{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif

------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.TypeInfo.Macro
-- Copyright:   (c) 2013 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <[email protected]>
-- Stability:   experimental
--
-- A Template Haskell macro for efficiently checking membership in
-- a set of type oids.
--
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.TypeInfo.Macro
    ( mkCompats
    , inlineTypoid
    ) where

import Database.PostgreSQL.Simple.TypeInfo.Static
import Database.PostgreSQL.Simple.Types (Oid(..))
import Language.Haskell.TH

-- | Returns an expression that has type @'Oid' -> 'Bool'@,  true if the
--   oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
mkCompats :: [TypeInfo] -> ExpQ
mkCompats :: [TypeInfo] -> ExpQ
mkCompats [TypeInfo]
tys = do
    x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
   where
     alt :: TypeInfo -> MatchQ
     alt :: TypeInfo -> Q Match
alt TypeInfo
ty = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (TypeInfo -> Q Pat
inlineTypoidP TypeInfo
ty) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| True |]) []

     catchAll :: MatchQ
     catchAll :: Q Match
catchAll = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| False |]) []

-- | Literally substitute the 'typoid' of a 'TypeInfo' expression.
--   Returns an expression of type 'Oid'.  Useful because GHC tends
--   not to fold constants.
inlineTypoid :: TypeInfo -> ExpQ
inlineTypoid :: TypeInfo -> ExpQ
inlineTypoid TypeInfo
ty = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Oid ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (TypeInfo -> Lit
getTypoid TypeInfo
ty)

inlineTypoidP :: TypeInfo -> PatQ
inlineTypoidP :: TypeInfo -> Q Pat
inlineTypoidP TypeInfo
ty = Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (TypeInfo -> Lit
getTypoid TypeInfo
ty)

getTypoid :: TypeInfo -> Lit
getTypoid :: TypeInfo -> Lit
getTypoid TypeInfo
ty = let (Oid CUInt
x) = TypeInfo -> Oid
typoid TypeInfo
ty in Integer -> Lit
integerL (CUInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
x)