{-# 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Oid [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> Q Match
alt [TypeInfo]
tys forall a. [a] -> [a] -> [a]
++ [Q Match
catchAll])
   where
     alt :: TypeInfo -> MatchQ
     alt :: TypeInfo -> Q Match
alt TypeInfo
ty = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (TypeInfo -> Q Pat
inlineTypoidP TypeInfo
ty) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| True |]) []

     catchAll :: MatchQ
     catchAll :: Q Match
catchAll = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (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 = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Oid forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (TypeInfo -> Lit
getTypoid TypeInfo
ty)

inlineTypoidP :: TypeInfo -> PatQ
inlineTypoidP :: TypeInfo -> Q Pat
inlineTypoidP TypeInfo
ty = 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
x)