{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}

-- | Instances that allow us to use Haskell as a backend syntax. This allows us
-- to use migrations defined a la 'Database.Beam.Migrate.SQL' to generate a beam
-- schema.
--
-- Mainly of interest to backends.
--
-- Unfortunately, we define some orphan 'Hashable' instances that aren't defined
-- for us in @haskell-src-exts@.
module Database.Beam.Haskell.Syntax where

import           Database.Beam
import           Database.Beam.Backend.SQL
import           Database.Beam.Backend.SQL.AST
import           Database.Beam.Backend.SQL.Builder
import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..))
import           Database.Beam.Migrate.SQL.SQL92
import           Database.Beam.Migrate.SQL.Types
import           Database.Beam.Migrate.Serialization

import           Data.Char (toLower, toUpper)
import           Data.Hashable
import           Data.Int
import           Data.List (find, nub)
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.Set as S
import           Data.String
import qualified Data.Text as T
#if !MIN_VERSION_base(4, 11, 0)
import           Data.Semigroup
#endif

import qualified Language.Haskell.Exts as Hs

import           Text.PrettyPrint (render)

newtype HsDbField = HsDbField { HsDbField -> Type () -> Type ()
buildHsDbField :: Hs.Type () -> Hs.Type () }

data HsConstraintDefinition
  = HsConstraintDefinition
  { HsConstraintDefinition -> HsExpr
hsConstraintDefinitionConstraint :: HsExpr }
  deriving (Int -> HsConstraintDefinition -> ShowS
[HsConstraintDefinition] -> ShowS
HsConstraintDefinition -> String
(Int -> HsConstraintDefinition -> ShowS)
-> (HsConstraintDefinition -> String)
-> ([HsConstraintDefinition] -> ShowS)
-> Show HsConstraintDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsConstraintDefinition] -> ShowS
$cshowList :: [HsConstraintDefinition] -> ShowS
show :: HsConstraintDefinition -> String
$cshow :: HsConstraintDefinition -> String
showsPrec :: Int -> HsConstraintDefinition -> ShowS
$cshowsPrec :: Int -> HsConstraintDefinition -> ShowS
Show, HsConstraintDefinition -> HsConstraintDefinition -> Bool
(HsConstraintDefinition -> HsConstraintDefinition -> Bool)
-> (HsConstraintDefinition -> HsConstraintDefinition -> Bool)
-> Eq HsConstraintDefinition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsConstraintDefinition -> HsConstraintDefinition -> Bool
$c/= :: HsConstraintDefinition -> HsConstraintDefinition -> Bool
== :: HsConstraintDefinition -> HsConstraintDefinition -> Bool
$c== :: HsConstraintDefinition -> HsConstraintDefinition -> Bool
Eq, (forall x. HsConstraintDefinition -> Rep HsConstraintDefinition x)
-> (forall x.
    Rep HsConstraintDefinition x -> HsConstraintDefinition)
-> Generic HsConstraintDefinition
forall x. Rep HsConstraintDefinition x -> HsConstraintDefinition
forall x. HsConstraintDefinition -> Rep HsConstraintDefinition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsConstraintDefinition x -> HsConstraintDefinition
$cfrom :: forall x. HsConstraintDefinition -> Rep HsConstraintDefinition x
Generic)
instance Hashable HsConstraintDefinition
instance Sql92DisplaySyntax HsConstraintDefinition where
  displaySyntax :: HsConstraintDefinition -> String
displaySyntax = HsConstraintDefinition -> String
forall a. Show a => a -> String
show

newtype HsEntityName = HsEntityName { HsEntityName -> String
getHsEntityName :: String } deriving (Int -> HsEntityName -> ShowS
[HsEntityName] -> ShowS
HsEntityName -> String
(Int -> HsEntityName -> ShowS)
-> (HsEntityName -> String)
-> ([HsEntityName] -> ShowS)
-> Show HsEntityName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsEntityName] -> ShowS
$cshowList :: [HsEntityName] -> ShowS
show :: HsEntityName -> String
$cshow :: HsEntityName -> String
showsPrec :: Int -> HsEntityName -> ShowS
$cshowsPrec :: Int -> HsEntityName -> ShowS
Show, HsEntityName -> HsEntityName -> Bool
(HsEntityName -> HsEntityName -> Bool)
-> (HsEntityName -> HsEntityName -> Bool) -> Eq HsEntityName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsEntityName -> HsEntityName -> Bool
$c/= :: HsEntityName -> HsEntityName -> Bool
== :: HsEntityName -> HsEntityName -> Bool
$c== :: HsEntityName -> HsEntityName -> Bool
Eq, Eq HsEntityName
Eq HsEntityName
-> (HsEntityName -> HsEntityName -> Ordering)
-> (HsEntityName -> HsEntityName -> Bool)
-> (HsEntityName -> HsEntityName -> Bool)
-> (HsEntityName -> HsEntityName -> Bool)
-> (HsEntityName -> HsEntityName -> Bool)
-> (HsEntityName -> HsEntityName -> HsEntityName)
-> (HsEntityName -> HsEntityName -> HsEntityName)
-> Ord HsEntityName
HsEntityName -> HsEntityName -> Bool
HsEntityName -> HsEntityName -> Ordering
HsEntityName -> HsEntityName -> HsEntityName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HsEntityName -> HsEntityName -> HsEntityName
$cmin :: HsEntityName -> HsEntityName -> HsEntityName
max :: HsEntityName -> HsEntityName -> HsEntityName
$cmax :: HsEntityName -> HsEntityName -> HsEntityName
>= :: HsEntityName -> HsEntityName -> Bool
$c>= :: HsEntityName -> HsEntityName -> Bool
> :: HsEntityName -> HsEntityName -> Bool
$c> :: HsEntityName -> HsEntityName -> Bool
<= :: HsEntityName -> HsEntityName -> Bool
$c<= :: HsEntityName -> HsEntityName -> Bool
< :: HsEntityName -> HsEntityName -> Bool
$c< :: HsEntityName -> HsEntityName -> Bool
compare :: HsEntityName -> HsEntityName -> Ordering
$ccompare :: HsEntityName -> HsEntityName -> Ordering
$cp1Ord :: Eq HsEntityName
Ord, String -> HsEntityName
(String -> HsEntityName) -> IsString HsEntityName
forall a. (String -> a) -> IsString a
fromString :: String -> HsEntityName
$cfromString :: String -> HsEntityName
IsString)

data HsImport = HsImportAll | HsImportSome (S.Set (Hs.ImportSpec ()))
  deriving (Int -> HsImport -> ShowS
[HsImport] -> ShowS
HsImport -> String
(Int -> HsImport -> ShowS)
-> (HsImport -> String) -> ([HsImport] -> ShowS) -> Show HsImport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsImport] -> ShowS
$cshowList :: [HsImport] -> ShowS
show :: HsImport -> String
$cshow :: HsImport -> String
showsPrec :: Int -> HsImport -> ShowS
$cshowsPrec :: Int -> HsImport -> ShowS
Show, HsImport -> HsImport -> Bool
(HsImport -> HsImport -> Bool)
-> (HsImport -> HsImport -> Bool) -> Eq HsImport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsImport -> HsImport -> Bool
$c/= :: HsImport -> HsImport -> Bool
== :: HsImport -> HsImport -> Bool
$c== :: HsImport -> HsImport -> Bool
Eq, (forall x. HsImport -> Rep HsImport x)
-> (forall x. Rep HsImport x -> HsImport) -> Generic HsImport
forall x. Rep HsImport x -> HsImport
forall x. HsImport -> Rep HsImport x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsImport x -> HsImport
$cfrom :: forall x. HsImport -> Rep HsImport x
Generic)
instance Hashable HsImport
instance Semigroup HsImport where
  <> :: HsImport -> HsImport -> HsImport
(<>) = HsImport -> HsImport -> HsImport
forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsImport where
  mempty :: HsImport
mempty = Set (ImportSpec ()) -> HsImport
HsImportSome Set (ImportSpec ())
forall a. Monoid a => a
mempty
  mappend :: HsImport -> HsImport -> HsImport
mappend HsImport
HsImportAll HsImport
_ = HsImport
HsImportAll
  mappend HsImport
_ HsImport
HsImportAll = HsImport
HsImportAll
  mappend (HsImportSome Set (ImportSpec ())
a) (HsImportSome Set (ImportSpec ())
b) =
    Set (ImportSpec ()) -> HsImport
HsImportSome (Set (ImportSpec ())
a Set (ImportSpec ()) -> Set (ImportSpec ()) -> Set (ImportSpec ())
forall a. Semigroup a => a -> a -> a
<> Set (ImportSpec ())
b)

importSome :: T.Text -> [ Hs.ImportSpec () ] -> HsImports
importSome :: Text -> [ImportSpec ()] -> HsImports
importSome Text
modNm [ImportSpec ()]
names = Map (ModuleName ()) HsImport -> HsImports
HsImports (ModuleName () -> HsImport -> Map (ModuleName ()) HsImport
forall k a. k -> a -> Map k a
M.singleton (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
Hs.ModuleName () (Text -> String
T.unpack Text
modNm))
                                                (Set (ImportSpec ()) -> HsImport
HsImportSome ([ImportSpec ()] -> Set (ImportSpec ())
forall a. Ord a => [a] -> Set a
S.fromList [ImportSpec ()]
names)))

importTyNamed :: T.Text -> Hs.ImportSpec ()
importTyNamed :: Text -> ImportSpec ()
importTyNamed = Text -> ImportSpec ()
importVarNamed -- nm = Hs.IAbs () (Hs.TypeNamespace ()) (Hs.Ident () (T.unpack nm))

importVarNamed :: T.Text -> Hs.ImportSpec ()
importVarNamed :: Text -> ImportSpec ()
importVarNamed Text
nm = () -> Name () -> ImportSpec ()
forall l. l -> Name l -> ImportSpec l
Hs.IVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm))

newtype HsImports = HsImports (M.Map (Hs.ModuleName ()) HsImport)
  deriving (Int -> HsImports -> ShowS
[HsImports] -> ShowS
HsImports -> String
(Int -> HsImports -> ShowS)
-> (HsImports -> String)
-> ([HsImports] -> ShowS)
-> Show HsImports
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsImports] -> ShowS
$cshowList :: [HsImports] -> ShowS
show :: HsImports -> String
$cshow :: HsImports -> String
showsPrec :: Int -> HsImports -> ShowS
$cshowsPrec :: Int -> HsImports -> ShowS
Show, HsImports -> HsImports -> Bool
(HsImports -> HsImports -> Bool)
-> (HsImports -> HsImports -> Bool) -> Eq HsImports
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsImports -> HsImports -> Bool
$c/= :: HsImports -> HsImports -> Bool
== :: HsImports -> HsImports -> Bool
$c== :: HsImports -> HsImports -> Bool
Eq)
instance Hashable HsImports where
  hashWithSalt :: Int -> HsImports -> Int
hashWithSalt Int
s (HsImports Map (ModuleName ()) HsImport
a) = Int -> [(ModuleName (), HsImport)] -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Map (ModuleName ()) HsImport -> [(ModuleName (), HsImport)]
forall k a. Map k a -> [(k, a)]
M.assocs Map (ModuleName ()) HsImport
a)
instance Semigroup HsImports where
  <> :: HsImports -> HsImports -> HsImports
(<>) = HsImports -> HsImports -> HsImports
forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsImports where
  mempty :: HsImports
mempty = Map (ModuleName ()) HsImport -> HsImports
HsImports Map (ModuleName ()) HsImport
forall a. Monoid a => a
mempty
  mappend :: HsImports -> HsImports -> HsImports
mappend (HsImports Map (ModuleName ()) HsImport
a) (HsImports Map (ModuleName ()) HsImport
b) =
    Map (ModuleName ()) HsImport -> HsImports
HsImports ((HsImport -> HsImport -> HsImport)
-> Map (ModuleName ()) HsImport
-> Map (ModuleName ()) HsImport
-> Map (ModuleName ()) HsImport
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith HsImport -> HsImport -> HsImport
forall a. Monoid a => a -> a -> a
mappend Map (ModuleName ()) HsImport
a Map (ModuleName ()) HsImport
b)

data HsDataType
  = HsDataType
  { HsDataType -> HsExpr
hsDataTypeMigration :: HsExpr
  , HsDataType -> HsType
hsDataTypeType :: HsType
  , HsDataType -> BeamSerializedDataType
hsDataTypeSerialized :: BeamSerializedDataType
  } deriving (HsDataType -> HsDataType -> Bool
(HsDataType -> HsDataType -> Bool)
-> (HsDataType -> HsDataType -> Bool) -> Eq HsDataType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsDataType -> HsDataType -> Bool
$c/= :: HsDataType -> HsDataType -> Bool
== :: HsDataType -> HsDataType -> Bool
$c== :: HsDataType -> HsDataType -> Bool
Eq, Int -> HsDataType -> ShowS
[HsDataType] -> ShowS
HsDataType -> String
(Int -> HsDataType -> ShowS)
-> (HsDataType -> String)
-> ([HsDataType] -> ShowS)
-> Show HsDataType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsDataType] -> ShowS
$cshowList :: [HsDataType] -> ShowS
show :: HsDataType -> String
$cshow :: HsDataType -> String
showsPrec :: Int -> HsDataType -> ShowS
$cshowsPrec :: Int -> HsDataType -> ShowS
Show, (forall x. HsDataType -> Rep HsDataType x)
-> (forall x. Rep HsDataType x -> HsDataType) -> Generic HsDataType
forall x. Rep HsDataType x -> HsDataType
forall x. HsDataType -> Rep HsDataType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsDataType x -> HsDataType
$cfrom :: forall x. HsDataType -> Rep HsDataType x
Generic)
instance Hashable HsDataType where
  hashWithSalt :: Int -> HsDataType -> Int
hashWithSalt Int
salt (HsDataType HsExpr
mig HsType
ty BeamSerializedDataType
_) = Int -> (HsExpr, HsType) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (HsExpr
mig, HsType
ty)
instance Sql92DisplaySyntax HsDataType where
  displaySyntax :: HsDataType -> String
displaySyntax = HsDataType -> String
forall a. Show a => a -> String
show
instance HasDataTypeCreatedCheck HsDataType where
  dataTypeHasBeenCreated :: HsDataType
-> (forall preCondition. Typeable preCondition => [preCondition])
-> Bool
dataTypeHasBeenCreated HsDataType
_ forall preCondition. Typeable preCondition => [preCondition]
_ = Bool
True -- TODO make this more robust

data HsType
  = HsType
  { HsType -> Type ()
hsTypeSyntax  :: Hs.Type ()
  , HsType -> HsImports
hsTypeImports :: HsImports
  } deriving (Int -> HsType -> ShowS
[HsType] -> ShowS
HsType -> String
(Int -> HsType -> ShowS)
-> (HsType -> String) -> ([HsType] -> ShowS) -> Show HsType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsType] -> ShowS
$cshowList :: [HsType] -> ShowS
show :: HsType -> String
$cshow :: HsType -> String
showsPrec :: Int -> HsType -> ShowS
$cshowsPrec :: Int -> HsType -> ShowS
Show, HsType -> HsType -> Bool
(HsType -> HsType -> Bool)
-> (HsType -> HsType -> Bool) -> Eq HsType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsType -> HsType -> Bool
$c/= :: HsType -> HsType -> Bool
== :: HsType -> HsType -> Bool
$c== :: HsType -> HsType -> Bool
Eq, (forall x. HsType -> Rep HsType x)
-> (forall x. Rep HsType x -> HsType) -> Generic HsType
forall x. Rep HsType x -> HsType
forall x. HsType -> Rep HsType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsType x -> HsType
$cfrom :: forall x. HsType -> Rep HsType x
Generic)
instance Hashable HsType

