{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- |
-- Module: Database.PostgreSQL.Typed.Enum
-- Copyright: 2015 Dylan Simon
-- 
-- Support for PostgreSQL enums.

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

-- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'.
class (Eq a, Ord a, Enum a, Bounded a, PGRep a) => PGEnum a where
  {-# MINIMAL pgEnumName | pgEnumValues #-}
  -- |The database name of a value.
  pgEnumName :: a -> PGName
  pgEnumName a
a = Maybe PGName -> PGName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe PGName -> PGName) -> Maybe PGName -> PGName
forall a b. (a -> b) -> a -> b
$ a -> [(a, PGName)] -> Maybe PGName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a [(a, PGName)]
forall a. PGEnum a => [(a, PGName)]
pgEnumValues
  -- |Lookup a value matching the given database name.
  pgEnumValue :: PGName -> Maybe a
  pgEnumValue PGName
n = PGName -> [(PGName, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PGName
n ([(PGName, a)] -> Maybe a) -> [(PGName, a)] -> Maybe a
forall a b. (a -> b) -> a -> b
$ ((a, PGName) -> (PGName, a)) -> [(a, PGName)] -> [(PGName, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a, PGName) -> (PGName, a)
forall a b. (a, b) -> (b, a)
swap [(a, PGName)]
forall a. PGEnum a => [(a, PGName)]
pgEnumValues
  -- |List of all the values in the enum along with their database names.
  pgEnumValues :: [(a, PGName)]
  pgEnumValues = (a -> (a, PGName)) -> [a] -> [(a, PGName)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a
forall a. a -> a
id (a -> a) -> (a -> PGName) -> a -> (a, PGName)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> PGName
forall a. PGEnum a => a -> PGName
pgEnumName) ([a] -> [(a, PGName)]) -> [a] -> [(a, PGName)]
forall a b. (a -> b) -> a -> b
$ a -> a -> [a]
forall a. Enum a => a -> a -> [a]
enumFromTo a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound

-- |Create a new enum type corresponding to the given PostgreSQL enum type.
-- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\')@, then
-- @dataPGEnum \"Foo\" \"foo\" (\"Foo_\"++)@ will be equivalent to:
-- 
-- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable)
-- > instance PGType "foo" where PGVal "foo" = Foo
-- > instance PGParameter "foo" Foo where ...
-- > instance PGColumn "foo" Foo where ...
-- > instance PGRep Foo where PGRepType = "foo"
-- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")]
--
-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies
dataPGEnum :: String -- ^ Haskell type to create
  -> PGName -- ^ PostgreSQL enum type name
  -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ (input is 'pgNameString')
  -> TH.DecsQ
dataPGEnum :: String -> PGName -> (String -> String) -> DecsQ
dataPGEnum String
typs PGName
pgenum String -> String
valnf = do
  (PGName
pgid, [PGName]
vals) <- IO (PGName, [PGName]) -> Q (PGName, [PGName])
forall a. IO a -> Q a
TH.runIO (IO (PGName, [PGName]) -> Q (PGName, [PGName]))
-> IO (PGName, [PGName]) -> Q (PGName, [PGName])
forall a b. (a -> b) -> a -> b
$ (PGTypeConnection -> IO (PGName, [PGName]))
-> IO (PGName, [PGName])
forall a. (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection ((PGTypeConnection -> IO (PGName, [PGName]))
 -> IO (PGName, [PGName]))
-> (PGTypeConnection -> IO (PGName, [PGName]))
-> IO (PGName, [PGName])
forall a b. (a -> b) -> a -> b
$ \PGTypeConnection
tpg -> do
    [(OID, PGName)]
vals <- ([PGValue] -> (OID, PGName)) -> [[PGValue]] -> [(OID, PGName)]
forall a b. (a -> b) -> [a] -> [b]
map (\([PGValue
eo, PGValue
v]) -> (PGValue -> OID
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
eo, PGValue -> PGName
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
v)) ([[PGValue]] -> [(OID, PGName)])
-> ((Int, [[PGValue]]) -> [[PGValue]])
-> (Int, [[PGValue]])
-> [(OID, PGName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [[PGValue]]) -> [[PGValue]]
forall a b. (a, b) -> b
snd
      ((Int, [[PGValue]]) -> [(OID, PGName)])
-> IO (Int, [[PGValue]]) -> IO [(OID, PGName)]
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 = ", PGName -> ByteString
forall a. PGRep a => a -> ByteString
pgLiteralRep PGName
pgenum, ByteString
"::regtype"
        , ByteString
" ORDER BY enumsortorder"
        ])
    case [(OID, PGName)]
vals of
      [] -> String -> IO (PGName, [PGName])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (PGName, [PGName]))
-> String -> IO (PGName, [PGName])
forall a b. (a -> b) -> a -> b
$ String
"dataPGEnum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgenum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": no values found"
      (OID
eo, PGName
_):[(OID, PGName)]
_ -> do
        PGName
et <- IO PGName -> (PGName -> IO PGName) -> Maybe PGName -> IO PGName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO PGName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO PGName) -> String -> IO PGName
forall a b. (a -> b) -> a -> b
$ String
"dataPGEnum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgenum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") PGName -> IO PGName
forall (m :: * -> *) a. Monad m => a -> m a
return
          (Maybe PGName -> IO PGName) -> IO (Maybe PGName) -> IO PGName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> OID -> IO (Maybe PGName)
