module Database.PostgreSQL.Query.TH.Enum
( derivePgEnum
, InflectorFunc
) where
import Data.FileEmbed
import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToField
import Language.Haskell.TH
#if !MIN_VERSION_base(4,8,0)
import Data.Traversable
import Control.Applicative
#endif
import qualified Data.Text.Encoding as T
import qualified Data.Text as T
type InflectorFunc = String -> String
derivePgEnum
:: InflectorFunc
-> Name
-> DecsQ
derivePgEnum infl typeName = do
constructors <- dataConstructors <$> reify typeName
tfInstance <- makeToField infl typeName constructors
ffInstance <- makeFromField infl typeName constructors
pure [tfInstance, ffInstance]
makeToField :: InflectorFunc
-> Name
-> [Con]
-> DecQ
makeToField i typeName constr = do
clauses <- traverse (makeToFieldClause i) constr
instanceD
(pure [])
(appT (conT ''ToField) (conT typeName))
[funD 'toField $ fmap pure clauses]
makeFromField :: InflectorFunc
-> Name
-> [Con]
-> Q Dec
makeFromField i typeName enumCons = do
f <- newName "f"
mb <- newName "mb"
byteSt <- newName "bs"
hName <- newName "h"
let
otherw = (,)
<$> normalG [|otherwise|]
<*> [|returnError ConversionFailed $(varE f) (show $(varE mb))|]
guards = map (makeFromFieldGuard i hName) enumCons ++ [otherw]
helper =
funD
hName
[clause
[varP byteSt]
(normalB [|((Just True) ==) (fmap (== $(varE byteSt)) $(varE mb))|])
[]
]
instanceD
(pure [])
(appT (conT ''FromField) (conT typeName))
[funD 'fromField [clause [varP f, varP mb] (guardedB guards) [helper]]]
makeFromFieldGuard :: InflectorFunc
-> Name
-> Con
-> Q (Guard, Exp)
makeFromFieldGuard i typeName con =
flip (withEnumConstructor i) con $ \nam ec -> do
let constr = conE nam
guard <- normalG $ appE (varE typeName) ec
expr <- appE (varE 'pure) constr
pure (guard, expr)
makeToFieldClause :: InflectorFunc
-> Con
-> ClauseQ
makeToFieldClause i con =
flip (withEnumConstructor i) con $ \nam ec -> do
clause [conP nam []] (normalB [|Escape $ec|]) []
withEnumConstructor :: InflectorFunc
-> (Name -> ExpQ -> Q a)
-> Con
-> Q a
withEnumConstructor i f = \case
(NormalC _ (_:_)) ->
error "constructors with arguments are not supported in makeToFieldClause"
(NormalC nam [] ) -> f nam inflectedBs
where inflectedT = T.pack $ i $ nameBase nam
inflectedBs = bsToExp $ T.encodeUtf8 inflectedT
_ ->
error "unsupported constructor in makeFromFieldClause"