data HsExpr
  = HsExpr
  { HsExpr -> Exp ()
hsExprSyntax  :: Hs.Exp ()
  , HsExpr -> HsImports
hsExprImports :: HsImports
  , HsExpr -> [Asst ()]
hsExprConstraints :: [ Hs.Asst () ]
  , HsExpr -> Set (Name ())
hsExprTypeVariables :: S.Set (Hs.Name ())
  } deriving (Int -> HsExpr -> ShowS
[HsExpr] -> ShowS
HsExpr -> String
(Int -> HsExpr -> ShowS)
-> (HsExpr -> String) -> ([HsExpr] -> ShowS) -> Show HsExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsExpr] -> ShowS
$cshowList :: [HsExpr] -> ShowS
show :: HsExpr -> String
$cshow :: HsExpr -> String
showsPrec :: Int -> HsExpr -> ShowS
$cshowsPrec :: Int -> HsExpr -> ShowS
Show, HsExpr -> HsExpr -> Bool
(HsExpr -> HsExpr -> Bool)
-> (HsExpr -> HsExpr -> Bool) -> Eq HsExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsExpr -> HsExpr -> Bool
$c/= :: HsExpr -> HsExpr -> Bool
== :: HsExpr -> HsExpr -> Bool
$c== :: HsExpr -> HsExpr -> Bool
Eq, (forall x. HsExpr -> Rep HsExpr x)
-> (forall x. Rep HsExpr x -> HsExpr) -> Generic HsExpr
forall x. Rep HsExpr x -> HsExpr
forall x. HsExpr -> Rep HsExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsExpr x -> HsExpr
$cfrom :: forall x. HsExpr -> Rep HsExpr x
Generic)
instance Hashable HsExpr

data HsColumnSchema
  = HsColumnSchema
  { HsColumnSchema -> Text -> HsExpr
mkHsColumnSchema :: T.Text -> HsExpr
  , HsColumnSchema -> HsType
hsColumnSchemaType :: HsType
  }
instance Show HsColumnSchema where
  show :: HsColumnSchema -> String
show (HsColumnSchema Text -> HsExpr
mk HsType
_) = HsExpr -> String
forall a. Show a => a -> String
show (Text -> HsExpr
mk Text
"fieldNm")
instance Eq HsColumnSchema where
  HsColumnSchema Text -> HsExpr
a HsType
aTy == :: HsColumnSchema -> HsColumnSchema -> Bool
== HsColumnSchema Text -> HsExpr
b HsType
bTy = Text -> HsExpr
a Text
"fieldNm" HsExpr -> HsExpr -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HsExpr
b Text
"fieldNm" Bool -> Bool -> Bool
&& HsType
aTy HsType -> HsType -> Bool
forall a. Eq a => a -> a -> Bool
== HsType
bTy
instance Hashable HsColumnSchema where
  hashWithSalt :: Int -> HsColumnSchema -> Int
hashWithSalt Int
s (HsColumnSchema Text -> HsExpr
mk HsType
ty) = Int -> (HsExpr, HsType) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Text -> HsExpr
mk Text
"fieldNm", HsType
ty)
instance Sql92DisplaySyntax HsColumnSchema where
  displaySyntax :: HsColumnSchema -> String
displaySyntax = HsColumnSchema -> String
forall a. Show a => a -> String
show

data HsDecl
  = HsDecl
  { HsDecl -> Decl ()
hsDeclSyntax  :: Hs.Decl ()
  , HsDecl -> HsImports
hsDeclImports :: HsImports
  , HsDecl -> [ExportSpec ()]
hsDeclExports :: [ Hs.ExportSpec () ]
  }

data HsAction
  = HsAction
  { HsAction -> [(Maybe (Pat ()), HsExpr)]
hsSyntaxMigration :: [ (Maybe (Hs.Pat ()), HsExpr) ]
  , HsAction -> [HsEntity]
hsSyntaxEntities  :: [ HsEntity ]
  }

instance Semigroup HsAction where
  <> :: HsAction -> HsAction -> HsAction
(<>) = HsAction -> HsAction -> HsAction
forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsAction where
  mempty :: HsAction
mempty = [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> HsAction
HsAction [] []
  mappend :: HsAction -> HsAction -> HsAction
mappend (HsAction [(Maybe (Pat ()), HsExpr)]
ma [HsEntity]
ea) (HsAction [(Maybe (Pat ()), HsExpr)]
mb [HsEntity]
eb) =
    [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> HsAction
HsAction ([(Maybe (Pat ()), HsExpr)]
ma [(Maybe (Pat ()), HsExpr)]
-> [(Maybe (Pat ()), HsExpr)] -> [(Maybe (Pat ()), HsExpr)]
forall a. Semigroup a => a -> a -> a
<> [(Maybe (Pat ()), HsExpr)]
mb) ([HsEntity]
ea [HsEntity] -> [HsEntity] -> [HsEntity]
forall a. Semigroup a => a -> a -> a
<> [HsEntity]
eb)

newtype HsBackendConstraint = HsBackendConstraint { HsBackendConstraint -> Type () -> Asst ()
buildHsBackendConstraint :: Hs.Type () -> Hs.Asst () }

data HsBeamBackend f
  = HsBeamBackendSingle HsType f
  | HsBeamBackendConstrained [ HsBackendConstraint ]
  | HsBeamBackendNone

instance Semigroup (HsBeamBackend f) where
  <> :: HsBeamBackend f -> HsBeamBackend f -> HsBeamBackend f
(<>) = HsBeamBackend f -> HsBeamBackend f -> HsBeamBackend f
forall a. Monoid a => a -> a -> a
mappend
instance Monoid (HsBeamBackend f) where
  mempty :: HsBeamBackend f
mempty = [HsBackendConstraint] -> HsBeamBackend f
forall f. [HsBackendConstraint] -> HsBeamBackend f
HsBeamBackendConstrained []
  mappend :: HsBeamBackend f -> HsBeamBackend f -> HsBeamBackend f
mappend (HsBeamBackendSingle HsType
aTy f
aExp) (HsBeamBackendSingle HsType
bTy f
_)
    | HsType
aTy HsType -> HsType -> Bool
forall a. Eq a => a -> a -> Bool
== HsType
bTy = HsType -> f -> HsBeamBackend f
forall f. HsType -> f -> HsBeamBackend f
HsBeamBackendSingle HsType
aTy f
aExp
    | Bool
otherwise = HsBeamBackend f
forall f. HsBeamBackend f
HsBeamBackendNone
  mappend a :: HsBeamBackend f
a@HsBeamBackendSingle {} HsBeamBackend f
_ = HsBeamBackend f
a
  mappend HsBeamBackend f
_ b :: HsBeamBackend f
b@HsBeamBackendSingle {} = HsBeamBackend f
b
  mappend HsBeamBackend f
HsBeamBackendNone HsBeamBackend f
_ = HsBeamBackend f
forall f. HsBeamBackend f
HsBeamBackendNone
  mappend HsBeamBackend f
_ HsBeamBackend f
HsBeamBackendNone = HsBeamBackend f
forall f. HsBeamBackend f
HsBeamBackendNone
  mappend (HsBeamBackendConstrained [HsBackendConstraint]
a) (HsBeamBackendConstrained [HsBackendConstraint]
b) =
    [HsBackendConstraint] -> HsBeamBackend f
forall f. [HsBackendConstraint] -> HsBeamBackend f
HsBeamBackendConstrained ([HsBackendConstraint]
a [HsBackendConstraint]
-> [HsBackendConstraint] -> [HsBackendConstraint]
forall a. Semigroup a => a -> a -> a
<> [HsBackendConstraint]
b)

data HsEntity
    = HsEntity
    { HsEntity -> HsBeamBackend HsExpr
hsEntityBackend :: HsBeamBackend HsExpr

    , HsEntity -> HsEntityName
hsEntityName    :: HsEntityName

    , HsEntity -> [HsDecl]
hsEntityDecls   :: [ HsDecl ]
    , HsEntity -> HsDbField
hsEntityDbDecl  :: HsDbField

    , HsEntity -> HsExpr
hsEntityExp     :: HsExpr
    }

newtype HsFieldLookup = HsFieldLookup { HsFieldLookup -> Text -> Maybe (Text, Type ())
hsFieldLookup :: T.Text -> Maybe (T.Text, Hs.Type ()) }
newtype HsTableConstraint = HsTableConstraint (T.Text -> HsFieldLookup -> HsTableConstraintDecls)

data HsTableConstraintDecls
    = HsTableConstraintDecls
    { HsTableConstraintDecls -> [InstDecl ()]
hsTableConstraintInstance :: [ Hs.InstDecl () ]
    , HsTableConstraintDecls -> [HsDecl]
hsTableConstraintDecls    :: [ HsDecl ]
    }

instance Semigroup HsTableConstraintDecls where
  <> :: HsTableConstraintDecls
-> HsTableConstraintDecls -> HsTableConstraintDecls
(<>) = HsTableConstraintDecls
-> HsTableConstraintDecls -> HsTableConstraintDecls
forall a. Monoid a => a -> a -> a
mappend

instance Monoid HsTableConstraintDecls where
  mempty :: HsTableConstraintDecls
mempty = [InstDecl ()] -> [HsDecl] -> HsTableConstraintDecls
HsTableConstraintDecls [] []
  mappend :: HsTableConstraintDecls
-> HsTableConstraintDecls -> HsTableConstraintDecls
mappend (HsTableConstraintDecls [InstDecl ()]
ai [HsDecl]
ad) (HsTableConstraintDecls [InstDecl ()]
bi [HsDecl]
bd) =
    [InstDecl ()] -> [HsDecl] -> HsTableConstraintDecls
HsTableConstraintDecls ([InstDecl ()]
ai [InstDecl ()] -> [InstDecl ()] -> [InstDecl ()]
forall a. Semigroup a => a -> a -> a
<> [InstDecl ()]
bi) ([HsDecl]
ad [HsDecl] -> [HsDecl] -> [HsDecl]
forall a. Semigroup a => a -> a -> a
<> [HsDecl]
bd)

data HsModule
  = HsModule
  { HsModule -> String
hsModuleName :: String
  , HsModule -> [HsEntity]
hsModuleEntities :: [ HsEntity ]
  , HsModule -> [(Maybe (Pat ()), HsExpr)]
hsModuleMigration :: [ (Maybe (Hs.Pat ()), HsExpr) ]
  }

hsActionsToModule :: String -> [ HsAction ] -> HsModule
hsActionsToModule :: String -> [HsAction] -> HsModule
hsActionsToModule String
modNm [HsAction]
actions =
  let HsAction [(Maybe (Pat ()), HsExpr)]
ms [HsEntity]
es = [HsAction] -> HsAction
forall a. Monoid a => [a] -> a
mconcat [HsAction]
actions
  in String -> [HsEntity] -> [(Maybe (Pat ()), HsExpr)] -> HsModule
HsModule String
modNm [HsEntity]
es [(Maybe (Pat ()), HsExpr)]
ms

unqual :: String -> Hs.QName ()
unqual :: String -> QName ()
unqual = () -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (Name () -> QName ()) -> (String -> Name ()) -> String -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident ()

entityDbFieldName :: HsEntity -> String
entityDbFieldName :: HsEntity -> String
entityDbFieldName HsEntity
entity = String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HsEntityName -> String
getHsEntityName (HsEntity -> HsEntityName
hsEntityName HsEntity
entity)

derivingDecl :: [Hs.InstRule ()] -> Hs.Deriving ()
derivingDecl :: [InstRule ()] -> Deriving ()
derivingDecl =
#if MIN_VERSION_haskell_src_exts(1,20,0)
  () -> Maybe (DerivStrategy ()) -> [InstRule ()] -> Deriving ()
forall l.
l -> Maybe (DerivStrategy l) -> [InstRule l] -> Deriving l
Hs.Deriving () Maybe (DerivStrategy ())
forall a. Maybe a
Nothing
#else
  Hs.Deriving ()
#endif

dataDecl :: Hs.DeclHead ()
         -> [Hs.QualConDecl ()]
         -> Maybe (Hs.Deriving ())
         -> Hs.Decl ()
dataDecl :: DeclHead () -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()
dataDecl DeclHead ()
declHead [QualConDecl ()]
cons Maybe (Deriving ())
deriving_ =
#if MIN_VERSION_haskell_src_exts(1,20,0)
  ()
-> DataOrNew ()
-> Maybe (Context ())
-> DeclHead ()
-> [QualConDecl ()]
-> [Deriving ()]
-> Decl ()
forall l.
l
-> DataOrNew l
-> Maybe (Context l)
-> DeclHead l
-> [QualConDecl l]
-> [Deriving l]
-> Decl l
Hs.DataDecl () (() -> DataOrNew ()
forall l. l -> DataOrNew l
Hs.DataType ()) Maybe (Context ())
forall a. Maybe a
Nothing DeclHead ()
declHead [QualConDecl ()]
cons (Maybe (Deriving ()) -> [Deriving ()]
forall a. Maybe a -> [a]
maybeToList Maybe (Deriving ())
deriving_)
#else
  Hs.DataDecl () (Hs.DataType ()) Nothing declHead cons deriving_
#endif

insDataDecl :: Hs.Type ()
            -> [Hs.QualConDecl ()]
            -> Maybe (Hs.Deriving ())
            -> Hs.InstDecl ()
insDataDecl :: Type () -> [QualConDecl ()] -> Maybe (Deriving ()) -> InstDecl ()
insDataDecl Type ()
declHead [QualConDecl ()]
cons Maybe (Deriving ())
deriving_ =
#if MIN_VERSION_haskell_src_exts(1,20,0)
   ()
-> DataOrNew ()
-> Type ()
-> [QualConDecl ()]
-> [Deriving ()]
-> InstDecl ()
forall l.
l
-> DataOrNew l
-> Type l
-> [QualConDecl l]
-> [Deriving l]
-> InstDecl l
Hs.InsData () (() -> DataOrNew ()
forall l. l -> DataOrNew l
Hs.DataType ()) Type ()
declHead [QualConDecl ()]
cons (Maybe (Deriving ()) -> [Deriving ()]
forall a. Maybe a -> [a]
maybeToList Maybe (Deriving ())
deriving_)
#else
   Hs.InsData () (Hs.DataType ()) declHead cons deriving_
#endif

databaseTypeDecl :: [ HsEntity ] -> Hs.Decl ()
databaseTypeDecl :: [HsEntity] -> Decl ()
databaseTypeDecl [HsEntity]
entities =
  DeclHead () -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()
dataDecl DeclHead ()
declHead [ QualConDecl ()
conDecl ] (Deriving () -> Maybe (Deriving ())
forall a. a -> Maybe a
Just Deriving ()
deriving_)
  where
    declHead :: DeclHead ()
declHead = () -> DeclHead () -> TyVarBind () -> DeclHead ()
forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
Hs.DHApp () (() -> Name () -> DeclHead ()
forall l. l -> Name l -> DeclHead l
Hs.DHead () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"Db"))
                           (() -> Name () -> TyVarBind ()
forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"entity"))
    conDecl :: QualConDecl ()
