#if __GLASGOW_HASKELL__ >= 800
#endif
module Database.PostgreSQL.Typed.Enum
( PGEnum(..)
, dataPGEnum
) where
import Control.Arrow ((&&&))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Ix (Ix)
import Data.Maybe (fromJust, fromMaybe)
import Data.Tuple (swap)
import Data.Typeable (Typeable)
import qualified Language.Haskell.TH as TH
import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Dynamic
import Database.PostgreSQL.Typed.Protocol
import Database.PostgreSQL.Typed.TypeCache
import Database.PostgreSQL.Typed.TH
class (Eq a, Ord a, Enum a, Bounded a, PGRep a) => PGEnum a where
pgEnumName :: a -> PGName
pgEnumName a = fromJust $ lookup a pgEnumValues
pgEnumValue :: PGName -> Maybe a
pgEnumValue n = lookup n $ map swap pgEnumValues
pgEnumValues :: [(a, PGName)]
pgEnumValues = map (id &&& pgEnumName) $ enumFromTo minBound maxBound
dataPGEnum :: String
-> PGName
-> (String -> String)
-> TH.DecsQ
dataPGEnum typs pgenum valnf = do
(pgid, vals) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do
vals <- map (\([eo, v]) -> (pgDecodeRep eo, pgDecodeRep v)) . snd
<$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks
[ "SELECT enumtypid, enumlabel"
, " FROM pg_catalog.pg_enum"
, " WHERE enumtypid = ", pgLiteralRep pgenum, "::regtype"
, " ORDER BY enumsortorder"
])
case vals of
[] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": no values found"
(eo, _):_ -> do
et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return
=<< lookupPGType tpg eo
return (et, map snd vals)
let valn = map (TH.mkName . valnf . pgNameString &&& map (TH.IntegerL . fromIntegral) . pgNameBytes) vals
typl = TH.LitT (TH.StrTyLit $ pgNameString pgid)
dv <- TH.newName "x"
return $
[ TH.DataD [] typn []
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#endif
(map (\(n, _) -> TH.NormalC n []) valn) $
#if MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_template_haskell(2,12,0)
return $ TH.DerivClause Nothing $
#endif
map TH.ConT
#endif
[''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable]
, instanceD [] (TH.ConT ''PGType `TH.AppT` typl)
[ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt
]
, instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt)
[ TH.FunD 'pgEncode [TH.Clause [TH.WildP, TH.VarP dv]
(TH.NormalB $ TH.VarE 'pgNameBS `TH.AppE` (TH.VarE 'pgEnumName `TH.AppE` TH.VarE dv))
[]]
]
, instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt)
[ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv]
(TH.NormalB $ TH.VarE 'fromMaybe
`TH.AppE` (TH.AppE (TH.VarE 'error) $
TH.InfixE (Just $ TH.LitE (TH.StringL ("pgEnumValue " ++ show pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv))
`TH.AppE` (TH.VarE 'pgEnumValue `TH.AppE` (TH.ConE 'PGName
`TH.AppE` (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv))))
[]]
]
, instanceD [] (TH.ConT ''PGRep `TH.AppT` typt)
[ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl
]
, instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt)
[ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [TH.ConP n []]
(TH.NormalB $ namelit l)
[]) valn
, TH.FunD 'pgEnumValue $ map (\(n, l) ->
TH.Clause [TH.ConP 'PGName [TH.ListP (map TH.LitP l)]]
(TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n)
[]) valn
++ [TH.Clause [TH.WildP] (TH.NormalB $ TH.ConE 'Nothing) []]
, TH.FunD 'pgEnumValues [TH.Clause []
(TH.NormalB $ TH.ListE $ map (\(n, l) ->
TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` namelit l) valn)
[]]
]
, TH.PragmaD $ TH.AnnP (TH.TypeAnnotation typn) $ namelit $ map (TH.IntegerL . fromIntegral) $ pgNameBytes pgid
]
++ map (\(n, l) ->
TH.PragmaD $ TH.AnnP (TH.ValueAnnotation n) $ namelit l) valn
where
typn = TH.mkName typs
typt = TH.ConT typn
instanceD = TH.InstanceD
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#endif
namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l)