{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE EmptyCase #-}
module Database.Beam.Postgres.CustomTypes
    ( PgType, PgTypeCheck(..)
    , PgDataTypeSchema

    , IsPgCustomDataType(..)

    , PgHasEnum(..)

    , HasSqlValueSyntax, FromBackendRow

    , pgCustomEnumSchema, pgBoundedEnumSchema

    , pgCustomEnumActionProvider
    , pgCreateEnumActionProvider
    , pgDropEnumActionProvider

    , pgChecksForTypeSchema

    , pgEnumValueSyntax, pgParseEnum

    , createEnum
    , beamTypeForCustomPg
    ) where

import           Database.Beam
import           Database.Beam.Schema.Tables
import           Database.Beam.Backend.SQL
import           Database.Beam.Migrate
import           Database.Beam.Postgres.Types
import           Database.Beam.Postgres.Syntax

import           Control.Monad
import           Control.Monad.Free.Church
import           Data.Aeson (object, (.=))
import qualified Data.ByteString.Char8 as BC
import           Data.Functor.Const
import qualified Data.HashSet as HS
import           Data.Proxy (Proxy(..))
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import           Data.Text (Text)
import qualified Data.Text.Encoding as TE

import qualified Database.PostgreSQL.Simple.FromField as Pg

data PgType a
newtype PgTypeCheck = PgTypeCheck (Text -> SomeDatabasePredicate)

data PgDataTypeSchema a where
    PgDataTypeEnum :: HasSqlValueSyntax PgValueSyntax a => [a] -> PgDataTypeSchema a

class IsPgCustomDataType a where
    pgDataTypeName :: Proxy a -> Text
    pgDataTypeDescription :: PgDataTypeSchema a

pgCustomEnumSchema :: HasSqlValueSyntax PgValueSyntax a => [a] -> PgDataTypeSchema a
pgCustomEnumSchema :: [a] -> PgDataTypeSchema a
pgCustomEnumSchema = [a] -> PgDataTypeSchema a
forall a.
HasSqlValueSyntax PgValueSyntax a =>
[a] -> PgDataTypeSchema a
PgDataTypeEnum

pgBoundedEnumSchema :: ( Enum a, Bounded a, HasSqlValueSyntax PgValueSyntax a )
                    => PgDataTypeSchema a
pgBoundedEnumSchema :: PgDataTypeSchema a
pgBoundedEnumSchema = [a] -> PgDataTypeSchema a
forall a.
HasSqlValueSyntax PgValueSyntax a =>
[a] -> PgDataTypeSchema a
pgCustomEnumSchema [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]

pgCustomEnumActionProvider :: ActionProvider Postgres
pgCustomEnumActionProvider :: ActionProvider Postgres
pgCustomEnumActionProvider = ActionProvider Postgres
pgCreateEnumActionProvider ActionProvider Postgres
-> ActionProvider Postgres -> ActionProvider Postgres
forall a. Semigroup a => a -> a -> a
<> ActionProvider Postgres
pgDropEnumActionProvider

pgCreateEnumActionProvider :: ActionProvider Postgres
pgCreateEnumActionProvider :: ActionProvider Postgres
pgCreateEnumActionProvider =
  ActionProviderFn Postgres -> ActionProvider Postgres
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (ActionProviderFn Postgres -> ActionProvider Postgres)
-> ActionProviderFn Postgres -> ActionProvider Postgres
forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
findPre forall preCondition. Typeable preCondition => [preCondition]
findPost ->
  do enumP :: PgHasEnum
enumP@(PgHasEnum Text
nm [Text]
vals) <- [PgHasEnum]
forall preCondition. Typeable preCondition => [preCondition]
findPost
     [()] -> [()]
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$
      do (PgHasEnum Text
beforeNm [Text]
_) <- [PgHasEnum]
forall preCondition. Typeable preCondition => [preCondition]
findPre
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
beforeNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nm)

     let cmd :: PgCommandSyntax
cmd = Text -> [PgValueSyntax] -> PgCommandSyntax
pgCreateEnumSyntax Text
nm ((Text -> PgValueSyntax) -> [Text] -> [PgValueSyntax]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> PgValueSyntax
forall expr ty. HasSqlValueSyntax expr ty => ty -> expr
sqlValueSyntax [Text]
vals)
     PotentialAction Postgres -> [PotentialAction Postgres]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand Postgres)