conDecl = ()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> ConDecl ()
-> QualConDecl ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing
                (() -> Name () -> [FieldDecl ()] -> ConDecl ()
forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
Hs.RecDecl () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"Db") (HsEntity -> FieldDecl ()
mkField (HsEntity -> FieldDecl ()) -> [HsEntity] -> [FieldDecl ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsEntity]
entities))
    deriving_ :: Deriving ()
deriving_ = [InstRule ()] -> Deriving ()
derivingDecl [ ()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> InstHead ()
-> InstRule ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (InstHead () -> InstRule ()) -> InstHead () -> InstRule ()
forall a b. (a -> b) -> a -> b
$
                               () -> QName () -> InstHead ()
forall l. l -> QName l -> InstHead l
Hs.IHCon () (QName () -> InstHead ()) -> QName () -> InstHead ()
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (Name () -> QName ()) -> Name () -> QName ()
forall a b. (a -> b) -> a -> b
$
                               () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"Generic" ]

    mkField :: HsEntity -> FieldDecl ()
mkField HsEntity
entity = () -> [Name ()] -> Type () -> FieldDecl ()
forall l. l -> [Name l] -> Type l -> FieldDecl l
Hs.FieldDecl () [ () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (HsEntity -> String
entityDbFieldName HsEntity
entity) ]
                                     (HsDbField -> Type () -> Type ()
buildHsDbField (HsEntity -> HsDbField
hsEntityDbDecl HsEntity
entity) (Type () -> Type ()) -> Type () -> Type ()
forall a b. (a -> b) -> a -> b
$
                                      () -> Name () -> Type ()
forall l. l -> Name l -> Type l
Hs.TyVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"entity"))

migrationTypeDecl :: HsBeamBackend HsExpr -> [Hs.Type ()] -> Hs.Decl ()
migrationTypeDecl :: HsBeamBackend HsExpr -> [Type ()] -> Decl ()
migrationTypeDecl HsBeamBackend HsExpr
be [Type ()]
inputs =
  () -> [Name ()] -> Type () -> Decl ()
forall l. l -> [Name l] -> Type l -> Decl l
Hs.TypeSig () [() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"migration"] Type ()
migrationType
  where
    ([Asst ()]
beAssts, Type ()
beVar) =
      case HsBeamBackend HsExpr
be of
        HsBeamBackend HsExpr
HsBeamBackendNone -> String -> ([Asst ()], Type ())
forall a. HasCallStack => String -> a
error String
"No backend matches"
        HsBeamBackendSingle HsType
ty HsExpr
_ -> ([], HsType -> Type ()
hsTypeSyntax HsType
ty)
        HsBeamBackendConstrained [HsBackendConstraint]
cs ->
          ( (HsBackendConstraint -> Asst ())
-> [HsBackendConstraint] -> [Asst ()]
forall a b. (a -> b) -> [a] -> [b]
map ((HsBackendConstraint -> Type () -> Asst ())
-> Type () -> HsBackendConstraint -> Asst ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HsBackendConstraint -> Type () -> Asst ()
buildHsBackendConstraint Type ()
beVar) [HsBackendConstraint]
cs
          , String -> Type ()
tyVarNamed String
"be" )

    resultType :: Type ()
resultType = Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"Migration")
                       [ Type ()
beVar
                       , Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"CheckedDatabaseSettings")
                               [ Type ()
beVar
                               , String -> Type ()
tyConNamed String
"Db" ] ]

    migrationUnconstrainedType :: Type ()
migrationUnconstrainedType
      | [] <- [Type ()]
inputs = Type ()
resultType
      | Bool
otherwise    = Type () -> Type () -> Type ()
functionTy ([Type ()] -> Type ()
tyTuple [Type ()]
inputs) Type ()
resultType

    constraints :: [Asst ()]
constraints = [Asst ()] -> [Asst ()]
forall a. Eq a => [a] -> [a]
nub [Asst ()]
beAssts
    migrationType :: Type ()
migrationType
      | [] <- [Asst ()]
constraints  = Type ()
migrationUnconstrainedType
      | [Asst ()
c] <- [Asst ()]
constraints = ()
-> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just (() -> Asst () -> Context ()
forall l. l -> Asst l -> Context l
Hs.CxSingle () Asst ()
c)) Type ()
migrationUnconstrainedType
      | Bool
otherwise          = ()
-> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just (() -> [Asst ()] -> Context ()
forall l. l -> [Asst l] -> Context l
Hs.CxTuple () [Asst ()]
constraints)) Type ()
migrationUnconstrainedType

migrationDecl :: HsBeamBackend HsExpr -> [Hs.Exp ()] -> [ (Maybe (Hs.Pat ()), HsExpr) ] -> [HsEntity] -> Hs.Decl ()
migrationDecl :: HsBeamBackend HsExpr
-> [Exp ()] -> [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> Decl ()
migrationDecl HsBeamBackend HsExpr
_ [Exp ()]
_ [(Maybe (Pat ()), HsExpr)]
migrations [HsEntity]
entities =
  () -> [Match ()] -> Decl ()
forall l. l -> [Match l] -> Decl l
Hs.FunBind () [ () -> Name () -> [Pat ()] -> Rhs () -> Maybe (Binds ()) -> Match ()
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"migration") [] (() -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
body) Maybe (Binds ())
forall a. Maybe a
Nothing ]
  where
    body :: Exp ()
body = () -> [Stmt ()] -> Exp ()
forall l. l -> [Stmt l] -> Exp l
Hs.Do () (((Maybe (Pat ()), HsExpr) -> Stmt ())
-> [(Maybe (Pat ()), HsExpr)] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe (Pat ())
pat, HsExpr
expr) ->
                            let expr' :: Exp ()
expr' = HsExpr -> Exp ()
hsExprSyntax HsExpr
expr
                            in case Maybe (Pat ())
pat of
                              Maybe (Pat ())
Nothing -> () -> Exp () -> Stmt ()
forall l. l -> Exp l -> Stmt l
Hs.Qualifier () Exp ()
expr'
                              Just Pat ()
pat' -> () -> Pat () -> Exp () -> Stmt ()
forall l. l -> Pat l -> Exp l -> Stmt l
Hs.Generator () Pat ()
pat' Exp ()
expr') [(Maybe (Pat ()), HsExpr)]
migrations [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. [a] -> [a] -> [a]
++
                     [() -> Exp () -> Stmt ()
forall l. l -> Exp l -> Stmt l
Hs.Qualifier () (HsExpr -> Exp ()
hsExprSyntax HsExpr
finalReturn)])

    finalReturn :: HsExpr
finalReturn = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"pure")
                        [ Text -> [(Text, HsExpr)] -> HsExpr
hsRecCon Text
"Db" ((HsEntity -> (Text, HsExpr)) -> [HsEntity] -> [(Text, HsExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\HsEntity
e -> (String -> Text
forall a. IsString a => String -> a
fromString (HsEntity -> String
entityDbFieldName HsEntity
e), HsEntity -> HsExpr
hsEntityExp HsEntity
e)) [HsEntity]
entities) ]

dbTypeDecl :: HsBeamBackend HsExpr -> Hs.Decl ()
dbTypeDecl :: HsBeamBackend HsExpr -> Decl ()
dbTypeDecl HsBeamBackend HsExpr
be =
  () -> [Name ()] -> Type () -> Decl ()
forall l. l -> [Name l] -> Type l -> Decl l
Hs.TypeSig () [ () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"db" ] Type ()
dbType
  where
    unconstrainedDbType :: Type ()
unconstrainedDbType = Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"DatabaseSettings")
                                [ Type ()
beVar, String -> Type ()
tyConNamed String
"Db" ]
    dbType :: Type ()
dbType
      | []  <- [Asst ()]
constraints, [] <- [TyVarBind ()]
bindings = Type ()
unconstrainedDbType
      | []  <- [Asst ()]
constraints  = ()
-> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () ([TyVarBind ()] -> Maybe [TyVarBind ()]
forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) Maybe (Context ())
forall a. Maybe a
Nothing Type ()
unconstrainedDbType
      | [Asst ()
c] <- [Asst ()]
constraints = ()
-> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () ([TyVarBind ()] -> Maybe [TyVarBind ()]
forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just (() -> Asst () -> Context ()
forall l. l -> Asst l -> Context l
Hs.CxSingle () Asst ()
c)) Type ()
unconstrainedDbType
      | Bool
otherwise          = ()
-> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () ([TyVarBind ()] -> Maybe [TyVarBind ()]
forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just (() -> [Asst ()] -> Context ()
forall l. l -> [Asst l] -> Context l
Hs.CxTuple () [Asst ()]
constraints)) Type ()
unconstrainedDbType

    constraints :: [Asst ()]
constraints = [Asst ()] -> [Asst ()]
forall a. Eq a => [a] -> [a]
nub [Asst ()]
beAssts
    ([TyVarBind ()]
bindings, [Asst ()]
beAssts, Type ()
beVar) =
      case HsBeamBackend HsExpr
be of
        HsBeamBackend HsExpr
HsBeamBackendNone -> String -> ([TyVarBind ()], [Asst ()], Type ())
forall a. HasCallStack => String -> a
error String
"No backend matches"
        HsBeamBackendSingle HsType
ty HsExpr
_ -> ([TyVarBind ()]
forall a. [a]
standardBindings, [], HsType -> Type ()
hsTypeSyntax HsType
ty)
        HsBeamBackendConstrained [HsBackendConstraint]
cs ->
          ( String -> TyVarBind ()
tyVarBind String
"be"TyVarBind () -> [TyVarBind ()] -> [TyVarBind ()]
forall a. a -> [a] -> [a]
:[TyVarBind ()]
forall a. [a]
standardBindings
          , (HsBackendConstraint -> Asst ())
-> [HsBackendConstraint] -> [Asst ()]
forall a b. (a -> b) -> [a] -> [b]
map ((HsBackendConstraint -> Type () -> Asst ())
-> Type () -> HsBackendConstraint -> Asst ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HsBackendConstraint -> Type () -> Asst ()
buildHsBackendConstraint Type ()
beVar) [HsBackendConstraint]
cs
          , String -> Type ()
tyVarNamed String
"be" )

    standardBindings :: [a]
standardBindings = []

    tyVarBind :: String -> TyVarBind ()
tyVarBind String
nm = () -> Name () -> TyVarBind ()
forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
nm)

dbDecl :: HsBeamBackend HsExpr -> [HsExpr] -> Hs.Decl ()
dbDecl :: HsBeamBackend HsExpr -> [HsExpr] -> Decl ()
dbDecl HsBeamBackend HsExpr
backend [HsExpr]
params =
  () -> [Match ()] -> Decl ()
forall l. l -> [Match l] -> Decl l
Hs.FunBind () [ () -> Name () -> [Pat ()] -> Rhs () -> Maybe (Binds ()) -> Match ()
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"db") [] (() -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
body) Maybe (Binds ())
forall a. Maybe a
Nothing ]
  where
    backendVar :: Type ()
backendVar = case HsBeamBackend HsExpr
backend of
                   HsBeamBackend HsExpr
HsBeamBackendNone -> String -> Type ()
forall a. HasCallStack => String -> a
error String
"No syntax matches"
                   HsBeamBackendSingle HsType
ty HsExpr
_ -> HsType -> Type ()
hsTypeSyntax HsType
ty
                   HsBeamBackendConstrained [HsBackendConstraint]
_ -> String -> Type ()
tyVarNamed String
"be"

    body :: Exp ()
body = HsExpr -> Exp ()
hsExprSyntax (HsExpr -> Exp ()) -> HsExpr -> Exp ()
forall a b. (a -> b) -> a -> b
$
           HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"unCheckDatabase")
                 [ HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"runMigrationSilenced" Text
"Database.Beam.Migrate")
                   [ HsExpr -> [HsExpr] -> HsExpr
hsApp (HsExpr -> Type () -> HsExpr
hsVisibleTyApp (Text -> HsExpr
hsVar Text
"migration") Type ()
backendVar) ([HsExpr] -> HsExpr) -> [HsExpr] -> HsExpr
forall a b. (a -> b) -> a -> b
$
                     case [HsExpr]
params of
                       [] -> []
                       [HsExpr]
_  -> [ [HsExpr] -> HsExpr
hsTuple [HsExpr]
params ]
                   ] ]

renderHsSchema :: HsModule -> Either String String
renderHsSchema :: HsModule -> Either String String
renderHsSchema (HsModule String
modNm [HsEntity]
entities [(Maybe (Pat ()), HsExpr)]
migrations) =
  let hsMod :: Module ()
hsMod = ()
-> Maybe (ModuleHead ())
-> [ModulePragma ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Hs.Module () (ModuleHead () -> Maybe (ModuleHead ())
forall a. a -> Maybe a
Just ModuleHead ()
modHead) [ModulePragma ()]
modPragmas [ImportDecl ()]
imports [Decl ()]
decls

      modHead :: ModuleHead ()
modHead = ()
-> ModuleName ()
-> Maybe (WarningText ())
-> Maybe (ExportSpecList ())
-> ModuleHead ()
forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
Hs.ModuleHead () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
Hs.ModuleName () String
modNm) Maybe (WarningText ())
forall a. Maybe a
Nothing (ExportSpecList () -> Maybe (ExportSpecList ())
forall a. a -> Maybe a
Just ExportSpecList ()
modExports)
      modExports :: ExportSpecList ()
modExports = () -> [ExportSpec ()] -> ExportSpecList ()
forall l. l -> [ExportSpec l] -> ExportSpecList l
Hs.ExportSpecList () ([ExportSpec ()]
commonExports [ExportSpec ()] -> [ExportSpec ()] -> [ExportSpec ()]
forall a. [a] -> [a] -> [a]
++ (HsEntity -> [ExportSpec ()]) -> [HsEntity] -> [ExportSpec ()]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((HsDecl -> [ExportSpec ()]) -> [HsDecl] -> [ExportSpec ()]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsDecl -> [ExportSpec ()]
hsDeclExports ([HsDecl] -> [ExportSpec ()])
-> (HsEntity -> [HsDecl]) -> HsEntity -> [ExportSpec ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsEntity -> [HsDecl]
hsEntityDecls) [HsEntity]
entities)
      commonExports :: [ExportSpec ()]
commonExports = [ () -> QName () -> ExportSpec ()
forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual String
"db")
                      , () -> QName () -> ExportSpec ()
forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual String
"migration")
                      , () -> EWildcard () -> QName () -> [CName ()] -> ExportSpec ()
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
Hs.EThingWith () (() -> Int -> EWildcard ()
forall l. l -> Int -> EWildcard l
Hs.EWildcard () Int
0)
                                      (String -> QName ()
unqual String
"Db") [] ]

      modPragmas :: [ModulePragma ()]