lookupPGType PGTypeConnection
tpg OID
eo
        (PGName, [PGName]) -> IO (PGName, [PGName])
forall (m :: * -> *) a. Monad m => a -> m a
return (PGName
et, ((OID, PGName) -> PGName) -> [(OID, PGName)] -> [PGName]
forall a b. (a -> b) -> [a] -> [b]
map (OID, PGName) -> PGName
forall a b. (a, b) -> b
snd [(OID, PGName)]
vals)
  let valn :: [(Name, [Lit])]
valn = (PGName -> (Name, [Lit])) -> [PGName] -> [(Name, [Lit])]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
TH.mkName (String -> Name) -> (PGName -> String) -> PGName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
valnf (String -> String) -> (PGName -> String) -> PGName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> String
pgNameString (PGName -> Name) -> (PGName -> [Lit]) -> PGName -> (Name, [Lit])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Word8 -> Lit) -> [Word8] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Lit
TH.IntegerL (Integer -> Lit) -> (Word8 -> Integer) -> Word8 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> [Lit]) -> (PGName -> [Word8]) -> PGName -> [Lit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes) [PGName]
vals
      typl :: Type
typl = TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString PGName
pgid)
  Name
dv <- String -> Q Name
TH.newName String
"x"
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
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)
      Maybe Type
forall a. Maybe a
Nothing
#endif
      (((Name, [Lit]) -> Con) -> [(Name, [Lit])] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
_) -> Name -> [BangType] -> Con
TH.NormalC Name
n []) [(Name, [Lit])]
valn) ([DerivClause] -> Dec) -> [DerivClause] -> Dec
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_template_haskell(2,12,0)
      DerivClause -> [DerivClause]
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivClause -> [DerivClause]) -> DerivClause -> [DerivClause]
forall a b. (a -> b) -> a -> b
$ Maybe DerivStrategy -> Cxt -> DerivClause
TH.DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Cxt -> DerivClause) -> Cxt -> DerivClause
forall a b. (a -> b) -> a -> b
$
#endif
      (Name -> Type) -> [Name] -> Cxt
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 (Exp -> Body) -> Exp -> Body
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 (Exp -> Body) -> Exp -> Body
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) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
            Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
TH.LitE (String -> Lit
TH.StringL (String
"pgEnumValue " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
pgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "))) (Name -> Exp
TH.VarE '(++)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
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 ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ ((Name, [Lit]) -> Clause) -> [(Name, [Lit])] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) -> [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> [Pat] -> Pat
TH.ConP Name
n []]
        (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit [Lit]
l)
        []) [(Name, [Lit])]
valn
      , Name -> [Clause] -> Dec
TH.FunD 'pgEnumValue ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ ((Name, [Lit]) -> Clause) -> [(Name, [Lit])] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) ->
          [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> [Pat] -> Pat
TH.ConP 'PGName [[Pat] -> Pat
TH.ListP ((Lit -> Pat) -> [Lit] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Lit -> Pat
TH.LitP [Lit]
l)]]
            (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
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
          [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
TH.WildP] (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
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 (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ ((Name, [Lit]) -> Exp) -> [(Name, [Lit])] -> [Exp]
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 (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.TypeAnnotation Name
typn) (Exp -> Pragma) -> Exp -> Pragma
forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit ([Lit] -> Exp) -> [Lit] -> Exp
forall a b. (a -> b) -> a -> b
$ (Word8 -> Lit) -> [Word8] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Lit
TH.IntegerL (Integer -> Lit) -> (Word8 -> Integer) -> Word8 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> [Lit]) -> [Word8] -> [Lit]
forall a b. (a -> b) -> a -> b
$ PGName -> [Word8]
pgNameBytes PGName
pgid
    ]
    [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ ((Name, [Lit]) -> Dec) -> [(Name, [Lit])] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, [Lit]
l) ->
      Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ AnnTarget -> Exp -> Pragma
TH.AnnP (Name -> AnnTarget
TH.ValueAnnotation Name
n) (Exp -> Pragma) -> Exp -> Pragma
forall a b. (a -> b) -> a -> b
$ [Lit] -> Exp
namelit [Lit]
l) [(Name, [Lit])]
valn
  where
  typn :: Name
typn = String -> Name
TH.mkName String
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)
      Maybe Overlap
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)
    (TySynEqn -> Dec) -> TySynEqn -> Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TH.TySynEqn Maybe [TyVarBndr]
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 ((Lit -> Exp) -> [Lit] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Lit -> Exp
TH.LitE [Lit]
l)