-> Text
-> Int
-> PotentialAction Postgres
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [PgHasEnum -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p PgHasEnum
enumP])
                           (MigrationCommand Postgres -> Seq (MigrationCommand Postgres)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BeamSqlBackendSyntax Postgres
-> MigrationDataLoss -> MigrationCommand Postgres
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax Postgres
PgCommandSyntax
cmd MigrationDataLoss
MigrationKeepsData))
                           (Text
"Create the enumeration " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm) Int
1)

pgDropEnumActionProvider :: ActionProvider Postgres
pgDropEnumActionProvider :: ActionProvider Postgres
pgDropEnumActionProvider =
  ActionProviderFn Postgres -> ActionProvider Postgres
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (ActionProviderFn Postgres -> ActionProvider Postgres)
-> ActionProviderFn Postgres -> ActionProvider Postgres
forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
findPre forall preCondition. Typeable preCondition => [preCondition]
findPost ->
  do enumP :: PgHasEnum
enumP@(PgHasEnum Text
nm [Text]
_) <- [PgHasEnum]
forall preCondition. Typeable preCondition => [preCondition]
findPre
     [()] -> [()]
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$
      do (PgHasEnum Text
afterNm [Text]
_) <- [PgHasEnum]
forall preCondition. Typeable preCondition => [preCondition]
findPost
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
afterNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nm)

     let cmd :: PgCommandSyntax
cmd = Text -> PgCommandSyntax
pgDropTypeSyntax Text
nm
     PotentialAction Postgres -> [PotentialAction Postgres]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand Postgres)
-> Text
-> Int
-> PotentialAction Postgres
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [PgHasEnum -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p PgHasEnum
enumP]) HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty
                           (MigrationCommand Postgres -> Seq (MigrationCommand Postgres)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BeamSqlBackendSyntax Postgres
-> MigrationDataLoss -> MigrationCommand Postgres
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax Postgres
PgCommandSyntax
cmd MigrationDataLoss
MigrationKeepsData))
                           (Text
"Drop the enumeration type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm) Int
1)

pgChecksForTypeSchema :: PgDataTypeSchema a -> [ PgTypeCheck ]
pgChecksForTypeSchema :: PgDataTypeSchema a -> [PgTypeCheck]
pgChecksForTypeSchema (PgDataTypeEnum [a]
vals) =
  let valTxts :: [Text]
