{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#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
{-# MINIMAL pgEnumName | pgEnumValues #-}
pgEnumName :: a -> PGName
pgEnumName a
a = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a forall a. PGEnum a => [(a, PGName)]
pgEnumValues
pgEnumValue :: PGName -> Maybe a
pgEnumValue PGName
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PGName
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap forall a. PGEnum a => [(a, PGName)]
pgEnumValues
pgEnumValues :: [(a, PGName)]
pgEnumValues = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. PGEnum a => a -> PGName
pgEnumName) forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a -> [a]
enumFromTo forall a. Bounded a => a
minBound forall a. Bounded a => a
maxBound
dataPGEnum :: String
-> PGName
-> (String -> String)
-> TH.DecsQ
dataPGEnum :: [Char] -> PGName -> ([Char] -> [Char]) -> DecsQ
dataPGEnum [Char]
typs PGName
pgenum [Char] -> [Char]
valnf = do
(PGName
pgid, [PGName]
vals) <- forall a. IO a -> Q a
TH.runIO forall a b. (a -> b) -> a -> b
$ forall a. (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection forall a b. (a -> b) -> a -> b
$ \PGTypeConnection
tpg -> do
[(OID, PGName)]
vals <- forall a b. (a -> b) -> [a] -> [b]
map (\([PGValue
eo, PGValue
v]) -> (forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
eo, forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection -> ByteString -> IO (Int, [[PGValue]])
pgSimpleQuery (PGTypeConnection -> PGConnection
pgConnection PGTypeConnection
tpg) ([ByteString] -> ByteString
BSL.fromChunks
[ ByteString
"SELECT enumtypid, enumlabel"
, ByteString
" FROM pg_catalog.pg_enum"
, ByteString
" WHERE enumtypid = ", forall a. PGRep a => a -> ByteString
pgLiteralRep PGName
pgenum, ByteString
"::regtype"
, ByteString
" ORDER BY enumsortorder"
])
case [(OID, PGName)]
vals of
[] -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"dataPGEnum " forall a. [a] -> [a] -> [a]
++ [Char]
typs forall a. [a] -> [a] -> [a]
++ [Char]
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PGName
pgenum forall a. [a] -> [a] -> [a]
++ [Char]
": no values found"
(OID
eo, PGName
_):[(OID, PGName)]
_ -> do
PGName
et <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"dataPGEnum " forall a. [a] -> [a] -> [a]
++ [Char]
typs forall a. [a] -> [a] -> [a]
++ [Char]
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PGName
pgenum forall a. [a] -> [a] -> [a]
++ [Char]
": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") forall (m :: * -> *) a. Monad m => a -> m a
return
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> OID -> IO (Maybe PGName)
lookupPGType PGTypeConnection
tpg OID
eo
forall (m :: * -> *) a. Monad m => a -> m a
return (PGName
et, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(OID, PGName)]
vals)
let valn :: [(Name, [Lit])]
valn = forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Name
TH.mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
valnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Char]
pgNameString forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Lit
TH.IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes) [PGName]
vals
typl :: Type
typl = TyLit -> Type
TH.LitT ([Char] -> TyLit
TH.StrTyLit forall a b. (a -> b) -> a -> b
$ PGName -> [Char]
pgNameString PGName
pgid)
Name
dv <- forall (m :: * -> *). Quote m => [Char] -> m Name
TH.newName [Char]
"x"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
typn []
#if MIN_VERSION_template_haskell(2,11,0)
forall a. Maybe a
Nothing
#endif
(forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
_) -> Name -> [BangType] -> Con
TH.NormalC Name
n []) [(Name, [Lit])]
valn) forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_template_haskell(2,12,0)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe DerivStrategy -> Cxt -> DerivClause
TH.DerivClause forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
#endif
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
TH.ConT
#endif
[''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGType Type -> Type -> Type
`TH.AppT` Type
typl)
[ Name -> Type -> Type -> Dec
tySynInstD ''PGVal Type
typl Type
typt
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGParameter Type -> Type -> Type
`TH.AppT` Type
typl Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> [Clause] -> Dec
TH.FunD 'pgEncode [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> Pat
TH.VarP Name
dv]
(Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'pgNameBS Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.VarE 'pgEnumName Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv))
[]]
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGColumn Type -> Type -> Type
`TH.AppT` Type
typl Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> [Clause] -> Dec
TH.FunD 'pgDecode [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP, Name -> Pat
TH.VarP Name
dv]
(Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'fromMaybe
Exp -> Exp -> Exp
`TH.AppE` (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'error) forall a b. (a -> b) -> a -> b
$
Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Lit -> Exp
TH.LitE ([Char] -> Lit
TH.StringL ([Char]
"pgEnumValue " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PGName
pgid forall a. [a] -> [a] -> [a]
++ [Char]
": "))) (Name -> Exp
TH.VarE '(++)) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'BSC.unpack Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv))
Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.VarE 'pgEnumValue Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.ConE 'PGName
Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.VarE 'BS.unpack Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
dv))))
[]]
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGRep Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> Type -> Type -> Dec
tySynInstD ''PGRepType Type
typt Type
typl
]
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Name -> Type
TH.ConT ''PGEnum Type -> Type -> Type
`TH.AppT` Type
typt)
[ Name -> [Clause] -> Dec
TH.FunD 'pgEnumName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) -> [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> [Pat] -> Pat
conP Name
n []]
(Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit [Lit]
l)
[]) [(Name, [Lit])]
valn
, Name -> [Clause] -> Dec
TH.FunD 'pgEnumValue forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) ->
[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> [Pat] -> Pat
conP 'PGName [[Pat] -> Pat
TH.ListP (forall a b. (a -> b) -> [a] -> [b]
map Lit -> Pat
TH.LitP [Lit]
l)]]
(Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE 'Just Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.ConE Name
n)
[]) [(Name, [Lit])]
valn
forall a. [a] -> [a] -> [a]
++ [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP] (Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE 'Nothing) []]
, Name -> [Clause] -> Dec
TH.FunD 'pgEnumValues [[Pat] -> Body -> [Dec] -> Clause
TH.Clause []
(Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TH.ListE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) ->
Name -> Exp
TH.ConE '(,) Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.ConE Name
n Exp -> Exp -> Exp
`TH.AppE` [Lit] -> Exp
namelit [Lit]
l) [(Name, [Lit])]
valn)
[]]
]
, Pragma -> Dec
TH.PragmaD forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.TypeAnnotation Name
typn) forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Lit
TH.IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall a b. (a -> b) -> a -> b
$ PGName -> [Word8]
pgNameBytes PGName
pgid
]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) ->
Pragma -> Dec
TH.PragmaD forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.ValueAnnotation Name
n) forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit [Lit]
l) [(Name, [Lit])]
valn
where
typn :: Name
typn = [Char] -> Name
TH.mkName [Char]
typs
typt :: Type
typt = Name -> Type
TH.ConT Name
typn
instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD
#if MIN_VERSION_template_haskell(2,11,0)
forall a. Maybe a
Nothing
#endif
tySynInstD :: Name -> Type -> Type -> Dec
tySynInstD Name
c Type
l Type
t = TySynEqn -> Dec
TH.TySynInstD
#if MIN_VERSION_template_haskell(2,15,0)
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TH.TySynEqn forall a. Maybe a
Nothing (Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
c) Type
l)
#else
c $ TH.TySynEqn [l]
#endif
Type
t
namelit :: [Lit] -> Exp
namelit [Lit]
l = Name -> Exp
TH.ConE 'PGName Exp -> Exp -> Exp
`TH.AppE` [Exp] -> Exp
TH.ListE (forall a b. (a -> b) -> [a] -> [b]
map Lit -> Exp
TH.LitE [Lit]
l)
conP :: Name -> [Pat] -> Pat
conP Name
n [Pat]
p = Name -> Cxt -> [Pat] -> Pat
TH.ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
p