modPragmas = [ () -> [Name ()] -> ModulePragma ()
forall l. l -> [Name l] -> ModulePragma l
Hs.LanguagePragma () [ () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"StandaloneDeriving"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"GADTs"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"ScopedTypeVariables"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"FlexibleContexts"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"FlexibleInstances"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"DeriveGeneric"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"TypeSynonymInstances"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"ExplicitNamespaces"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"TypeApplications"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"TypeFamilies"
                                          , () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"OverloadedStrings" ] ]

      HsImports Map (ModuleName ()) HsImport
importedModules = (HsEntity -> HsImports) -> [HsEntity] -> HsImports
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\HsEntity
e -> (HsDecl -> HsImports) -> [HsDecl] -> HsImports
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsDecl -> HsImports
hsDeclImports (HsEntity -> [HsDecl]
hsEntityDecls HsEntity
e) HsImports -> HsImports -> HsImports
forall a. Semigroup a => a -> a -> a
<>
                                                 HsExpr -> HsImports
hsExprImports (HsEntity -> HsExpr
hsEntityExp HsEntity
e)) [HsEntity]
entities HsImports -> HsImports -> HsImports
forall a. Semigroup a => a -> a -> a
<>
                                  ((Maybe (Pat ()), HsExpr) -> HsImports)
-> [(Maybe (Pat ()), HsExpr)] -> HsImports
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HsExpr -> HsImports
hsExprImports (HsExpr -> HsImports)
-> ((Maybe (Pat ()), HsExpr) -> HsExpr)
-> (Maybe (Pat ()), HsExpr)
-> HsImports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Pat ()), HsExpr) -> HsExpr
forall a b. (a, b) -> b
snd) [(Maybe (Pat ()), HsExpr)]
migrations HsImports -> HsImports -> HsImports
forall a. Semigroup a => a -> a -> a
<>
                                  Text -> [ImportSpec ()] -> HsImports
importSome Text
"Database.Beam.Migrate" [ Text -> ImportSpec ()
importTyNamed Text
"CheckedDatabaseSettings", Text -> ImportSpec ()
importTyNamed Text
"Migration"
                                                                     , Text -> ImportSpec ()
importTyNamed Text
"BeamMigrateSqlBackend"
                                                                     , Text -> ImportSpec ()
importVarNamed Text
"runMigrationSilenced"
                                                                     , Text -> ImportSpec ()
importVarNamed Text
"unCheckDatabase" ]
      imports :: [ImportDecl ()]
imports = [ImportDecl ()]
commonImports [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<>
                ((ModuleName (), HsImport) -> ImportDecl ())
-> [(ModuleName (), HsImport)] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName ()
modName, HsImport
spec) ->
                       case HsImport
spec of
                         HsImport
HsImportAll -> ()
-> ModuleName ()
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName ())
-> Maybe (ImportSpecList ())
-> ImportDecl ()
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () ModuleName ()
modName Bool
False Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing Maybe (ModuleName ())
forall a. Maybe a
Nothing Maybe (ImportSpecList ())
forall a. Maybe a
Nothing
                         HsImportSome Set (ImportSpec ())
nms ->
                           let importList :: ImportSpecList ()
importList = () -> Bool -> [ImportSpec ()] -> ImportSpecList ()
forall l. l -> Bool -> [ImportSpec l] -> ImportSpecList l
Hs.ImportSpecList () Bool
False (Set (ImportSpec ()) -> [ImportSpec ()]
forall a. Set a -> [a]
S.toList Set (ImportSpec ())
nms)
                           in ()
-> ModuleName ()
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName ())
-> Maybe (ImportSpecList ())
-> ImportDecl ()
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () ModuleName ()
modName Bool
False Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing Maybe (ModuleName ())
forall a. Maybe a
Nothing (ImportSpecList () -> Maybe (ImportSpecList ())
forall a. a -> Maybe a
Just ImportSpecList ()
importList)
                    )
                    (Map (ModuleName ()) HsImport -> [(ModuleName (), HsImport)]
forall k a. Map k a -> [(k, a)]
M.assocs Map (ModuleName ()) HsImport
importedModules)

      commonImports :: [ImportDecl ()]
commonImports = [ ()
-> ModuleName ()
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName ())
-> Maybe (ImportSpecList ())
-> ImportDecl ()
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
Hs.ModuleName () String
"Database.Beam") Bool
False Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing Maybe (ModuleName ())
forall a. Maybe a
Nothing Maybe (ImportSpecList ())
forall a. Maybe a
Nothing
                      , ()
-> ModuleName ()
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName ())
-> Maybe (ImportSpecList ())
-> ImportDecl ()
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
Hs.ModuleName () String
"Control.Applicative") Bool
False Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing Maybe (ModuleName ())
forall a. Maybe a
Nothing Maybe (ImportSpecList ())
forall a. Maybe a
Nothing ]

      backend :: HsBeamBackend HsExpr
backend = (HsEntity -> HsBeamBackend HsExpr)
-> [HsEntity] -> HsBeamBackend HsExpr
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsEntity -> HsBeamBackend HsExpr
hsEntityBackend [HsEntity]
entities

      backendHs :: Type ()
backendHs = case HsBeamBackend HsExpr
backend of
                    HsBeamBackend HsExpr
HsBeamBackendNone -> String -> Type ()
forall a. HasCallStack => String -> a
error String
"Can't instantiate Database instance: No backend matches"
                    HsBeamBackendSingle HsType
ty HsExpr
_ -> HsType -> Type ()
hsTypeSyntax HsType
ty
                    HsBeamBackendConstrained {} -> String -> Type ()
tyVarNamed String
"be" -- TODO constraints

      decls :: [Decl ()]
decls = (HsEntity -> [Decl ()]) -> [HsEntity] -> [Decl ()]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((HsDecl -> Decl ()) -> [HsDecl] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Decl ()
hsDeclSyntax ([HsDecl] -> [Decl ()])
-> (HsEntity -> [HsDecl]) -> HsEntity -> [Decl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsEntity -> [HsDecl]
hsEntityDecls) [HsEntity]
entities [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++
              [ [HsEntity] -> Decl ()
databaseTypeDecl [HsEntity]
entities

              , HsBeamBackend HsExpr -> [Type ()] -> Decl ()
migrationTypeDecl HsBeamBackend HsExpr
backend []
              , HsBeamBackend HsExpr
-> [Exp ()] -> [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> Decl ()
migrationDecl HsBeamBackend HsExpr
backend [] [(Maybe (Pat ()), HsExpr)]
migrations [HsEntity]
entities

              , Text -> [Type ()] -> [InstDecl ()] -> Decl ()
hsInstance Text
"Database" [ Type ()
backendHs, String -> Type ()
tyConNamed String
"Db" ] []

              , HsBeamBackend HsExpr -> Decl ()
dbTypeDecl HsBeamBackend HsExpr
backend
              , HsBeamBackend HsExpr -> [HsExpr] -> Decl ()
dbDecl HsBeamBackend HsExpr
backend [] ]

  in String -> Either String String
forall a b. b -> Either a b
Right (Doc -> String
render (Module () -> Doc
forall a. Pretty a => a -> Doc
Hs.prettyPrim Module ()
hsMod))

-- * DDL Syntax definitions

data HsNone = HsNone deriving (Int -> HsNone -> ShowS
[HsNone] -> ShowS
HsNone -> String
(Int -> HsNone -> ShowS)
-> (HsNone -> String) -> ([HsNone] -> ShowS) -> Show HsNone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsNone] -> ShowS
$cshowList :: [HsNone] -> ShowS
show :: HsNone -> String
$cshow :: HsNone -> String
showsPrec :: Int -> HsNone -> ShowS
$cshowsPrec :: Int -> HsNone -> ShowS
Show, HsNone -> HsNone -> Bool
(HsNone -> HsNone -> Bool)
-> (HsNone -> HsNone -> Bool) -> Eq HsNone
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsNone -> HsNone -> Bool
$c/= :: HsNone -> HsNone -> Bool
== :: HsNone -> HsNone -> Bool
$c== :: HsNone -> HsNone -> Bool
Eq, Eq HsNone
Eq HsNone
-> (HsNone -> HsNone -> Ordering)
-> (HsNone -> HsNone -> Bool)
-> (HsNone -> HsNone -> Bool)
-> (HsNone -> HsNone -> Bool)
-> (HsNone -> HsNone -> Bool)
-> (HsNone -> HsNone -> HsNone)
-> (HsNone -> HsNone -> HsNone)
-> Ord HsNone
HsNone -> HsNone -> Bool
HsNone -> HsNone -> Ordering
HsNone -> HsNone -> HsNone
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HsNone -> HsNone -> HsNone
$cmin :: HsNone -> HsNone -> HsNone
max :: HsNone -> HsNone -> HsNone
$cmax :: HsNone -> HsNone -> HsNone
>= :: HsNone -> HsNone -> Bool
$c>= :: HsNone -> HsNone -> Bool
> :: HsNone -> HsNone -> Bool
$c> :: HsNone -> HsNone -> Bool
<= :: HsNone -> HsNone -> Bool
$c<= :: HsNone -> HsNone -> Bool
< :: HsNone -> HsNone -> Bool
$c< :: HsNone -> HsNone -> Bool
compare :: HsNone -> HsNone -> Ordering
$ccompare :: HsNone -> HsNone -> Ordering
$cp1Ord :: Eq HsNone
Ord, (forall x. HsNone -> Rep HsNone x)
-> (forall x. Rep HsNone x -> HsNone) -> Generic HsNone
forall x. Rep HsNone x -> HsNone
forall x. HsNone -> Rep HsNone x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HsNone x -> HsNone
$cfrom :: forall x. HsNone -> Rep HsNone x
Generic)
instance Hashable HsNone

instance Semigroup HsNone where
  <> :: HsNone -> HsNone -> HsNone
(<>) = HsNone -> HsNone -> HsNone
forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsNone where
  mempty :: HsNone
mempty = HsNone
HsNone
  mappend :: HsNone -> HsNone -> HsNone
mappend HsNone
_ HsNone
_ = HsNone
HsNone

data HsMigrateBackend = HsMigrateBackend

instance BeamMigrateOnlySqlBackend HsMigrateBackend
type instance BeamSqlBackendSyntax HsMigrateBackend = HsAction

hsMkTableName :: (Char -> Char) -> TableName -> String
hsMkTableName :: (Char -> Char) -> TableName -> String
hsMkTableName Char -> Char
toNameCase (TableName Maybe Text
sch Text
nm) =
  case Maybe Text
sch of
    Maybe Text
Nothing ->
      case Text -> String
T.unpack Text
nm of
        [] -> ShowS
forall a. HasCallStack => String -> a
error String
"No name for table"
        Char
x:String
xs -> Char -> Char
toNameCase Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs
    Just Text
schNm ->
      case Text -> String
T.unpack Text
schNm of
        [] -> ShowS
forall a. HasCallStack => String -> a
error String
"Empty schema name"
        Char
x:String
xs -> Char -> Char
toNameCase Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
nm

hsTableVarName, hsTableTypeName :: TableName -> String
hsTableVarName :: TableName -> String
hsTableVarName = (Char -> Char) -> TableName -> String
hsMkTableName Char -> Char
toLower
hsTableTypeName :: TableName -> String
hsTableTypeName = (Char -> Char) -> TableName -> String
hsMkTableName Char -> Char
toUpper

instance IsSql92DdlCommandSyntax HsAction where
  type Sql92DdlCommandCreateTableSyntax HsAction = HsAction
  type Sql92DdlCommandAlterTableSyntax HsAction = HsAction
  type Sql92DdlCommandDropTableSyntax HsAction = HsAction

  createTableCmd :: Sql92DdlCommandCreateTableSyntax HsAction -> HsAction
createTableCmd = Sql92DdlCommandCreateTableSyntax HsAction -> HsAction
forall a. a -> a
id
  dropTableCmd :: Sql92DdlCommandDropTableSyntax HsAction -> HsAction
dropTableCmd = Sql92DdlCommandDropTableSyntax HsAction -> HsAction
forall a. a -> a
id
  alterTableCmd :: Sql92DdlCommandAlterTableSyntax HsAction -> HsAction
alterTableCmd = Sql92DdlCommandAlterTableSyntax HsAction -> HsAction
forall a. a -> a
id

instance IsSql92AlterTableSyntax HsAction where
  type Sql92AlterTableTableNameSyntax HsAction = TableName
  type Sql92AlterTableAlterTableActionSyntax HsAction = HsNone

  alterTableSyntax :: Sql92AlterTableTableNameSyntax HsAction
-> Sql92AlterTableAlterTableActionSyntax HsAction -> HsAction
alterTableSyntax Sql92AlterTableTableNameSyntax HsAction
_ Sql92AlterTableAlterTableActionSyntax HsAction
_ = String -> HsAction
forall a. HasCallStack => String -> a
error String
"alterTableSyntax"

instance IsSql92AlterTableActionSyntax HsNone where
  type Sql92AlterTableColumnSchemaSyntax HsNone = HsColumnSchema
  type Sql92AlterTableAlterColumnActionSyntax HsNone = HsNone

  alterColumnSyntax :: Text -> Sql92AlterTableAlterColumnActionSyntax HsNone -> HsNone
alterColumnSyntax Text
_ Sql92AlterTableAlterColumnActionSyntax HsNone
_ = HsNone
HsNone
  addColumnSyntax :: Text -> Sql92AlterTableColumnSchemaSyntax HsNone -> HsNone
addColumnSyntax Text
_ Sql92AlterTableColumnSchemaSyntax HsNone
_ = HsNone
HsNone
  dropColumnSyntax :: Text -> HsNone
dropColumnSyntax Text
_ = HsNone
HsNone
  renameTableToSyntax :: Text -> HsNone
renameTableToSyntax Text
_ = HsNone
HsNone
  renameColumnToSyntax :: Text -> Text -> HsNone
renameColumnToSyntax Text
_ Text
_ = HsNone
HsNone

instance IsSql92AlterColumnActionSyntax HsNone where
  setNullSyntax :: HsNone
setNullSyntax = HsNone
HsNone
  setNotNullSyntax :: HsNone
setNotNullSyntax = HsNone
HsNone

instance IsSql92DropTableSyntax HsAction where
  type Sql92DropTableTableNameSyntax HsAction = TableName

  dropTableSyntax :: Sql92DropTableTableNameSyntax HsAction -> HsAction
dropTableSyntax Sql92DropTableTableNameSyntax HsAction
nm = [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> HsAction
HsAction [ (Maybe (Pat ())
forall a. Maybe a
Nothing, HsExpr
dropTable) ] []
    where
      dropTable :: HsExpr
dropTable = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"dropTable") [ Text -> HsExpr
hsVar (String -> Text
forall a. IsString a => String -> a
fromString (TableName -> String
hsTableVarName TableName
Sql92DropTableTableNameSyntax HsAction
nm)) ]

instance IsSql92CreateTableSyntax HsAction where
  type Sql92CreateTableTableNameSyntax HsAction = TableName
  type Sql92CreateTableOptionsSyntax HsAction = HsNone
  type Sql92CreateTableTableConstraintSyntax HsAction = HsTableConstraint
  type Sql92CreateTableColumnSchemaSyntax HsAction = HsColumnSchema

  createTableSyntax :: Maybe (Sql92CreateTableOptionsSyntax HsAction)
-> Sql92CreateTableTableNameSyntax HsAction
-> [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
-> [Sql92CreateTableTableConstraintSyntax HsAction]
-> HsAction
createTableSyntax Maybe (Sql92CreateTableOptionsSyntax HsAction)
_ Sql92CreateTableTableNameSyntax HsAction
nm [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
fields [Sql92CreateTableTableConstraintSyntax HsAction]
cs =
    [(Maybe (Pat ()), HsExpr)] -> [HsEntity] -> HsAction
HsAction [ ( Pat () -> Maybe (Pat ())
forall a. a -> Maybe a
Just (() -> Name () -> Pat ()
forall l. l -> Name l -> Pat l
Hs.PVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
varName))
               , HsExpr
migration ) ]
             [ HsEntity
entity ]
    where
      (String
varName, String
tyName, String
tyConName) =
        ( TableName -> String
hsTableVarName TableName
Sql92CreateTableTableNameSyntax HsAction
nm, TableName -> String
hsTableTypeName TableName
Sql92CreateTableTableNameSyntax HsAction
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"T", TableName -> String
hsTableTypeName TableName
Sql92CreateTableTableNameSyntax HsAction
nm )

      mkHsFieldName :: Text -> String
mkHsFieldName Text
fieldNm = String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
varName String -> ShowS
forall a. [a] -> [a] -> [a]
++
                              case Text -> String
T.unpack Text
fieldNm of
                                [] -> ShowS
forall a. HasCallStack => String -> a
error String
"empty field name"
                                (Char
x:String
xs) -> Char -> Char
toUpper Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs

      HsTableConstraintDecls [InstDecl ()]
tableInstanceDecls [HsDecl]
constraintDecls = (HsTableConstraint -> HsTableConstraintDecls)
-> [HsTableConstraint] -> HsTableConstraintDecls
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(HsTableConstraint Text -> HsFieldLookup -> HsTableConstraintDecls
mkConstraint) -> Text -> HsFieldLookup -> HsTableConstraintDecls
mkConstraint (String -> Text
forall a. IsString a => String -> a
fromString String
tyConName) HsFieldLookup
fieldLookup) [Sql92CreateTableTableConstraintSyntax HsAction]
[HsTableConstraint]
cs
      fieldLookup :: HsFieldLookup
fieldLookup = (Text -> Maybe (Text, Type ())) -> HsFieldLookup
HsFieldLookup ((Text -> Maybe (Text, Type ())) -> HsFieldLookup)
-> (Text -> Maybe (Text, Type ())) -> HsFieldLookup
forall a b. (a -> b) -> a -> b
$ \Text
fieldNm ->
                    ((Text, Type ()) -> (Text, Type ()))
-> Maybe (Text, Type ()) -> Maybe (Text, Type ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
fieldNm', Type ()
ty') -> (String -> Text
forall a. IsString a => String -> a
fromString (Text -> String
mkHsFieldName Text
fieldNm'), Type ()
ty')) (Maybe (Text, Type ()) -> Maybe (Text, Type ()))
-> Maybe (Text, Type ()) -> Maybe (Text, Type ())
forall a b. (a -> b) -> a -> b
$
                    ((Text, Type ()) -> Bool)
-> [(Text, Type ())] -> Maybe (Text, Type ())
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ( (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fieldNm) (Text -> Bool)
-> ((Text, Type ()) -> Text) -> (Text, Type ()) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Type ()) -> Text
forall a b. (a, b) -> a
fst ) [(Text, Type ())]
tyConFields

      migration :: HsExpr
migration =
        HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"createTable" Text
"Database.Beam.Migrate")
              [ Text -> HsExpr
hsStr (String -> Text
forall a. IsString a => String -> a
fromString (TableName -> String
hsTableVarName TableName
Sql92CreateTableTableNameSyntax HsAction
nm))
              , HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsTyCon (String -> Text
forall a. IsString a => String -> a
fromString String
tyConName))
                      (((Text, HsColumnSchema) -> HsExpr)
-> [(Text, HsColumnSchema)] -> [HsExpr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, HsColumnSchema
ty) -> HsColumnSchema -> Text -> HsExpr
mkHsColumnSchema HsColumnSchema
ty Text
fieldNm) [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
[(Text, HsColumnSchema)]
fields) ]
      entity :: HsEntity
entity = HsEntity :: HsBeamBackend HsExpr
-> HsEntityName -> [HsDecl] -> HsDbField -> HsExpr -> HsEntity
HsEntity
             { hsEntityBackend :: HsBeamBackend HsExpr
hsEntityBackend = [HsBackendConstraint] -> HsBeamBackend HsExpr
forall f. [HsBackendConstraint] -> HsBeamBackend f
HsBeamBackendConstrained [ HsBackendConstraint
beamMigrateSqlBackend ]

             , hsEntityName :: HsEntityName
hsEntityName    = String -> HsEntityName
HsEntityName String
varName
             , hsEntityDecls :: [HsDecl]
hsEntityDecls   = [ Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblDecl HsImports
imports
                                          [ () -> EWildcard () -> QName () -> [CName ()] -> ExportSpec ()
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
Hs.EThingWith () (() -> Int -> EWildcard ()
forall l. l -> Int -> EWildcard l
Hs.EWildcard () Int
0) (String -> QName ()
unqual String
tyName) [] ]
                                 , Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblBeamable HsImports
imports []

                                 , Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblPun HsImports
imports [ () -> QName () -> ExportSpec ()
forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual String
tyConName) ]

                                 , Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblShowInstance HsImports
imports []
                                 , Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblEqInstance HsImports
imports []

                                 , Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
tblInstanceDecl HsImports
imports []
                                 ] [HsDecl] -> [HsDecl] -> [HsDecl]
forall a. [a] -> [a] -> [a]
++
                                 [HsDecl]
constraintDecls
             , hsEntityDbDecl :: HsDbField
hsEntityDbDecl  = (Type () -> Type ()) -> HsDbField
HsDbField (\Type ()
f -> Type () -> [Type ()] -> Type ()
tyApp Type ()
f [ Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"TableEntity") [String -> Type ()
tyConNamed String
tyName] ])
             , hsEntityExp :: HsExpr
