{-# 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 = 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
  -- |Lookup a value matching the given database name.
  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
  -- |List of all the values in the enum along with their database names.
  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

-- |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 :: [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