valTxts = (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall ty. HasSqlValueSyntax PgValueSyntax ty => ty -> Text
encodeToString [a]
vals

      -- TODO better reporting
      encodeToString :: ty -> Text
encodeToString ty
val =
        let PgValueSyntax (PgSyntax PgSyntaxM ()
syntax) = ty -> PgValueSyntax
forall expr ty. HasSqlValueSyntax expr ty => ty -> expr
sqlValueSyntax ty
val
        in PgSyntaxM () -> (() -> Text) -> (PgSyntaxF Text -> Text) -> Text
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF PgSyntaxM ()
syntax (\()
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Expecting a simple text encoding for enumeration type")
                       (\case
                           EmitByteString ByteString
"'" Text
next -> Text
next
                           EscapeString ByteString
s Text
_ -> ByteString -> Text
TE.decodeUtf8 ByteString
s -- TODO Make this more robust
                           PgSyntaxF Text
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Expecting a simple text encoding for enumeration type")
  in [ (Text -> SomeDatabasePredicate) -> PgTypeCheck
PgTypeCheck (\Text
nm -> PgHasEnum -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p (Text -> [Text] -> PgHasEnum
PgHasEnum Text
nm [Text]
valTxts)) ]

instance IsDatabaseEntity Postgres (PgType a) where

  data DatabaseEntityDescriptor Postgres (PgType a) where
      PgTypeDescriptor :: Maybe Text -> Text -> PgDataTypeSyntax
                       -> DatabaseEntityDescriptor Postgres (PgType a)

  type DatabaseEntityDefaultRequirements Postgres (PgType a) =
      ( HasSqlValueSyntax PgValueSyntax a
      , FromBackendRow Postgres a
      , IsPgCustomDataType a)

  type DatabaseEntityRegularRequirements Postgres (PgType a) =
      ( HasSqlValueSyntax PgValueSyntax a
      , FromBackendRow Postgres a )

  dbEntityName :: (Text -> f Text)
-> DatabaseEntityDescriptor Postgres (PgType a)
-> f (DatabaseEntityDescriptor Postgres (PgType a))
dbEntityName Text -> f Text
f (PgTypeDescriptor sch nm ty) = (\Text
nm' -> Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
forall a.
Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
PgTypeDescriptor Maybe Text
sch Text
nm' PgDataTypeSyntax
ty) (Text -> DatabaseEntityDescriptor Postgres (PgType a))
-> f Text -> f (DatabaseEntityDescriptor Postgres (PgType a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f Text
nm
  dbEntitySchema :: (Maybe Text -> f (Maybe Text))
-> DatabaseEntityDescriptor Postgres (PgType a)
-> f (DatabaseEntityDescriptor Postgres (PgType a))
dbEntitySchema Maybe Text -> f (Maybe Text)
f (PgTypeDescriptor sch nm ty) = Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
forall a.
Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
PgTypeDescriptor (Maybe Text
 -> Text
 -> PgDataTypeSyntax
 -> DatabaseEntityDescriptor Postgres (PgType a))
-> f (Maybe Text)
-> f (Text
      -> PgDataTypeSyntax
      -> DatabaseEntityDescriptor Postgres (PgType a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> f (Maybe Text)
f Maybe Text
sch f (Text
   -> PgDataTypeSyntax
   -> DatabaseEntityDescriptor Postgres (PgType a))
-> f Text
-> f (PgDataTypeSyntax
      -> DatabaseEntityDescriptor Postgres (PgType a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> f Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
nm f (PgDataTypeSyntax
   -> DatabaseEntityDescriptor Postgres (PgType a))
-> f PgDataTypeSyntax
-> f (DatabaseEntityDescriptor Postgres (PgType a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PgDataTypeSyntax -> f PgDataTypeSyntax
forall (f :: * -> *) a. Applicative f => a -> f a
pure PgDataTypeSyntax
ty
  dbEntityAuto :: Text -> DatabaseEntityDescriptor Postgres (PgType a)
dbEntityAuto Text
_ = Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
forall a.
Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
PgTypeDescriptor Maybe Text
forall a. Maybe a
Nothing Text
typeName
                                    (PgDataTypeDescr
-> PgSyntax -> BeamSerializedDataType -> PgDataTypeSyntax
PgDataTypeSyntax (Text -> PgDataTypeDescr
PgDataTypeDescrDomain Text
typeName)
                                                      (Text -> PgSyntax
pgQuotedIdentifier Text
typeName)
                                                      (Value -> BeamSerializedDataType
pgDataTypeJSON ([Pair] -> Value
object [ Key
"customType" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
typeName])))
      where
        typeName :: Text
typeName = Proxy a -> Text
forall a. IsPgCustomDataType a => Proxy a -> Text
pgDataTypeName (Proxy a
forall k (t :: k). Proxy t
Proxy @a)

instance IsCheckedDatabaseEntity Postgres (PgType a) where
    data CheckedDatabaseEntityDescriptor Postgres (PgType a) where
        CheckedPgTypeDescriptor :: DatabaseEntityDescriptor Postgres (PgType a)
                                -> [ PgTypeCheck ]
                                -> CheckedDatabaseEntityDescriptor Postgres (PgType a)
    type CheckedDatabaseEntityDefaultRequirements Postgres (PgType a) =
        DatabaseEntityDefaultRequirements Postgres (PgType a)

    unChecked :: (DatabaseEntityDescriptor Postgres (PgType a)
 -> f (DatabaseEntityDescriptor Postgres (PgType a)))
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
-> f (CheckedDatabaseEntityDescriptor Postgres (PgType a))
unChecked DatabaseEntityDescriptor Postgres (PgType a)
-> f (DatabaseEntityDescriptor Postgres (PgType a))
f (CheckedPgTypeDescriptor ty d) = (DatabaseEntityDescriptor Postgres (PgType a)
 -> CheckedDatabaseEntityDescriptor Postgres (PgType a))
-> f (DatabaseEntityDescriptor Postgres (PgType a))
-> f (CheckedDatabaseEntityDescriptor Postgres (PgType a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DatabaseEntityDescriptor Postgres (PgType a)
ty' -> DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
forall a.
DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
CheckedPgTypeDescriptor DatabaseEntityDescriptor Postgres (PgType a)
ty' [PgTypeCheck]
d) (DatabaseEntityDescriptor Postgres (PgType a)
-> f (DatabaseEntityDescriptor Postgres (PgType a))
f DatabaseEntityDescriptor Postgres (PgType a)
ty)
    collectEntityChecks :: CheckedDatabaseEntityDescriptor Postgres (PgType a)
-> [SomeDatabasePredicate]
collectEntityChecks (CheckedPgTypeDescriptor e chks) =
        (PgTypeCheck -> SomeDatabasePredicate)
-> [PgTypeCheck] -> [SomeDatabasePredicate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PgTypeCheck Text -> SomeDatabasePredicate
mkCheck) -> Text -> SomeDatabasePredicate
mkCheck (Const Text (DatabaseEntityDescriptor Postgres (PgType a)) -> Text
forall a k (b :: k). Const a b -> a
getConst ((Text -> Const Text Text)
-> DatabaseEntityDescriptor Postgres (PgType a)
-> Const Text (DatabaseEntityDescriptor Postgres (PgType a))
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName Text -> Const Text Text
forall k a (b :: k). a -> Const a b
Const DatabaseEntityDescriptor Postgres (PgType a)
e))) [PgTypeCheck]
chks
    checkedDbEntityAuto :: Text -> CheckedDatabaseEntityDescriptor Postgres (PgType a)
checkedDbEntityAuto Text
nm = DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
forall a.
DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
CheckedPgTypeDescriptor (Text -> DatabaseEntityDescriptor Postgres (PgType a)
forall be entityType.
(IsDatabaseEntity be entityType,
 DatabaseEntityDefaultRequirements be entityType) =>
Text -> DatabaseEntityDescriptor be entityType
dbEntityAuto Text
nm)
                                                     (PgDataTypeSchema a -> [PgTypeCheck]
forall a. PgDataTypeSchema a -> [PgTypeCheck]
pgChecksForTypeSchema (IsPgCustomDataType a => PgDataTypeSchema a
forall a. IsPgCustomDataType a => PgDataTypeSchema a
pgDataTypeDescription @a))

instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor Postgres (PgType a))) where
    renamingFields :: (NonEmpty Text -> Text)
-> FieldRenamer (DatabaseEntityDescriptor Postgres (PgType a))
renamingFields NonEmpty Text -> Text
_ = (DatabaseEntityDescriptor Postgres (PgType a)
 -> DatabaseEntityDescriptor Postgres (PgType a))
-> FieldRenamer (DatabaseEntityDescriptor Postgres (PgType a))
forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer DatabaseEntityDescriptor Postgres (PgType a)
-> DatabaseEntityDescriptor Postgres (PgType a)
forall a. a -> a
id

createEnum :: forall a db
            . ( HasSqlValueSyntax PgValueSyntax a
              , Enum a, Bounded a )
           => Text -> Migration Postgres (CheckedDatabaseEntity Postgres db (PgType a))
createEnum :: Text
-> Migration
     Postgres (CheckedDatabaseEntity Postgres db (PgType a))
createEnum Text
nm = do
  BeamSqlBackendSyntax Postgres
-> Maybe (BeamSqlBackendSyntax Postgres) -> Migration Postgres ()
forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (Text -> [PgValueSyntax] -> PgCommandSyntax
pgCreateEnumSyntax Text
nm ((a -> PgValueSyntax) -> [a] -> [PgValueSyntax]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> PgValueSyntax
forall expr ty. HasSqlValueSyntax expr ty => ty -> expr
sqlValueSyntax [a
forall a. Bounded a => a
minBound..(a
forall a. Bounded a => a
maxBound::a)]))
         (PgCommandSyntax -> Maybe PgCommandSyntax
forall a. a -> Maybe a
Just (Text -> PgCommandSyntax
pgDropTypeSyntax Text
nm))

  let tyDesc :: DatabaseEntityDescriptor Postgres (PgType a)
tyDesc = Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
forall a.
Maybe Text
-> Text
-> PgDataTypeSyntax
-> DatabaseEntityDescriptor Postgres (PgType a)
PgTypeDescriptor Maybe Text
forall a. Maybe a
Nothing Text
nm (PgDataTypeSyntax -> DatabaseEntityDescriptor Postgres (PgType a))
-> PgDataTypeSyntax -> DatabaseEntityDescriptor Postgres (PgType a)
forall a b. (a -> b) -> a -> b
$
               PgDataTypeDescr
-> PgSyntax -> BeamSerializedDataType -> PgDataTypeSyntax
PgDataTypeSyntax (Text -> PgDataTypeDescr
PgDataTypeDescrDomain Text
nm)
                                (Text -> PgSyntax
pgQuotedIdentifier Text
nm)
                                (Value -> BeamSerializedDataType
pgDataTypeJSON ([Pair] -> Value
object [ Key
"customType" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
nm ]))

  CheckedDatabaseEntity Postgres db (PgType a)
-> Migration
     Postgres (CheckedDatabaseEntity Postgres db (PgType a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckedDatabaseEntityDescriptor Postgres (PgType a)
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity Postgres db (PgType a)
forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity
          (DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
forall a.
DatabaseEntityDescriptor Postgres (PgType a)
-> [PgTypeCheck]
-> CheckedDatabaseEntityDescriptor Postgres (PgType a)
CheckedPgTypeDescriptor DatabaseEntityDescriptor Postgres (PgType a)
tyDesc
             (PgDataTypeSchema a -> [PgTypeCheck]
forall a. PgDataTypeSchema a -> [PgTypeCheck]
pgChecksForTypeSchema ([a] -> PgDataTypeSchema a
forall a.
HasSqlValueSyntax PgValueSyntax a =>
[a] -> PgDataTypeSchema a
PgDataTypeEnum [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound::a])))
          [])


pgEnumValueSyntax :: (a -> String) -> a -> PgValueSyntax
pgEnumValueSyntax :: (a -> [Char]) -> a -> PgValueSyntax
pgEnumValueSyntax a -> [Char]
namer = [Char] -> PgValueSyntax
forall expr ty. HasSqlValueSyntax expr ty => ty -> expr
sqlValueSyntax ([Char] -> PgValueSyntax) -> (a -> [Char]) -> a -> PgValueSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
namer

newtype PgRawString = PgRawString String
instance FromBackendRow Postgres PgRawString
instance Pg.FromField PgRawString where
    fromField :: FieldParser PgRawString
fromField Field
f Maybe ByteString
Nothing = ([Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> ResultError)
-> Field -> [Char] -> Conversion PgRawString
forall a err.
(Typeable a, Exception err) =>
([Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> err)
-> Field -> [Char] -> Conversion a
Pg.returnError [Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> ResultError
Pg.UnexpectedNull Field
f [Char]
"When parsing enumeration string"
    fromField Field
_ (Just ByteString
d) = PgRawString -> Conversion PgRawString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> PgRawString
PgRawString (ByteString -> [Char]
BC.unpack ByteString
d))

pgParseEnum :: (Enum a, Bounded a) => (a -> String)
            -> FromBackendRowM Postgres a
pgParseEnum :: (a -> [Char]) -> FromBackendRowM Postgres a
pgParseEnum a -> [Char]
namer =
  let allNames :: [([Char], a)]
allNames = (a -> ([Char], a)) -> [a] -> [([Char], a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> [Char]
namer a
x, a
x)) [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]
  in do
    PgRawString [Char]
name <- FromBackendRowM Postgres PgRawString
forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow
    case [Char] -> [([Char], a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name [([Char], a)]
allNames of
      Maybe a
Nothing -> [Char] -> FromBackendRowM Postgres a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Invalid postgres enumeration value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name)
      Just  a
v -> a -> FromBackendRowM Postgres a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

beamTypeForCustomPg :: CheckedDatabaseEntity Postgres db (PgType a) -> DataType Postgres a
beamTypeForCustomPg :: CheckedDatabaseEntity Postgres db (PgType a) -> DataType Postgres a
beamTypeForCustomPg (CheckedDatabaseEntity (CheckedPgTypeDescriptor (PgTypeDescriptor _ _ dt) _) [SomeDatabasePredicate]
_)
    = BeamSqlBackendCastTargetSyntax Postgres -> DataType Postgres a
forall be a. BeamSqlBackendCastTargetSyntax be -> DataType be a
DataType BeamSqlBackendCastTargetSyntax Postgres
PgDataTypeSyntax
dt