hsEntityExp     = Text -> HsExpr
hsVar (String -> Text
forall a. IsString a => String -> a
fromString String
varName)
             }

      imports :: HsImports
imports = ((Text, HsColumnSchema) -> HsImports)
-> [(Text, HsColumnSchema)] -> HsImports
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Text
_, HsColumnSchema
ty) -> HsType -> HsImports
hsTypeImports (HsColumnSchema -> HsType
hsColumnSchemaType HsColumnSchema
ty)) [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
[(Text, HsColumnSchema)]
fields

      tblDecl :: Decl ()
tblDecl = DeclHead () -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()
dataDecl DeclHead ()
tblDeclHead [ QualConDecl ()
tblConDecl ] (Deriving () -> Maybe (Deriving ())
forall a. a -> Maybe a
Just Deriving ()
deriving_)
      tblDeclHead :: DeclHead ()
tblDeclHead = () -> DeclHead () -> TyVarBind () -> DeclHead ()
forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
Hs.DHApp () (() -> Name () -> DeclHead ()
forall l. l -> Name l -> DeclHead l
Hs.DHead () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
tyName))
                                (() -> Name () -> TyVarBind ()
forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"f"))
      tblConDecl :: QualConDecl ()
tblConDecl = ()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> ConDecl ()
-> QualConDecl ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (() -> Name () -> [FieldDecl ()] -> ConDecl ()
forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
Hs.RecDecl () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
tyConName) [FieldDecl ()]
tyConFieldDecls)

      tyConFieldDecls :: [FieldDecl ()]
tyConFieldDecls = ((Text, Type ()) -> FieldDecl ())
-> [(Text, Type ())] -> [FieldDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, Type ()
ty) ->
                                () -> [Name ()] -> Type () -> FieldDecl ()
forall l. l -> [Name l] -> Type l -> FieldDecl l
Hs.FieldDecl () [ () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
mkHsFieldName Text
fieldNm) ] Type ()
ty) [(Text, Type ())]
tyConFields
      tyConFields :: [(Text, Type ())]
tyConFields = ((Text, HsColumnSchema) -> (Text, Type ()))
-> [(Text, HsColumnSchema)] -> [(Text, Type ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, HsColumnSchema
ty) -> ( Text
fieldNm
                                           , Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"Columnar")
                                                   [ String -> Type ()
tyVarNamed String
"f"
                                                   , HsType -> Type ()
hsTypeSyntax (HsColumnSchema -> HsType
hsColumnSchemaType HsColumnSchema
ty) ])) [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
[(Text, HsColumnSchema)]
fields

      deriving_ :: Deriving ()
deriving_ = [InstRule ()] -> Deriving ()
derivingDecl [ String -> InstRule ()
inst String
"Generic" ]

      tblBeamable :: Decl ()
tblBeamable = Text -> [Type ()] -> [InstDecl ()] -> Decl ()
hsInstance Text
"Beamable" [ String -> Type ()
tyConNamed String
tyName ] []
      tblPun :: Decl ()
tblPun = () -> DeclHead () -> Type () -> Decl ()
forall l. l -> DeclHead l -> Type l -> Decl l
Hs.TypeDecl () (() -> Name () -> DeclHead ()
forall l. l -> Name l -> DeclHead l
Hs.DHead () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
tyConName))
                              (Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
tyName) [ String -> Type ()
tyConNamed String
"Identity" ])

      tblEqInstance :: Decl ()
tblEqInstance = Text -> [Type ()] -> Decl ()
hsDerivingInstance Text
"Eq" [ String -> Type ()
tyConNamed String
tyConName ]
      tblShowInstance :: Decl ()
tblShowInstance = Text -> [Type ()] -> Decl ()
hsDerivingInstance Text
"Show" [ String -> Type ()
tyConNamed String
tyConName]

      tblInstanceDecl :: Decl ()
tblInstanceDecl = Text -> [Type ()] -> [InstDecl ()] -> Decl ()
hsInstance Text
"Table" [ String -> Type ()
tyConNamed String
tyName ] [InstDecl ()]
tableInstanceDecls

instance IsSql92ColumnSchemaSyntax HsColumnSchema where
  type Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema = HsConstraintDefinition
  type Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema = HsDataType
  type Sql92ColumnSchemaExpressionSyntax HsColumnSchema = HsExpr

  columnSchemaSyntax :: Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax HsColumnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
      HsColumnSchema]
-> Maybe Text
-> HsColumnSchema
columnSchemaSyntax Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema
dataType Maybe (Sql92ColumnSchemaExpressionSyntax HsColumnSchema)
_ [Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema]
cs Maybe Text
_ = (Text -> HsExpr) -> HsType -> HsColumnSchema
HsColumnSchema (\Text
nm -> Text -> HsExpr
fieldExpr Text
nm)
                                                      (HsType -> HsType
modTy (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ HsDataType -> HsType
hsDataTypeType Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema
HsDataType
dataType)
    where
      notNullable :: Bool
notNullable = (HsConstraintDefinition -> Bool)
-> [HsConstraintDefinition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((HsExpr -> HsExpr -> Bool
forall a. Eq a => a -> a -> Bool
==HsExpr
forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
notNullConstraintSyntax) (HsExpr -> Bool)
-> (HsConstraintDefinition -> HsExpr)
-> HsConstraintDefinition
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsConstraintDefinition -> HsExpr
hsConstraintDefinitionConstraint) [Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema]
[HsConstraintDefinition]
cs
      modTy :: HsType -> HsType
modTy HsType
t = if Bool
notNullable then HsType
t else HsType
t { hsTypeSyntax :: Type ()
hsTypeSyntax = Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"Maybe") [ HsType -> Type ()
hsTypeSyntax HsType
t ] }
      modDataTy :: HsExpr -> HsExpr
modDataTy HsExpr
e = if Bool
notNullable then HsExpr
e else HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"maybeType" Text
"Database.Beam.Migrate") [HsExpr
e]

      fieldExpr :: Text -> HsExpr
fieldExpr Text
nm = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"field" Text
"Database.Beam.Migrate")
                           ([ Text -> HsExpr
hsStr Text
nm
                            , HsExpr -> HsExpr
modDataTy (HsDataType -> HsExpr
hsDataTypeMigration Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema
HsDataType
dataType) ] [HsExpr] -> [HsExpr] -> [HsExpr]
forall a. [a] -> [a] -> [a]
++
                            (HsConstraintDefinition -> HsExpr)
-> [HsConstraintDefinition] -> [HsExpr]
forall a b. (a -> b) -> [a] -> [b]
map HsConstraintDefinition -> HsExpr
hsConstraintDefinitionConstraint [Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema]
[HsConstraintDefinition]
cs)

instance IsSql92TableConstraintSyntax HsTableConstraint where
  primaryKeyConstraintSyntax :: [Text] -> HsTableConstraint
primaryKeyConstraintSyntax [Text]
fields =
    (Text -> HsFieldLookup -> HsTableConstraintDecls)
-> HsTableConstraint
HsTableConstraint ((Text -> HsFieldLookup -> HsTableConstraintDecls)
 -> HsTableConstraint)
-> (Text -> HsFieldLookup -> HsTableConstraintDecls)
-> HsTableConstraint
forall a b. (a -> b) -> a -> b
$ \Text
tblNm HsFieldLookup
tblFields ->
    let primaryKeyDataDecl :: InstDecl ()
primaryKeyDataDecl = Type () -> [QualConDecl ()] -> Maybe (Deriving ()) -> InstDecl ()
insDataDecl Type ()
primaryKeyType [ QualConDecl ()
primaryKeyConDecl ] (Deriving () -> Maybe (Deriving ())
forall a. a -> Maybe a
Just Deriving ()
primaryKeyDeriving)

        tableTypeNm :: Text
tableTypeNm = Text
tblNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"T"
        tableTypeKeyNm :: Text
tableTypeKeyNm = Text
tblNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Key"

        ([Text]
fieldRecordNames, [Type ()]
fieldTys) = [(Text, Type ())] -> ([Text], [Type ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Text, Type ())] -> Maybe [(Text, Type ())] -> [(Text, Type ())]
forall a. a -> Maybe a -> a
fromMaybe (String -> [(Text, Type ())]
forall a. HasCallStack => String -> a
error String
"fieldTys") ((Text -> Maybe (Text, Type ()))
-> [Text] -> Maybe [(Text, Type ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsFieldLookup -> Text -> Maybe (Text, Type ())
hsFieldLookup HsFieldLookup
tblFields) [Text]
fields))

        primaryKeyType :: Type ()
primaryKeyType = Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"PrimaryKey") [ String -> Type ()
tyConNamed (Text -> String
T.unpack Text
tableTypeNm), String -> Type ()
tyVarNamed String
"f" ]
        primaryKeyConDecl :: QualConDecl ()
primaryKeyConDecl  = ()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> ConDecl ()
-> QualConDecl ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (() -> Name () -> [Type ()] -> ConDecl ()
forall l. l -> Name l -> [Type l] -> ConDecl l
Hs.ConDecl () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
tableTypeKeyNm)) [Type ()]
fieldTys)
        primaryKeyDeriving :: Deriving ()
