{-# 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 <leon@melding-monads.com>
-- 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
    Name
x <- String -> Q Name
newName String
"x"
    [PatQ] -> ExpQ -> ExpQ
lamE [Name -> [PatQ] -> PatQ
conP 'Oid [Name -> PatQ
varP Name
x]] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((TypeInfo -> MatchQ) -> [TypeInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> MatchQ
alt [TypeInfo]
tys [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
catchAll])
   where
     alt :: TypeInfo -> MatchQ
     alt :: TypeInfo -> MatchQ
alt TypeInfo
ty = PatQ -> BodyQ -> [DecQ] -> MatchQ
match (TypeInfo -> PatQ
inlineTypoidP TypeInfo
ty) (ExpQ -> BodyQ
normalB [| True |]) []

     catchAll :: MatchQ
     catchAll :: MatchQ
catchAll = PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
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
conE 'Oid ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (TypeInfo -> Lit
getTypoid TypeInfo
ty)

inlineTypoidP :: TypeInfo -> PatQ
inlineTypoidP :: TypeInfo -> PatQ
inlineTypoidP TypeInfo
ty = Lit -> PatQ
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)