primaryKeyDeriving = [InstRule ()] -> Deriving ()
derivingDecl [ String -> InstRule ()
inst String
"Generic" ]

        primaryKeyTypeDecl :: Decl ()
primaryKeyTypeDecl = () -> DeclHead () -> Type () -> Decl ()
forall l. l -> DeclHead l -> Type l -> Decl l
Hs.TypeDecl () (() -> Name () -> DeclHead ()
forall l. l -> Name l -> DeclHead l
Hs.DHead () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
tableTypeKeyNm)))
                                            (Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"PrimaryKey")
                                                   [ String -> Type ()
tyConNamed (Text -> String
T.unpack Text
tableTypeNm)
                                                   , String -> Type ()
tyConNamed String
"Identity" ])

        primaryKeyFunDecl :: InstDecl ()
primaryKeyFunDecl = () -> Decl () -> InstDecl ()
forall l. l -> Decl l -> InstDecl l
Hs.InsDecl () (() -> [Match ()] -> Decl ()
forall l. l -> [Match l] -> Decl l
Hs.FunBind () [() -> Name () -> [Pat ()] -> Rhs () -> Maybe (Binds ()) -> Match ()
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"primaryKey") [] (() -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
primaryKeyFunBody) Maybe (Binds ())
forall a. Maybe a
Nothing])
        primaryKeyFunBody :: Exp ()
primaryKeyFunBody = HsExpr -> Exp ()
hsExprSyntax (HsExpr -> Exp ()) -> HsExpr -> Exp ()
forall a b. (a -> b) -> a -> b
$
                            HsExpr -> [HsExpr] -> HsExpr
hsApApp (Text -> HsExpr
hsVar Text
tableTypeKeyNm)
                                    ((Text -> HsExpr) -> [Text] -> [HsExpr]
forall a b. (a -> b) -> [a] -> [b]
map Text -> HsExpr
hsVar [Text]
fieldRecordNames)

        decl :: Decl () -> HsDecl
decl Decl ()
d = Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
d HsImports
forall a. Monoid a => a
mempty [ExportSpec ()]
forall a. Monoid a => a
mempty

    in [InstDecl ()] -> [HsDecl] -> HsTableConstraintDecls
HsTableConstraintDecls [ InstDecl ()
primaryKeyDataDecl
                              , InstDecl ()
primaryKeyFunDecl ]
                              (Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
primaryKeyTypeDecl HsImports
forall a. Monoid a => a
mempty [ () -> QName () -> ExportSpec ()
forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual (Text -> String
T.unpack Text
tableTypeKeyNm)) ]HsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
:
                               (Decl () -> HsDecl) -> [Decl ()] -> [HsDecl]
forall a b. (a -> b) -> [a] -> [b]
map Decl () -> HsDecl
decl [ Text -> [Type ()] -> [InstDecl ()] -> Decl ()
hsInstance Text
"Beamable" [ Type () -> Type ()
tyParens (Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"PrimaryKey") [ String -> Type ()
tyConNamed (Text -> String
T.unpack Text
tableTypeNm)  ]) ] []
                                        , Text -> [Type ()] -> Decl ()
hsDerivingInstance Text
"Eq" [ String -> Type ()
tyConNamed (Text -> String
T.unpack Text
tableTypeKeyNm) ]
                                        , Text -> [Type ()] -> Decl ()
hsDerivingInstance Text
"Show" [ String -> Type ()
tyConNamed (Text -> String
T.unpack Text
tableTypeKeyNm) ]
                                        ])

instance IsSql92ColumnConstraintDefinitionSyntax HsConstraintDefinition where
  type Sql92ColumnConstraintDefinitionAttributesSyntax HsConstraintDefinition = HsNone
  type Sql92ColumnConstraintDefinitionConstraintSyntax HsConstraintDefinition = HsExpr

  constraintDefinitionSyntax :: Maybe Text
-> Sql92ColumnConstraintDefinitionConstraintSyntax
     HsConstraintDefinition
-> Maybe
     (Sql92ColumnConstraintDefinitionAttributesSyntax
        HsConstraintDefinition)
-> HsConstraintDefinition
constraintDefinitionSyntax Maybe Text
Nothing Sql92ColumnConstraintDefinitionConstraintSyntax
  HsConstraintDefinition
expr Maybe
  (Sql92ColumnConstraintDefinitionAttributesSyntax
     HsConstraintDefinition)
Nothing = HsExpr -> HsConstraintDefinition
HsConstraintDefinition Sql92ColumnConstraintDefinitionConstraintSyntax
  HsConstraintDefinition
HsExpr
expr
  constraintDefinitionSyntax Maybe Text
_ Sql92ColumnConstraintDefinitionConstraintSyntax
  HsConstraintDefinition
_ Maybe
  (Sql92ColumnConstraintDefinitionAttributesSyntax
     HsConstraintDefinition)
_ = String -> HsConstraintDefinition
forall a. HasCallStack => String -> a
error String
"constraintDefinitionSyntax{HsExpr}"

instance Sql92SerializableConstraintDefinitionSyntax HsConstraintDefinition where
  serializeConstraint :: HsConstraintDefinition -> Value
serializeConstraint HsConstraintDefinition
_ = Value
"unknown-constrainst"

instance IsSql92MatchTypeSyntax HsNone where
  fullMatchSyntax :: HsNone
fullMatchSyntax = HsNone
HsNone
  partialMatchSyntax :: HsNone
partialMatchSyntax = HsNone
HsNone
instance IsSql92ReferentialActionSyntax HsNone where
  referentialActionCascadeSyntax :: HsNone
referentialActionCascadeSyntax = HsNone
HsNone
  referentialActionNoActionSyntax :: HsNone
referentialActionNoActionSyntax = HsNone
HsNone
  referentialActionSetDefaultSyntax :: HsNone
referentialActionSetDefaultSyntax = HsNone
HsNone
  referentialActionSetNullSyntax :: HsNone
referentialActionSetNullSyntax = HsNone
HsNone

instance IsSql92ExtractFieldSyntax HsExpr where
  secondsField :: HsExpr
secondsField = Text -> HsExpr
hsVar Text
"secondsField"
  minutesField :: HsExpr
minutesField = Text -> HsExpr
hsVar Text
"minutesField"
  hourField :: HsExpr
hourField    = Text -> HsExpr
hsVar Text
"hourField"
  yearField :: HsExpr
yearField    = Text -> HsExpr
hsVar Text
"yearField"
  monthField :: HsExpr
monthField   = Text -> HsExpr
hsVar Text
"monthField"
  dayField :: HsExpr
dayField     = Text -> HsExpr
hsVar Text
"dayField"

instance IsSql92ExpressionSyntax HsExpr where
  type Sql92ExpressionFieldNameSyntax HsExpr = HsExpr
  type Sql92ExpressionSelectSyntax HsExpr = SqlSyntaxBuilder
  type Sql92ExpressionValueSyntax HsExpr = HsExpr
  type Sql92ExpressionQuantifierSyntax HsExpr = HsExpr
  type Sql92ExpressionExtractFieldSyntax HsExpr = HsExpr
  type Sql92ExpressionCastTargetSyntax HsExpr = HsDataType

  valueE :: Sql92ExpressionValueSyntax HsExpr -> HsExpr
valueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"valueE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  rowE :: [HsExpr] -> HsExpr
rowE = String -> [HsExpr] -> HsExpr
forall a. HasCallStack => String -> a
error String
"rowE"

  currentTimestampE :: HsExpr
currentTimestampE = Text -> HsExpr
hsVar Text
"currentTimestampE"
  defaultE :: HsExpr
defaultE = Text -> HsExpr
hsVar Text
"defaultE"

  coalesceE :: [HsExpr] -> HsExpr
coalesceE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"coalesceE")
  fieldE :: Sql92ExpressionFieldNameSyntax HsExpr -> HsExpr
fieldE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"fieldE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  betweenE :: HsExpr -> HsExpr -> HsExpr -> HsExpr
betweenE HsExpr
a HsExpr
b HsExpr
c = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"betweenE") [HsExpr
a, HsExpr
b, HsExpr
c]

  andE :: HsExpr -> HsExpr -> HsExpr
andE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"andE") [HsExpr
a, HsExpr
b]
  orE :: HsExpr -> HsExpr -> HsExpr
orE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"orE") [HsExpr
a, HsExpr
b]
  addE :: HsExpr -> HsExpr -> HsExpr
addE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"addE") [HsExpr
a, HsExpr
b]
  subE :: HsExpr -> HsExpr -> HsExpr
subE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"subE") [HsExpr
a, HsExpr
b]
  mulE :: HsExpr -> HsExpr -> HsExpr
mulE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"mulE") [HsExpr
a, HsExpr
b]
  divE :: HsExpr -> HsExpr -> HsExpr
divE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"divE") [HsExpr
a, HsExpr
b]
  modE :: HsExpr -> HsExpr -> HsExpr
modE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"modE") [HsExpr
a, HsExpr
b]
  likeE :: HsExpr -> HsExpr -> HsExpr
likeE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"likeE") [HsExpr
a, HsExpr
b]
  overlapsE :: HsExpr -> HsExpr -> HsExpr
overlapsE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"overlapsE") [HsExpr
a, HsExpr
b]
  positionE :: HsExpr -> HsExpr -> HsExpr
positionE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"positionE") [HsExpr
a, HsExpr
b]

  notE :: HsExpr -> HsExpr
notE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"notE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  negateE :: HsExpr -> HsExpr
negateE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"negateE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  absE :: HsExpr -> HsExpr
absE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"absE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  charLengthE :: HsExpr -> HsExpr
charLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"charLengthE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  octetLengthE :: HsExpr -> HsExpr
octetLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"octetLengthE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  bitLengthE :: HsExpr -> HsExpr
bitLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"bitLengthE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  lowerE :: HsExpr -> HsExpr
lowerE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"lowerE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  upperE :: HsExpr -> HsExpr
upperE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"upperE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  trimE :: HsExpr -> HsExpr
trimE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"trimE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  existsE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
existsE = String -> SqlSyntaxBuilder -> HsExpr
forall a. HasCallStack => String -> a
error String
"existsE"
  uniqueE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
uniqueE = String -> SqlSyntaxBuilder -> HsExpr
forall a. HasCallStack => String -> a
error String
"uniqueE"
  subqueryE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
subqueryE = String -> SqlSyntaxBuilder -> HsExpr
forall a. HasCallStack => String -> a
error String
"subqueryE"

  caseE :: [(HsExpr, HsExpr)] -> HsExpr -> HsExpr
caseE = String -> [(HsExpr, HsExpr)] -> HsExpr -> HsExpr
forall a. HasCallStack => String -> a
error String
"caseE"
  nullIfE :: HsExpr -> HsExpr -> HsExpr
nullIfE HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"nullIfE") [HsExpr
a, HsExpr
b]

  castE :: HsExpr -> Sql92ExpressionCastTargetSyntax HsExpr -> HsExpr
castE = String -> HsExpr -> HsDataType -> HsExpr
forall a. HasCallStack => String -> a
error String
"castE"
  extractE :: Sql92ExpressionExtractFieldSyntax HsExpr -> HsExpr -> HsExpr
extractE = String -> HsExpr -> HsExpr -> HsExpr
forall a. HasCallStack => String -> a
error String
"extractE"

  isNullE :: HsExpr -> HsExpr
isNullE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNullE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isNotNullE :: HsExpr -> HsExpr
isNotNullE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotNullE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isTrueE :: HsExpr -> HsExpr
isTrueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isTrueE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isFalseE :: HsExpr -> HsExpr
isFalseE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isFalseE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isNotTrueE :: HsExpr -> HsExpr
isNotTrueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotTrueE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isNotFalseE :: HsExpr -> HsExpr
isNotFalseE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotFalseE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isUnknownE :: HsExpr -> HsExpr
isUnknownE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isUnknownE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  isNotUnknownE :: HsExpr -> HsExpr
isNotUnknownE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotUnknownE") ([HsExpr] -> HsExpr) -> (HsExpr -> [HsExpr]) -> HsExpr -> HsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr -> [HsExpr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  eqE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
eqE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"eqE")   [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]
  neqE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
neqE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"neqE") [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]
  gtE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
gtE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"gtE")   [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]
  ltE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
ltE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"ltE")   [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]
  geE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
geE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"geE")   [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]
  leE :: Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
-> HsExpr -> HsExpr -> HsExpr
leE Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
q HsExpr
a HsExpr
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"leE")   [Maybe HsExpr -> HsExpr
hsMaybe Maybe (Sql92ExpressionQuantifierSyntax HsExpr)
Maybe HsExpr
q, HsExpr
a, HsExpr
b]

  inE :: HsExpr -> [HsExpr] -> HsExpr
inE HsExpr
a [HsExpr]
b = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"inE") [HsExpr
a, [HsExpr] -> HsExpr
hsList [HsExpr]
b]

instance IsSql92QuantifierSyntax HsExpr where
  quantifyOverAll :: HsExpr
quantifyOverAll = Text -> HsExpr
hsVar Text
"quantifyOverAll"
  quantifyOverAny :: HsExpr
quantifyOverAny = Text -> HsExpr
hsVar Text
"quantifyOverAny"

instance IsSql92ColumnConstraintSyntax HsExpr where
  type Sql92ColumnConstraintExpressionSyntax HsExpr = HsExpr
  type Sql92ColumnConstraintMatchTypeSyntax HsExpr = HsNone
  type Sql92ColumnConstraintReferentialActionSyntax HsExpr = HsNone

  notNullConstraintSyntax :: HsExpr
notNullConstraintSyntax = Text -> Text -> HsExpr
hsVarFrom Text
"notNull" Text
"Database.Beam.Migrate"
  uniqueColumnConstraintSyntax :: HsExpr
uniqueColumnConstraintSyntax = Text -> HsExpr
hsVar Text
"unique"
  checkColumnConstraintSyntax :: Sql92ColumnConstraintExpressionSyntax HsExpr -> HsExpr
checkColumnConstraintSyntax = String -> HsExpr -> HsExpr
forall a. HasCallStack => String -> a
error String
"checkColumnConstraintSyntax"
  primaryKeyColumnConstraintSyntax :: HsExpr
primaryKeyColumnConstraintSyntax = String -> HsExpr
forall a. HasCallStack => String -> a
error String
"primaryKeyColumnConstraintSyntax"
  referencesConstraintSyntax :: Text
-> [Text]
-> Maybe (Sql92ColumnConstraintMatchTypeSyntax HsExpr)
-> Maybe (Sql92ColumnConstraintReferentialActionSyntax HsExpr)
-> Maybe (Sql92ColumnConstraintReferentialActionSyntax HsExpr)
-> HsExpr
referencesConstraintSyntax = String
-> Text
-> [Text]
-> Maybe HsNone
-> Maybe HsNone
-> Maybe HsNone
-> HsExpr
forall a. HasCallStack => String -> a
error String
"referencesConstraintSyntax"

instance IsSql92ConstraintAttributesSyntax HsNone where
  initiallyDeferredAttributeSyntax :: HsNone
initiallyDeferredAttributeSyntax = HsNone
HsNone
  initiallyImmediateAttributeSyntax :: HsNone
initiallyImmediateAttributeSyntax = HsNone
HsNone
  notDeferrableAttributeSyntax :: HsNone
notDeferrableAttributeSyntax = HsNone
HsNone
  deferrableAttributeSyntax :: HsNone
deferrableAttributeSyntax = HsNone
HsNone

instance HasSqlValueSyntax HsExpr Int32 where
  sqlValueSyntax :: Int32 -> HsExpr
sqlValueSyntax = Int32 -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt
instance HasSqlValueSyntax HsExpr Bool where
  sqlValueSyntax :: Bool -> HsExpr
sqlValueSyntax Bool
True = Text -> HsExpr
hsVar Text
"True"
  sqlValueSyntax Bool
False = Text -> HsExpr
hsVar Text
"False"

instance IsSql92FieldNameSyntax HsExpr where
  qualifiedField :: Text -> Text -> HsExpr
qualifiedField Text
tbl Text
nm = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"qualifiedField") [ Text -> HsExpr
hsStr Text
tbl, Text -> HsExpr
hsStr Text
nm ]
  unqualifiedField :: Text -> HsExpr
unqualifiedField Text
nm = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"unqualifiedField") [ Text -> HsExpr
hsStr Text
nm ]

hsErrorType :: String -> HsDataType
hsErrorType :: String -> HsDataType
hsErrorType String
msg =
  HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"error") [ Text -> HsExpr
hsStr (Text
"Unknown type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString String
msg) ]) (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Void") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Void" [ Text -> ImportSpec ()
importTyNamed Text
"Void" ]))
             (Value -> BeamSerializedDataType
BeamSerializedDataType Value
"hsErrorType")

instance IsSql92DataTypeSyntax HsDataType where
  intType :: HsDataType
intType = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"int" Text
"Database.Beam.Migrate") (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Int") HsImports
forall a. Monoid a => a
mempty) BeamSerializedDataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType
  smallIntType :: HsDataType
smallIntType = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"smallint" Text
"Database.Beam.Migrate") (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Int16") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Int" [ Text -> ImportSpec ()
importTyNamed Text
"Int16" ])) BeamSerializedDataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType
  doubleType :: HsDataType
doubleType = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"double" Text
"Database.Beam.Migrate") (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Double") HsImports
forall a. Monoid a => a
mempty) BeamSerializedDataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
doubleType

  floatType :: Maybe Word -> HsDataType
floatType Maybe Word
width = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"float" Text
"Database.Beam.Migrate")
                                      [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Scientific") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Scientific" [ Text -> ImportSpec ()
importTyNamed Text
"Scientific" ]))
                               (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
floatType Maybe Word
width)

  realType :: HsDataType
realType = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"real" Text
"Database.Beam.Migrate") (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Double") HsImports
forall a. Monoid a => a
mempty) BeamSerializedDataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
realType

  charType :: Maybe Word -> Maybe Text -> HsDataType
charType Maybe Word
_ Just {} = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"char collation"
  charType Maybe Word
width Maybe Text
Nothing = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"char" Text
"Database.Beam.Migrate")
                                             [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                                      (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Text") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Text" [ Text -> ImportSpec ()
importTyNamed Text
"Text" ]))
                                      (Maybe Word -> Maybe Text -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
charType Maybe Word
width Maybe Text
forall a. Maybe a
Nothing)

  varCharType :: Maybe Word -> Maybe Text -> HsDataType
varCharType Maybe Word
_ Just {} = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"varchar collation"
  varCharType Maybe Word
width Maybe Text
Nothing = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"varchar" Text
"Database.Beam.Migrate")
                                                [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                                         (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Text") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Text" [ Text -> ImportSpec ()
importTyNamed Text
"Text" ]))
                                         (Maybe Word -> Maybe Text -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
varCharType Maybe Word
width Maybe Text
forall a. Maybe a
Nothing)

  nationalCharType :: Maybe Word -> HsDataType
nationalCharType Maybe Word
width = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"nationalChar" Text
"Database.Beam.Migrate")
                                             [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                                      (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Text") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Text" [ Text -> ImportSpec ()
importTyNamed Text
"Text" ]))
                                      (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
nationalCharType Maybe Word
width)

  nationalVarCharType :: Maybe Word -> HsDataType
nationalVarCharType Maybe Word
width = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"nationalVarchar" Text
"Database.Beam.Migrate")
                                                [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                                         (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Text") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Text" [ Text -> ImportSpec ()
importTyNamed Text
"Text" ]))
                                         (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
nationalVarCharType Maybe Word
width)

  bitType :: Maybe Word -> HsDataType
bitType Maybe Word
width = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"bit" Text
"Database.Beam.Migrate")
                                    [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                             (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"SqlBits") HsImports
forall a. Monoid a => a
mempty)
                             (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
bitType Maybe Word
width)

  varBitType :: Maybe Word -> HsDataType
varBitType Maybe Word
width = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"varbit" Text
"Database.Beam.Migrate")
                                       [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
                                (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"SqlBits") HsImports
forall a. Monoid a => a
mempty)
                                (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
varBitType Maybe Word
width)

  dateType :: HsDataType
dateType = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"date" Text
"Database.Beam.Migrate")
                        (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Day") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Time" [ Text -> ImportSpec ()
importTyNamed Text
"Day" ])) BeamSerializedDataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
dateType

  timeType :: Maybe Word -> Bool -> HsDataType
timeType Maybe Word
p Bool
False = HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"time" Text
"Database.Beam.Migrate") [ Maybe HsExpr -> HsExpr
hsMaybe Maybe HsExpr
forall a. Maybe a
Nothing ] )
                                (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"TimeOfDay") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Time" [ Text -> ImportSpec ()
importTyNamed Text
"TimeOfDay" ]))
                                (Maybe Word -> Bool -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timeType Maybe Word
p Bool
False)
  timeType Maybe Word
_ Bool
_ = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"timeType"
  domainType :: Text -> HsDataType
domainType Text
_ = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"domainType"
  timestampType :: Maybe Word -> Bool -> HsDataType
timestampType Maybe Word
Nothing Bool
True =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"timestamptz" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"LocalTime") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Time" [ Text -> ImportSpec ()
importTyNamed Text
"LocalTime" ]))
               (Maybe Word -> Bool -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
True)
  timestampType Maybe Word
Nothing Bool
False =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"timestamp" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"LocalTime") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Time" [ Text -> ImportSpec ()
importTyNamed Text
"LocalTime" ]))
               (Maybe Word -> Bool -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
False)
  timestampType Maybe Word
_ Bool
_ = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"timestampType with prec"

  numericType :: Maybe (Word, Maybe Word) -> HsDataType
numericType Maybe (Word, Maybe Word)
precDec =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"numeric" Text
"Database.Beam.Migrate")
                      [ Maybe HsExpr -> HsExpr
hsMaybe (((Word, Maybe Word) -> HsExpr)
-> Maybe (Word, Maybe Word) -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Word
prec, Maybe Word
dec) -> [HsExpr] -> HsExpr
hsTuple [ Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt Word
prec, Maybe HsExpr -> HsExpr
hsMaybe ((Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt Maybe Word
dec) ]) Maybe (Word, Maybe Word)
precDec) ])
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Scientific") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Scientific" [ Text -> ImportSpec ()
importTyNamed Text
"Scientific" ]))
               (Maybe (Word, Maybe Word) -> BeamSerializedDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType Maybe (Word, Maybe Word)
precDec)

  decimalType :: Maybe (Word, Maybe Word) -> HsDataType
decimalType = Maybe (Word, Maybe Word) -> HsDataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType

instance IsSql99DataTypeSyntax HsDataType where
  characterLargeObjectType :: HsDataType
characterLargeObjectType =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"characterLargeObject" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Text") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Text" [ Text -> ImportSpec ()
importTyNamed Text
"Text" ]))
               BeamSerializedDataType
forall dataType. IsSql99DataTypeSyntax dataType => dataType
characterLargeObjectType
  binaryLargeObjectType :: HsDataType
binaryLargeObjectType =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"binaryLargeObject" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"ByteString") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.ByteString" [ Text -> ImportSpec ()
importTyNamed Text
"ByteString" ]))
               BeamSerializedDataType
forall dataType. IsSql99DataTypeSyntax dataType => dataType
binaryLargeObjectType
  booleanType :: HsDataType
booleanType =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"boolean" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Bool") HsImports
forall a. Monoid a => a
mempty)
               BeamSerializedDataType
forall dataType. IsSql99DataTypeSyntax dataType => dataType
booleanType
  arrayType :: HsDataType -> Int -> HsDataType
arrayType (HsDataType HsExpr
migType (HsType Type ()
typeExpr HsImports
typeImports) BeamSerializedDataType
serialized) Int
len =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"array" Text
"Database.Beam.Migrate") [ HsExpr
migType, Int -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt Int
len ])
               (Type () -> HsImports -> HsType
HsType (Type () -> [Type ()] -> Type ()
tyApp (String -> Type ()
tyConNamed String
"Vector") [Type ()
typeExpr])
                       (HsImports
typeImports HsImports -> HsImports -> HsImports
forall a. Semigroup a => a -> a -> a
<> Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Vector" [ Text -> ImportSpec ()
importTyNamed Text
"Vector" ]))
               (BeamSerializedDataType -> Int -> BeamSerializedDataType
forall dataType.
IsSql99DataTypeSyntax dataType =>
dataType -> Int -> dataType
arrayType BeamSerializedDataType
serialized Int
len)
  rowType :: [(Text, HsDataType)] -> HsDataType
rowType [(Text, HsDataType)]
_ = String -> HsDataType
forall a. HasCallStack => String -> a
error String
"row types"

instance IsSql2003BinaryAndVarBinaryDataTypeSyntax HsDataType where
  binaryType :: Maybe Word -> HsDataType
binaryType Maybe Word
prec =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"binary" Text
"Database.Beam.Migrate") [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
prec) ])
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Integer") HsImports
forall a. Monoid a => a
mempty)
               (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql2003BinaryAndVarBinaryDataTypeSyntax dataType =>
Maybe Word -> dataType
binaryType Maybe Word
prec)
  varBinaryType :: Maybe Word -> HsDataType
varBinaryType Maybe Word
prec =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> Text -> HsExpr
hsVarFrom Text
"varbinary" Text
"Database.Beam.Migrate") [ Maybe HsExpr -> HsExpr
hsMaybe (Word -> HsExpr
forall a. (Integral a, Show a) => a -> HsExpr
hsInt (Word -> HsExpr) -> Maybe Word -> Maybe HsExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
prec) ])
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Integer") HsImports
forall a. Monoid a => a
mempty)
               (Maybe Word -> BeamSerializedDataType
forall dataType.
IsSql2003BinaryAndVarBinaryDataTypeSyntax dataType =>
Maybe Word -> dataType
varBinaryType Maybe Word
prec)

instance IsSql2008BigIntDataTypeSyntax HsDataType where
  bigIntType :: HsDataType
bigIntType =
    HsExpr -> HsType -> BeamSerializedDataType -> HsDataType
HsDataType (Text -> Text -> HsExpr
hsVarFrom Text
"bigint" Text
"Database.Beam.Migrate")
               (Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Int64") (Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Int" [ Text -> ImportSpec ()
importTyNamed Text
"Int64" ]))
               BeamSerializedDataType
forall dataType. IsSql2008BigIntDataTypeSyntax dataType => dataType
bigIntType

instance Sql92SerializableDataTypeSyntax HsDataType where
  serializeDataType :: HsDataType -> Value
serializeDataType = BeamSerializedDataType -> Value
fromBeamSerializedDataType (BeamSerializedDataType -> Value)
-> (HsDataType -> BeamSerializedDataType) -> HsDataType -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDataType -> BeamSerializedDataType
hsDataTypeSerialized

-- * HsSyntax utilities

tyParens :: Hs.Type () -> Hs.Type ()
tyParens :: Type () -> Type ()
tyParens = () -> Type () -> Type ()
forall l. l -> Type l -> Type l
Hs.TyParen ()

functionTy :: Hs.Type () -> Hs.Type () -> Hs.Type ()
functionTy :: Type () -> Type () -> Type ()
functionTy = () -> Type () -> Type () -> Type ()
forall l. l -> Type l -> Type l -> Type l
Hs.TyFun ()

tyTuple :: [ Hs.Type () ] -> Hs.Type ()
tyTuple :: [Type ()] -> Type ()
tyTuple = () -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
Hs.TyTuple () Boxed
Hs.Boxed

tyApp :: Hs.Type () -> [ Hs.Type () ]
      -> Hs.Type ()
tyApp :: Type () -> [Type ()] -> Type ()
tyApp Type ()
fn [Type ()]
args = (Type () -> Type () -> Type ()) -> Type () -> [Type ()] -> Type ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (() -> Type () -> Type () -> Type ()
forall l. l -> Type l -> Type l -> Type l
Hs.TyApp ()) Type ()
fn [Type ()]
args

tyConNamed :: String -> Hs.Type ()
tyConNamed :: String -> Type ()
tyConNamed String
nm = () -> QName () -> Type ()
forall l. l -> QName l -> Type l
Hs.TyCon () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
nm))

tyVarNamed :: String -> Hs.Type ()
tyVarNamed :: String -> Type ()
tyVarNamed String
nm = () -> Name () -> Type ()
forall l. l -> Name l -> Type l
Hs.TyVar () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
nm)

combineHsExpr :: (Hs.Exp () -> Hs.Exp () -> Hs.Exp ())
              -> HsExpr -> HsExpr -> HsExpr
combineHsExpr :: (Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr Exp () -> Exp () -> Exp ()
f HsExpr
a HsExpr
b =
  Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (Exp () -> Exp () -> Exp ()
f (HsExpr -> Exp ()
hsExprSyntax HsExpr
a) (HsExpr -> Exp ()
hsExprSyntax HsExpr
b))
         (HsExpr -> HsImports
hsExprImports HsExpr
a HsImports -> HsImports -> HsImports
forall a. Semigroup a => a -> a -> a
<> HsExpr -> HsImports
hsExprImports HsExpr
b)
         (HsExpr -> [Asst ()]
hsExprConstraints HsExpr
a [Asst ()] -> [Asst ()] -> [Asst ()]
forall a. Semigroup a => a -> a -> a
<> HsExpr -> [Asst ()]
hsExprConstraints HsExpr
b)
         (HsExpr -> Set (Name ())
hsExprTypeVariables HsExpr
a Set (Name ()) -> Set (Name ()) -> Set (Name ())
forall a. Semigroup a => a -> a -> a
<> HsExpr -> Set (Name ())
hsExprTypeVariables HsExpr
b)

hsApp :: HsExpr -> [HsExpr] -> HsExpr
hsApp :: HsExpr -> [HsExpr] -> HsExpr
hsApp HsExpr
fn [HsExpr]
args = (HsExpr -> HsExpr -> HsExpr) -> HsExpr -> [HsExpr] -> HsExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExpr -> HsExpr -> HsExpr
hsDoApp HsExpr
fn [HsExpr]
args
  where
    hsDoApp :: HsExpr -> HsExpr -> HsExpr
hsDoApp = (Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
Hs.App ())

hsVisibleTyApp :: HsExpr -> Hs.Type () -> HsExpr
hsVisibleTyApp :: HsExpr -> Type () -> HsExpr
hsVisibleTyApp HsExpr
e Type ()
t = HsExpr
e { hsExprSyntax :: Exp ()
hsExprSyntax = () -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
Hs.App () (HsExpr -> Exp ()
hsExprSyntax HsExpr
e) (() -> Type () -> Exp ()
forall l. l -> Type l -> Exp l
Hs.TypeApp () Type ()
t) }

hsApApp :: HsExpr -> [HsExpr] -> HsExpr
hsApApp :: HsExpr -> [HsExpr] -> HsExpr
hsApApp HsExpr
fn [] = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"pure") [ HsExpr
fn ]
hsApApp HsExpr
fn (HsExpr
x:[HsExpr]
xs) = (HsExpr -> HsExpr -> HsExpr) -> HsExpr -> [HsExpr] -> HsExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExpr -> HsExpr -> HsExpr
mkAp (HsExpr -> HsExpr -> HsExpr
mkFmap HsExpr
fn HsExpr
x) [HsExpr]
xs
  where
    mkFmap :: HsExpr -> HsExpr -> HsExpr
mkFmap = (Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr (\Exp ()
a Exp ()
b -> () -> Exp () -> QOp () -> Exp () -> Exp ()
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
Hs.InfixApp () Exp ()
a QOp ()
fmapOp Exp ()
b)
    mkAp :: HsExpr -> HsExpr -> HsExpr
mkAp = (Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr (\Exp ()
a Exp ()
b -> () -> Exp () -> QOp () -> Exp () -> Exp ()
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
Hs.InfixApp () Exp ()
a QOp ()
apOp Exp ()
b)

    fmapOp :: QOp ()
fmapOp = Text -> QOp ()
hsOp Text
"<$>"
    apOp :: QOp ()
apOp = Text -> QOp ()
hsOp Text
"<*>"

hsStr :: T.Text -> HsExpr
hsStr :: Text -> HsExpr
hsStr Text
t = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> Literal () -> Exp ()
forall l. l -> Literal l -> Exp l
Hs.Lit () (() -> String -> String -> Literal ()
forall l. l -> String -> String -> Literal l
Hs.String () String
s String
s)) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty
  where s :: String
s = Text -> String
T.unpack Text
t

hsRecCon :: T.Text -> [ (T.Text, HsExpr) ] -> HsExpr
hsRecCon :: Text -> [(Text, HsExpr)] -> HsExpr
hsRecCon Text
nm [(Text, HsExpr)]
fs = (HsExpr -> HsExpr -> HsExpr) -> HsExpr -> [HsExpr] -> HsExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr Exp () -> Exp () -> Exp ()
forall a b. a -> b -> a
const) (Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr Exp ()
e HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty) (((Text, HsExpr) -> HsExpr) -> [(Text, HsExpr)] -> [HsExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Text, HsExpr) -> HsExpr
forall a b. (a, b) -> b
snd [(Text, HsExpr)]
fs)
  where
    e :: Exp ()
e = () -> QName () -> [FieldUpdate ()] -> Exp ()
forall l. l -> QName l -> [FieldUpdate l] -> Exp l
Hs.RecConstr () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))
                        (((Text, HsExpr) -> FieldUpdate ())
-> [(Text, HsExpr)] -> [FieldUpdate ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, HsExpr
e') -> () -> QName () -> Exp () -> FieldUpdate ()
forall l. l -> QName l -> Exp l -> FieldUpdate l
Hs.FieldUpdate () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
fieldNm)))
                                                                  (HsExpr -> Exp ()
hsExprSyntax HsExpr
e')) [(Text, HsExpr)]
fs)

hsMaybe :: Maybe HsExpr -> HsExpr
hsMaybe :: Maybe HsExpr -> HsExpr
hsMaybe Maybe HsExpr
Nothing = Text -> HsExpr
hsTyCon Text
"Nothing"
hsMaybe (Just HsExpr
e) = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsTyCon Text
"Just") [HsExpr
e]

hsVar :: T.Text -> HsExpr
hsVar :: Text -> HsExpr
hsVar Text
nm = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Hs.Var () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty

hsVarFrom :: T.Text -> T.Text -> HsExpr
hsVarFrom :: Text -> Text -> HsExpr
hsVarFrom Text
nm Text
modNm = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Hs.Var () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))) (Text -> [ImportSpec ()] -> HsImports
importSome Text
modNm [ Text -> ImportSpec ()
importVarNamed Text
nm])
                            [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty

hsTyCon :: T.Text -> HsExpr
hsTyCon :: Text -> HsExpr
hsTyCon Text
nm = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Hs.Con () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty

hsInt :: (Integral a, Show a) => a -> HsExpr
hsInt :: a -> HsExpr
hsInt a
i = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> Literal () -> Exp ()
forall l. l -> Literal l -> Exp l
Hs.Lit () (() -> Integer -> String -> Literal ()
forall l. l -> Integer -> String -> Literal l
Hs.Int () (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i) (a -> String
forall a. Show a => a -> String
show a
i))) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty

hsOp :: T.Text -> Hs.QOp ()
hsOp :: Text -> QOp ()
hsOp Text
nm = () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
Hs.QVarOp () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Symbol () (Text -> String
T.unpack Text
nm)))

hsInstance :: T.Text -> [ Hs.Type () ] -> [ Hs.InstDecl () ] -> Hs.Decl ()
hsInstance :: Text -> [Type ()] -> [InstDecl ()] -> Decl ()
hsInstance Text
classNm [Type ()]
params [InstDecl ()]
decls =
  ()
-> Maybe (Overlap ())
-> InstRule ()
-> Maybe [InstDecl ()]
-> Decl ()
forall l.
l
-> Maybe (Overlap l) -> InstRule l -> Maybe [InstDecl l] -> Decl l
Hs.InstDecl () Maybe (Overlap ())
forall a. Maybe a
Nothing (()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> InstHead ()
-> InstRule ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing InstHead ()
instHead) (Maybe [InstDecl ()] -> Decl ()) -> Maybe [InstDecl ()] -> Decl ()
forall a b. (a -> b) -> a -> b
$
  case [InstDecl ()]
decls of
    [] -> Maybe [InstDecl ()]
forall a. Maybe a
Nothing
    [InstDecl ()]
_  -> [InstDecl ()] -> Maybe [InstDecl ()]
forall a. a -> Maybe a
Just [InstDecl ()]
decls
  where
    instHead :: InstHead ()
instHead = (InstHead () -> Type () -> InstHead ())
-> InstHead () -> [Type ()] -> InstHead ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (() -> InstHead () -> Type () -> InstHead ()
forall l. l -> InstHead l -> Type l -> InstHead l
Hs.IHApp ()) (() -> QName () -> InstHead ()
forall l. l -> QName l -> InstHead l
Hs.IHCon () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
classNm)))) [Type ()]
params

hsDerivingInstance :: T.Text -> [ Hs.Type () ] -> Hs.Decl ()
hsDerivingInstance :: Text -> [Type ()] -> Decl ()
hsDerivingInstance Text
classNm [Type ()]
params =
#if MIN_VERSION_haskell_src_exts(1,20,0)
  ()
-> Maybe (DerivStrategy ())
-> Maybe (Overlap ())
-> InstRule ()
-> Decl ()
forall l.
l
-> Maybe (DerivStrategy l)
-> Maybe (Overlap l)
-> InstRule l
-> Decl l
Hs.DerivDecl () Maybe (DerivStrategy ())
forall a. Maybe a
Nothing Maybe (Overlap ())
forall a. Maybe a
Nothing (()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> InstHead ()
-> InstRule ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing InstHead ()
instHead)
#else
  Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead)
#endif
  where
    instHead :: InstHead ()
instHead = (InstHead () -> Type () -> InstHead ())
-> InstHead () -> [Type ()] -> InstHead ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (() -> InstHead () -> Type () -> InstHead ()
forall l. l -> InstHead l -> Type l -> InstHead l
Hs.IHApp ()) (() -> QName () -> InstHead ()
forall l. l -> QName l -> InstHead l
Hs.IHCon () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
classNm)))) [Type ()]
params

hsList, hsTuple :: [ HsExpr ] -> HsExpr
hsList :: [HsExpr] -> HsExpr
hsList = (HsExpr -> HsExpr -> HsExpr) -> HsExpr -> [HsExpr] -> HsExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr Exp () -> Exp () -> Exp ()
addList) (Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> [Exp ()] -> Exp ()
forall l. l -> [Exp l] -> Exp l
Hs.List () []) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty)
  where
    addList :: Exp () -> Exp () -> Exp ()
addList (Hs.List () [Exp ()]
ts) Exp ()
t = () -> [Exp ()] -> Exp ()
forall l. l -> [Exp l] -> Exp l
Hs.List () ([Exp ()]
ts [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. [a] -> [a] -> [a]
++ [Exp ()
t])
    addList Exp ()
_ Exp ()
_ = String -> Exp ()
forall a. HasCallStack => String -> a
error String
"addList"
hsTuple :: [HsExpr] -> HsExpr
hsTuple = (HsExpr -> HsExpr -> HsExpr) -> HsExpr -> [HsExpr] -> HsExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr Exp () -> Exp () -> Exp ()
addTuple) (Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (() -> Boxed -> [Exp ()] -> Exp ()
forall l. l -> Boxed -> [Exp l] -> Exp l
Hs.Tuple () Boxed
Hs.Boxed []) HsImports
forall a. Monoid a => a
mempty [Asst ()]
forall a. Monoid a => a
mempty Set (Name ())
forall a. Monoid a => a
mempty)
  where
    addTuple :: Exp () -> Exp () -> Exp ()
addTuple (Hs.Tuple () Boxed
boxed [Exp ()]
ts) Exp ()
t = () -> Boxed -> [Exp ()] -> Exp ()
forall l. l -> Boxed -> [Exp l] -> Exp l
Hs.Tuple () Boxed
boxed ([Exp ()]
ts [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. [a] -> [a] -> [a]
++ [Exp ()
t])
    addTuple Exp ()
_ Exp ()
_ = String -> Exp ()
forall a. HasCallStack => String -> a
error String
"addTuple"

inst :: String -> Hs.InstRule ()
inst :: String -> InstRule ()
inst = ()
-> Maybe [TyVarBind ()]
-> Maybe (Context ())
-> InstHead ()
-> InstRule ()
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (InstHead () -> InstRule ())
-> (String -> InstHead ()) -> String -> InstRule ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> QName () -> InstHead ()
forall l. l -> QName l -> InstHead l
Hs.IHCon () (QName () -> InstHead ())
-> (String -> QName ()) -> String -> InstHead ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (Name () -> QName ()) -> (String -> Name ()) -> String -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident ()

beamMigrateSqlBackend :: HsBackendConstraint
beamMigrateSqlBackend :: HsBackendConstraint
beamMigrateSqlBackend =
  (Type () -> Asst ()) -> HsBackendConstraint
HsBackendConstraint ((Type () -> Asst ()) -> HsBackendConstraint)
-> (Type () -> Asst ()) -> HsBackendConstraint
forall a b. (a -> b) -> a -> b
$ \Type ()
beTy ->
#if MIN_VERSION_haskell_src_exts(1, 22, 0)
  () -> Type () -> Asst ()
forall l. l -> Type l -> Asst l
Hs.TypeA () (() -> Type () -> Type () -> Type ()
forall l. l -> Type l -> Type l -> Type l
Hs.TyApp () (() -> QName () -> Type ()
forall l. l -> QName l -> Type l
Hs.TyCon () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
Hs.UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Hs.Ident () String
"BeamMigrateSqlBackend"))) Type ()
beTy)
#else
  Hs.ClassA () (Hs.UnQual () (Hs.Ident () "BeamMigrateSqlBackend")) [ beTy ]
#endif



-- * Orphans

instance Hashable (Hs.Exp ())
instance Hashable (Hs.QName ())
instance Hashable (Hs.ModuleName ())
instance Hashable (Hs.IPName ())
instance Hashable (Hs.Asst ())
instance Hashable (Hs.Literal ())
instance Hashable (Hs.Name ())
instance Hashable (Hs.Type ())
instance Hashable (Hs.QOp ())
instance Hashable (Hs.TyVarBind ())
#if !MIN_VERSION_haskell_src_exts(1, 21, 0)
instance Hashable (Hs.Kind ())
#endif
instance Hashable (Hs.Context ())
instance Hashable (Hs.SpecialCon ())
instance Hashable (Hs.Pat ())
instance Hashable (Hs.Sign ())
instance Hashable Hs.Boxed
instance Hashable (Hs.Promoted ())
instance Hashable (Hs.Binds ())
instance Hashable (Hs.Splice ())
instance Hashable (Hs.PatField ())
instance Hashable (Hs.Decl ())
instance Hashable (Hs.DeclHead ())
instance Hashable (Hs.IPBind ())
instance Hashable (Hs.RPat ())
instance Hashable (Hs.Stmt ())
instance Hashable (Hs.RPatOp ())
instance Hashable (Hs.XName ())
instance Hashable (Hs.ResultSig ())
instance Hashable (Hs.Alt ())
instance Hashable (Hs.Unpackedness ())
instance Hashable (Hs.InjectivityInfo ())
instance Hashable (Hs.PXAttr ())
instance Hashable (Hs.Rhs ())
instance Hashable (Hs.FieldUpdate ())
instance Hashable (Hs.TypeEqn ())
instance Hashable (Hs.QualStmt ())
instance Hashable (Hs.DataOrNew ())
instance Hashable (Hs.Bracket ())
instance Hashable (Hs.QualConDecl ())
instance Hashable (Hs.XAttr ())
instance Hashable (Hs.ConDecl ())
instance Hashable (Hs.Deriving ())
instance Hashable (Hs.InstRule ())
instance Hashable (Hs.FieldDecl ())
instance Hashable (Hs.GadtDecl ())
instance Hashable (Hs.InstHead ())
instance Hashable (Hs.FunDep ())
instance Hashable (Hs.ClassDecl ())
instance Hashable (Hs.Overlap ())
instance Hashable (Hs.InstDecl ())
instance Hashable (Hs.Assoc ())
instance Hashable (Hs.Op ())
instance Hashable (Hs.Match ())
instance Hashable (Hs.PatternSynDirection ())
instance Hashable (Hs.CallConv ())
instance Hashable (Hs.Safety ())
instance Hashable (Hs.Rule ())
instance Hashable (Hs.Activation ())
instance Hashable (Hs.RuleVar ())
instance Hashable (Hs.Annotation ())
instance Hashable (Hs.BooleanFormula ())
instance Hashable (Hs.Role ())
instance Hashable (Hs.GuardedRhs ())
instance Hashable (Hs.BangType ())
instance Hashable (Hs.ImportSpec ())
instance Hashable (Hs.Namespace ())
instance Hashable (Hs.CName ())
#if MIN_VERSION_haskell_src_exts(1,20,0)
instance Hashable (Hs.DerivStrategy ())
instance Hashable (Hs.MaybePromotedName ())
#endif
#if !MIN_VERSION_hashable(1, 3, 4)
instance Hashable a => Hashable (S.Set a) where
  hashWithSalt s a = hashWithSalt s (S.toList a)
#endif