{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
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
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
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. 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 = forall a. Show a => a -> String
show
newtype HsEntityName = HsEntityName { HsEntityName -> String
getHsEntityName :: String } deriving (Int -> HsEntityName -> ShowS
[HsEntityName] -> ShowS
HsEntityName -> String
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
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
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
Ord, String -> 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
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
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. 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
(<>) = forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsImport where
mempty :: HsImport
mempty = Set (ImportSpec ()) -> HsImport
HsImportSome 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 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 (forall k a. k -> a -> Map k a
M.singleton (forall l. l -> String -> ModuleName l
Hs.ModuleName () (Text -> String
T.unpack Text
modNm))
(Set (ImportSpec ()) -> HsImport
HsImportSome (forall a. Ord a => [a] -> Set a
S.fromList [ImportSpec ()]
names)))
importTyNamed :: T.Text -> Hs.ImportSpec ()
importTyNamed :: Text -> ImportSpec ()
importTyNamed = Text -> ImportSpec ()
importVarNamed
importVarNamed :: T.Text -> Hs.ImportSpec ()
importVarNamed :: Text -> ImportSpec ()
importVarNamed Text
nm = forall l. l -> Name l -> ImportSpec l
Hs.IVar () (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
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
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) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (forall k a. Map k a -> [(k, a)]
M.assocs Map (ModuleName ()) HsImport
a)
instance Semigroup HsImports where
<> :: HsImports -> HsImports -> HsImports
(<>) = forall a. Monoid a => a -> a -> a
mappend
instance Monoid HsImports where
mempty :: HsImports
mempty = Map (ModuleName ()) HsImport -> HsImports
HsImports 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 (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith 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
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
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. 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
_) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (HsExpr
mig, HsType
ty)
instance Sql92DisplaySyntax HsDataType where
displaySyntax :: HsDataType -> String
displaySyntax = 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
data HsType
= HsType
{ HsType -> Type ()
hsTypeSyntax :: Hs.Type ()
, HsType -> HsImports
hsTypeImports :: HsImports
} deriving (Int -> HsType -> ShowS
[HsType] -> ShowS
HsType -> String
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
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. 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
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
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. 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
_) = 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" forall a. Eq a => a -> a -> Bool
== Text -> HsExpr
b Text
"fieldNm" Bool -> Bool -> Bool
&& HsType
aTy 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) = 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 = 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
(<>) = 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 forall a. Semigroup a => a -> a -> a
<> [(Maybe (Pat ()), HsExpr)]
mb) ([HsEntity]
ea 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
(<>) = forall a. Monoid a => a -> a -> a
mappend
instance Monoid (HsBeamBackend f) where
mempty :: HsBeamBackend f
mempty = 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 forall a. Eq a => a -> a -> Bool
== HsType
bTy = forall f. HsType -> f -> HsBeamBackend f
HsBeamBackendSingle HsType
aTy f
aExp
| Bool
otherwise = 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
_ = forall f. HsBeamBackend f
HsBeamBackendNone
mappend HsBeamBackend f
_ HsBeamBackend f
HsBeamBackendNone = forall f. HsBeamBackend f
HsBeamBackendNone
mappend (HsBeamBackendConstrained [HsBackendConstraint]
a) (HsBeamBackendConstrained [HsBackendConstraint]
b) =
forall f. [HsBackendConstraint] -> HsBeamBackend f
HsBeamBackendConstrained ([HsBackendConstraint]
a 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
(<>) = 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 forall a. Semigroup a => a -> a -> a
<> [InstDecl ()]
bi) ([HsDecl]
ad 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 = 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 = forall l. l -> Name l -> QName l
Hs.UnQual () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> String -> Name l
Hs.Ident ()
entityDbFieldName :: HsEntity -> String
entityDbFieldName :: HsEntity -> String
entityDbFieldName HsEntity
entity = String
"_" 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)
forall l.
l -> Maybe (DerivStrategy l) -> [InstRule l] -> Deriving l
Hs.Deriving () 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)
forall l.
l
-> DataOrNew l
-> Maybe (Context l)
-> DeclHead l
-> [QualConDecl l]
-> [Deriving l]
-> Decl l
Hs.DataDecl () (forall l. l -> DataOrNew l
Hs.DataType ()) forall a. Maybe a
Nothing DeclHead ()
declHead [QualConDecl ()]
cons (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)
forall l.
l
-> DataOrNew l
-> Type l
-> [QualConDecl l]
-> [Deriving l]
-> InstDecl l
Hs.InsData () (forall l. l -> DataOrNew l
Hs.DataType ()) Type ()
declHead [QualConDecl ()]
cons (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 ] (forall a. a -> Maybe a
Just Deriving ()
deriving_)
where
declHead :: DeclHead ()
declHead = forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
Hs.DHApp () (forall l. l -> Name l -> DeclHead l
Hs.DHead () (forall l. l -> String -> Name l
Hs.Ident () String
"Db"))
(forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (forall l. l -> String -> Name l
Hs.Ident () String
"entity"))
conDecl :: QualConDecl ()
conDecl = forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () forall a. Maybe a
Nothing forall a. Maybe a
Nothing
(forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
Hs.RecDecl () (forall l. l -> String -> Name l
Hs.Ident () String
"Db") (HsEntity -> FieldDecl ()
mkField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsEntity]
entities))
deriving_ :: Deriving ()
deriving_ = [InstRule ()] -> Deriving ()
derivingDecl [ forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
forall l. l -> QName l -> InstHead l
Hs.IHCon () forall a b. (a -> b) -> a -> b
$ forall l. l -> Name l -> QName l
Hs.UnQual () forall a b. (a -> b) -> a -> b
$
forall l. l -> String -> Name l
Hs.Ident () String
"Generic" ]
mkField :: HsEntity -> FieldDecl ()
mkField HsEntity
entity = forall l. l -> [Name l] -> Type l -> FieldDecl l
Hs.FieldDecl () [ forall l. l -> String -> Name l
Hs.Ident () (HsEntity -> String
entityDbFieldName HsEntity
entity) ]
(HsDbField -> Type () -> Type ()
buildHsDbField (HsEntity -> HsDbField
hsEntityDbDecl HsEntity
entity) forall a b. (a -> b) -> a -> b
$
forall l. l -> Name l -> Type l
Hs.TyVar () (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 =
forall l. l -> [Name l] -> Type l -> Decl l
Hs.TypeSig () [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 -> forall a. HasCallStack => String -> a
error String
"No backend matches"
HsBeamBackendSingle HsType
ty HsExpr
_ -> ([], HsType -> Type ()
hsTypeSyntax HsType
ty)
HsBeamBackendConstrained [HsBackendConstraint]
cs ->
( forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a. Eq a => [a] -> [a]
nub [Asst ()]
beAssts
migrationType :: Type ()
migrationType
| [] <- [Asst ()]
constraints = Type ()
migrationUnconstrainedType
| [Asst ()
c] <- [Asst ()]
constraints = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall l. l -> Asst l -> Context l
Hs.CxSingle () Asst ()
c)) Type ()
migrationUnconstrainedType
| Bool
otherwise = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (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 =
forall l. l -> [Match l] -> Decl l
Hs.FunBind () [ forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (forall l. l -> String -> Name l
Hs.Ident () String
"migration") [] (forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
body) forall a. Maybe a
Nothing ]
where
body :: Exp ()
body = forall l. l -> [Stmt l] -> Exp l
Hs.Do () (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 -> forall l. l -> Exp l -> Stmt l
Hs.Qualifier () Exp ()
expr'
Just Pat ()
pat' -> forall l. l -> Pat l -> Exp l -> Stmt l
Hs.Generator () Pat ()
pat' Exp ()
expr') [(Maybe (Pat ()), HsExpr)]
migrations forall a. [a] -> [a] -> [a]
++
[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" (forall a b. (a -> b) -> [a] -> [b]
map (\HsEntity
e -> (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 =
forall l. l -> [Name l] -> Type l -> Decl l
Hs.TypeSig () [ 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 = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () (forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) forall a. Maybe a
Nothing Type ()
unconstrainedDbType
| [Asst ()
c] <- [Asst ()]
constraints = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () (forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) (forall a. a -> Maybe a
Just (forall l. l -> Asst l -> Context l
Hs.CxSingle () Asst ()
c)) Type ()
unconstrainedDbType
| Bool
otherwise = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
Hs.TyForall () (forall a. a -> Maybe a
Just [TyVarBind ()]
bindings) (forall a. a -> Maybe a
Just (forall l. l -> [Asst l] -> Context l
Hs.CxTuple () [Asst ()]
constraints)) Type ()
unconstrainedDbType
constraints :: [Asst ()]
constraints = forall a. Eq a => [a] -> [a]
nub [Asst ()]
beAssts
([TyVarBind ()]
bindings, [Asst ()]
beAssts, Type ()
beVar) =
case HsBeamBackend HsExpr
be of
HsBeamBackend HsExpr
HsBeamBackendNone -> forall a. HasCallStack => String -> a
error String
"No backend matches"
HsBeamBackendSingle HsType
ty HsExpr
_ -> (forall a. [a]
standardBindings, [], HsType -> Type ()
hsTypeSyntax HsType
ty)
HsBeamBackendConstrained [HsBackendConstraint]
cs ->
( String -> TyVarBind ()
tyVarBind String
"be"forall a. a -> [a] -> [a]
:forall a. [a]
standardBindings
, forall a b. (a -> b) -> [a] -> [b]
map (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 = forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (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 =
forall l. l -> [Match l] -> Decl l
Hs.FunBind () [ forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (forall l. l -> String -> Name l
Hs.Ident () String
"db") [] (forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
body) forall a. Maybe a
Nothing ]
where
backendVar :: Type ()
backendVar = case HsBeamBackend HsExpr
backend of
HsBeamBackend HsExpr
HsBeamBackendNone -> 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 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) 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 = forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Hs.Module () (forall a. a -> Maybe a
Just ModuleHead ()
modHead) [ModulePragma ()]
modPragmas [ImportDecl ()]
imports [Decl ()]
decls
modHead :: ModuleHead ()
modHead = forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
Hs.ModuleHead () (forall l. l -> String -> ModuleName l
Hs.ModuleName () String
modNm) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just ExportSpecList ()
modExports)
modExports :: ExportSpecList ()
modExports = forall l. l -> [ExportSpec l] -> ExportSpecList l
Hs.ExportSpecList () ([ExportSpec ()]
commonExports forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsDecl -> [ExportSpec ()]
hsDeclExports forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsEntity -> [HsDecl]
hsEntityDecls) [HsEntity]
entities)
commonExports :: [ExportSpec ()]
commonExports = [ forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual String
"db")
, forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual String
"migration")
, forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
Hs.EThingWith () (forall l. l -> Int -> EWildcard l
Hs.EWildcard () Int
0)
(String -> QName ()
unqual String
"Db") [] ]
modPragmas :: [ModulePragma ()]
modPragmas = [ forall l. l -> [Name l] -> ModulePragma l
Hs.LanguagePragma () [ forall l. l -> String -> Name l
Hs.Ident () String
"StandaloneDeriving"
, forall l. l -> String -> Name l
Hs.Ident () String
"GADTs"
, forall l. l -> String -> Name l
Hs.Ident () String
"ScopedTypeVariables"
, forall l. l -> String -> Name l
Hs.Ident () String
"FlexibleContexts"
, forall l. l -> String -> Name l
Hs.Ident () String
"FlexibleInstances"
, forall l. l -> String -> Name l
Hs.Ident () String
"DeriveGeneric"
, forall l. l -> String -> Name l
Hs.Ident () String
"TypeSynonymInstances"
, forall l. l -> String -> Name l
Hs.Ident () String
"ExplicitNamespaces"
, forall l. l -> String -> Name l
Hs.Ident () String
"TypeApplications"
, forall l. l -> String -> Name l
Hs.Ident () String
"TypeFamilies"
, forall l. l -> String -> Name l
Hs.Ident () String
"OverloadedStrings" ] ]
HsImports Map (ModuleName ()) HsImport
importedModules = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\HsEntity
e -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsDecl -> HsImports
hsDeclImports (HsEntity -> [HsDecl]
hsEntityDecls HsEntity
e) forall a. Semigroup a => a -> a -> a
<>
HsExpr -> HsImports
hsExprImports (HsEntity -> HsExpr
hsEntityExp HsEntity
e)) [HsEntity]
entities forall a. Semigroup a => a -> a -> a
<>
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HsExpr -> HsImports
hsExprImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe (Pat ()), HsExpr)]
migrations 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 forall a. Semigroup a => a -> a -> a
<>
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName ()
modName, HsImport
spec) ->
case HsImport
spec of
HsImport
HsImportAll -> 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
HsImportSome Set (ImportSpec ())
nms ->
let importList :: ImportSpecList ()
importList = forall l. l -> Bool -> [ImportSpec l] -> ImportSpecList l
Hs.ImportSpecList () Bool
False (forall a. Set a -> [a]
S.toList Set (ImportSpec ())
nms)
in 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just ImportSpecList ()
importList)
)
(forall k a. Map k a -> [(k, a)]
M.assocs Map (ModuleName ()) HsImport
importedModules)
commonImports :: [ImportDecl ()]
commonImports = [ forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () (forall l. l -> String -> ModuleName l
Hs.ModuleName () String
"Database.Beam") Bool
False Bool
False Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
, forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
Hs.ImportDecl () (forall l. l -> String -> ModuleName l
Hs.ModuleName () String
"Control.Applicative") Bool
False Bool
False Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing ]
backend :: HsBeamBackend HsExpr
backend = 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 -> 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"
decls :: [Decl ()]
decls = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> [a] -> [b]
map HsDecl -> Decl ()
hsDeclSyntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsEntity -> [HsDecl]
hsEntityDecls) [HsEntity]
entities 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 forall a b. b -> Either a b
Right (Doc -> String
render (forall a. Pretty a => a -> Doc
Hs.prettyPrim Module ()
hsMod))
data HsNone = HsNone deriving (Int -> HsNone -> ShowS
[HsNone] -> ShowS
HsNone -> String
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
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
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
Ord, 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
(<>) = 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
[] -> forall a. HasCallStack => String -> a
error String
"No name for table"
Char
x:String
xs -> Char -> Char
toNameCase Char
xforall a. a -> [a] -> [a]
:String
xs
Just Text
schNm ->
case Text -> String
T.unpack Text
schNm of
[] -> forall a. HasCallStack => String -> a
error String
"Empty schema name"
Char
x:String
xs -> Char -> Char
toNameCase Char
xforall a. a -> [a] -> [a]
:String
xs forall a. [a] -> [a] -> [a]
++ String
"_" 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 = forall a. a -> a
id
dropTableCmd :: Sql92DdlCommandDropTableSyntax HsAction -> HsAction
dropTableCmd = forall a. a -> a
id
alterTableCmd :: Sql92DdlCommandAlterTableSyntax HsAction -> HsAction
alterTableCmd = 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
_ = 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 [ (forall a. Maybe a
Nothing, HsExpr
dropTable) ] []
where
dropTable :: HsExpr
dropTable = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"dropTable") [ Text -> HsExpr
hsVar (forall a. IsString a => String -> a
fromString (TableName -> String
hsTableVarName 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 [ ( forall a. a -> Maybe a
Just (forall l. l -> Name l -> Pat l
Hs.PVar () (forall l. l -> String -> Name l
Hs.Ident () String
varName))
, HsExpr
migration ) ]
[ HsEntity
entity ]
where
(String
varName, String
tyName, String
tyConName) =
( TableName -> String
hsTableVarName Sql92CreateTableTableNameSyntax HsAction
nm, TableName -> String
hsTableTypeName Sql92CreateTableTableNameSyntax HsAction
nm forall a. [a] -> [a] -> [a]
++ String
"T", TableName -> String
hsTableTypeName Sql92CreateTableTableNameSyntax HsAction
nm )
mkHsFieldName :: Text -> String
mkHsFieldName Text
fieldNm = String
"_" forall a. [a] -> [a] -> [a]
++ String
varName forall a. [a] -> [a] -> [a]
++
case Text -> String
T.unpack Text
fieldNm of
[] -> forall a. HasCallStack => String -> a
error String
"empty field name"
(Char
x:String
xs) -> Char -> Char
toUpper Char
xforall a. a -> [a] -> [a]
:String
xs
HsTableConstraintDecls [InstDecl ()]
tableInstanceDecls [HsDecl]
constraintDecls = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(HsTableConstraint Text -> HsFieldLookup -> HsTableConstraintDecls
mkConstraint) -> Text -> HsFieldLookup -> HsTableConstraintDecls
mkConstraint (forall a. IsString a => String -> a
fromString String
tyConName) HsFieldLookup
fieldLookup) [Sql92CreateTableTableConstraintSyntax HsAction]
cs
fieldLookup :: HsFieldLookup
fieldLookup = (Text -> Maybe (Text, Type ())) -> HsFieldLookup
HsFieldLookup forall a b. (a -> b) -> a -> b
$ \Text
fieldNm ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
fieldNm', Type ()
ty') -> (forall a. IsString a => String -> a
fromString (Text -> String
mkHsFieldName Text
fieldNm'), Type ()
ty')) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ( (forall a. Eq a => a -> a -> Bool
== Text
fieldNm) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a. IsString a => String -> a
fromString (TableName -> String
hsTableVarName Sql92CreateTableTableNameSyntax HsAction
nm))
, HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsTyCon (forall a. IsString a => String -> a
fromString String
tyConName))
(forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, HsColumnSchema
ty) -> HsColumnSchema -> Text -> HsExpr
mkHsColumnSchema HsColumnSchema
ty Text
fieldNm) [(Text, Sql92CreateTableColumnSchemaSyntax HsAction)]
fields) ]
entity :: HsEntity
entity = HsEntity
{ hsEntityBackend :: HsBeamBackend HsExpr
hsEntityBackend = 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
[ forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
Hs.EThingWith () (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 [ 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 []
] 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 (forall a. IsString a => String -> a
fromString String
varName)
}
imports :: HsImports
imports = 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)]
fields
tblDecl :: Decl ()
tblDecl = DeclHead () -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()
dataDecl DeclHead ()
tblDeclHead [ QualConDecl ()
tblConDecl ] (forall a. a -> Maybe a
Just Deriving ()
deriving_)
tblDeclHead :: DeclHead ()
tblDeclHead = forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
Hs.DHApp () (forall l. l -> Name l -> DeclHead l
Hs.DHead () (forall l. l -> String -> Name l
Hs.Ident () String
tyName))
(forall l. l -> Name l -> TyVarBind l
Hs.UnkindedVar () (forall l. l -> String -> Name l
Hs.Ident () String
"f"))
tblConDecl :: QualConDecl ()
tblConDecl = forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
Hs.RecDecl () (forall l. l -> String -> Name l
Hs.Ident () String
tyConName) [FieldDecl ()]
tyConFieldDecls)
tyConFieldDecls :: [FieldDecl ()]
tyConFieldDecls = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, Type ()
ty) ->
forall l. l -> [Name l] -> Type l -> FieldDecl l
Hs.FieldDecl () [ forall l. l -> String -> Name l
Hs.Ident () (Text -> String
mkHsFieldName Text
fieldNm) ] Type ()
ty) [(Text, Type ())]
tyConFields
tyConFields :: [(Text, Type ())]
tyConFields = 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)]
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 = forall l. l -> DeclHead l -> Type l -> Decl l
Hs.TypeDecl () (forall l. l -> Name l -> DeclHead l
Hs.DHead () (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 forall a b. (a -> b) -> a -> b
$ HsDataType -> HsType
hsDataTypeType Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema
dataType)
where
notNullable :: Bool
notNullable = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
==forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
notNullConstraintSyntax) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsConstraintDefinition -> HsExpr
hsConstraintDefinitionConstraint) [Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema]
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
dataType) ] forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map HsConstraintDefinition -> HsExpr
hsConstraintDefinitionConstraint [Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema]
cs)
instance IsSql92TableConstraintSyntax HsTableConstraint where
primaryKeyConstraintSyntax :: [Text] -> HsTableConstraint
primaryKeyConstraintSyntax [Text]
fields =
(Text -> HsFieldLookup -> HsTableConstraintDecls)
-> HsTableConstraint
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 ] (forall a. a -> Maybe a
Just Deriving ()
primaryKeyDeriving)
tableTypeNm :: Text
tableTypeNm = Text
tblNm forall a. Semigroup a => a -> a -> a
<> Text
"T"
tableTypeKeyNm :: Text
tableTypeKeyNm = Text
tblNm forall a. Semigroup a => a -> a -> a
<> Text
"Key"
([Text]
fieldRecordNames, [Type ()]
fieldTys) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"fieldTys") (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 = forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
Hs.QualConDecl () forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall l. l -> Name l -> [Type l] -> ConDecl l
Hs.ConDecl () (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 = forall l. l -> DeclHead l -> Type l -> Decl l
Hs.TypeDecl () (forall l. l -> Name l -> DeclHead l
Hs.DHead () (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 = forall l. l -> Decl l -> InstDecl l
Hs.InsDecl () (forall l. l -> [Match l] -> Decl l
Hs.FunBind () [forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Hs.Match () (forall l. l -> String -> Name l
Hs.Ident () String
"primaryKey") [] (forall l. l -> Exp l -> Rhs l
Hs.UnGuardedRhs () Exp ()
primaryKeyFunBody) forall a. Maybe a
Nothing])
primaryKeyFunBody :: Exp ()
primaryKeyFunBody = HsExpr -> Exp ()
hsExprSyntax forall a b. (a -> b) -> a -> b
$
HsExpr -> [HsExpr] -> HsExpr
hsApApp (Text -> HsExpr
hsVar Text
tableTypeKeyNm)
(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 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
in [InstDecl ()] -> [HsDecl] -> HsTableConstraintDecls
HsTableConstraintDecls [ InstDecl ()
primaryKeyDataDecl
, InstDecl ()
primaryKeyFunDecl ]
(Decl () -> HsImports -> [ExportSpec ()] -> HsDecl
HsDecl Decl ()
primaryKeyTypeDecl forall a. Monoid a => a
mempty [ forall l. l -> QName l -> ExportSpec l
Hs.EVar () (String -> QName ()
unqual (Text -> String
T.unpack Text
tableTypeKeyNm)) ]forall a. a -> [a] -> [a]
:
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
expr
constraintDefinitionSyntax Maybe Text
_ Sql92ColumnConstraintDefinitionConstraintSyntax
HsConstraintDefinition
_ Maybe
(Sql92ColumnConstraintDefinitionAttributesSyntax
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 HsExpr = HsExpr
type Sql92ExpressionCastTargetSyntax HsExpr = HsDataType
valueE :: Sql92ExpressionValueSyntax HsExpr -> HsExpr
valueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"valueE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
rowE :: [HsExpr] -> HsExpr
rowE = 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") forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
negateE :: HsExpr -> HsExpr
negateE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"negateE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
absE :: HsExpr -> HsExpr
absE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"absE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
charLengthE :: HsExpr -> HsExpr
charLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"charLengthE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
octetLengthE :: HsExpr -> HsExpr
octetLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"octetLengthE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
bitLengthE :: HsExpr -> HsExpr
bitLengthE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"bitLengthE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
lowerE :: HsExpr -> HsExpr
lowerE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"lowerE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
upperE :: HsExpr -> HsExpr
upperE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"upperE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
trimE :: HsExpr -> HsExpr
trimE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"trimE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
existsE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
existsE = forall a. HasCallStack => String -> a
error String
"existsE"
uniqueE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
uniqueE = forall a. HasCallStack => String -> a
error String
"uniqueE"
subqueryE :: Sql92ExpressionSelectSyntax HsExpr -> HsExpr
subqueryE = forall a. HasCallStack => String -> a
error String
"subqueryE"
caseE :: [(HsExpr, HsExpr)] -> HsExpr -> HsExpr
caseE = 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 = forall a. HasCallStack => String -> a
error String
"castE"
extractE :: Sql92ExpressionExtractFieldSyntax HsExpr -> HsExpr -> HsExpr
extractE = forall a. HasCallStack => String -> a
error String
"extractE"
isNullE :: HsExpr -> HsExpr
isNullE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNullE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isNotNullE :: HsExpr -> HsExpr
isNotNullE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotNullE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isTrueE :: HsExpr -> HsExpr
isTrueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isTrueE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isFalseE :: HsExpr -> HsExpr
isFalseE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isFalseE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isNotTrueE :: HsExpr -> HsExpr
isNotTrueE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotTrueE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isNotFalseE :: HsExpr -> HsExpr
isNotFalseE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotFalseE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isUnknownE :: HsExpr -> HsExpr
isUnknownE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isUnknownE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
isNotUnknownE :: HsExpr -> HsExpr
isNotUnknownE = HsExpr -> [HsExpr] -> HsExpr
hsApp (Text -> HsExpr
hsVar Text
"isNotUnknownE") forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
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)
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)
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)
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)
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)
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]
inSelectE :: HsExpr -> Sql92ExpressionSelectSyntax HsExpr -> HsExpr
inSelectE HsExpr
_ Sql92ExpressionSelectSyntax HsExpr
_ = forall a. HasCallStack => String -> a
error String
"inSelectE"
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 = forall a. HasCallStack => String -> a
error String
"checkColumnConstraintSyntax"
primaryKeyColumnConstraintSyntax :: HsExpr
primaryKeyColumnConstraintSyntax = forall a. HasCallStack => String -> a
error String
"primaryKeyColumnConstraintSyntax"
referencesConstraintSyntax :: Text
-> [Text]
-> Maybe (Sql92ColumnConstraintMatchTypeSyntax HsExpr)
-> Maybe (Sql92ColumnConstraintReferentialActionSyntax HsExpr)
-> Maybe (Sql92ColumnConstraintReferentialActionSyntax HsExpr)
-> HsExpr
referencesConstraintSyntax = 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 = 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: " forall a. Semigroup a => a -> a -> a
<> 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") forall a. Monoid a => a
mempty) 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" ])) 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") forall a. Monoid a => a
mempty) 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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt 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" ]))
(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") forall a. Monoid a => a
mempty) forall dataType. IsSql92DataTypeSyntax dataType => dataType
realType
charType :: Maybe Word -> Maybe Text -> HsDataType
charType Maybe Word
_ Just {} = 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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
charType Maybe Word
width forall a. Maybe a
Nothing)
varCharType :: Maybe Word -> Maybe Text -> HsDataType
varCharType Maybe Word
_ Just {} = 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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
varCharType Maybe Word
width 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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt 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" ]))
(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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt 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" ]))
(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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
(Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"SqlBits") forall a. Monoid a => a
mempty)
(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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
width) ])
(Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"SqlBits") forall a. Monoid a => a
mempty)
(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" ])) 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 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timeType Maybe Word
p Bool
False)
timeType Maybe Word
_ Bool
_ = forall a. HasCallStack => String -> a
error String
"timeType"
domainType :: Text -> HsDataType
domainType Text
_ = 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType forall a. Maybe a
Nothing Bool
False)
timestampType Maybe Word
_ Bool
_ = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Word
prec, Maybe Word
dec) -> [HsExpr] -> HsExpr
hsTuple [ forall a. (Integral a, Show a) => a -> HsExpr
hsInt Word
prec, Maybe HsExpr -> HsExpr
hsMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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" ]))
(forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType Maybe (Word, Maybe Word)
precDec)
decimalType :: Maybe (Word, Maybe Word) -> HsDataType
decimalType = 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" ]))
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" ]))
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") forall a. Monoid a => a
mempty)
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, 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 forall a. Semigroup a => a -> a -> a
<> Text -> [ImportSpec ()] -> HsImports
importSome Text
"Data.Vector" [ Text -> ImportSpec ()
importTyNamed Text
"Vector" ]))
(forall dataType.
IsSql99DataTypeSyntax dataType =>
dataType -> Int -> dataType
arrayType BeamSerializedDataType
serialized Int
len)
rowType :: [(Text, HsDataType)] -> HsDataType
rowType [(Text, 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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
prec) ])
(Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Integer") forall a. Monoid a => a
mempty)
(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 (forall a. (Integral a, Show a) => a -> HsExpr
hsInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
prec) ])
(Type () -> HsImports -> HsType
HsType (String -> Type ()
tyConNamed String
"Integer") forall a. Monoid a => a
mempty)
(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" ]))
forall dataType. IsSql2008BigIntDataTypeSyntax dataType => dataType
bigIntType
instance Sql92SerializableDataTypeSyntax HsDataType where
serializeDataType :: HsDataType -> Value
serializeDataType = BeamSerializedDataType -> Value
fromBeamSerializedDataType forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDataType -> BeamSerializedDataType
hsDataTypeSerialized
tyParens :: Hs.Type () -> Hs.Type ()
tyParens :: Type () -> Type ()
tyParens = forall l. l -> Type l -> Type l
Hs.TyParen ()
functionTy :: Hs.Type () -> Hs.Type () -> Hs.Type ()
functionTy :: Type () -> Type () -> Type ()
functionTy = forall l. l -> Type l -> Type l -> Type l
Hs.TyFun ()
tyTuple :: [ Hs.Type () ] -> Hs.Type ()
tyTuple :: [Type ()] -> Type ()
tyTuple = 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (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 = forall l. l -> QName l -> Type l
Hs.TyCon () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () String
nm))
tyVarNamed :: String -> Hs.Type ()
tyVarNamed :: String -> Type ()
tyVarNamed String
nm = forall l. l -> Name l -> Type l
Hs.TyVar () (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 forall a. Semigroup a => a -> a -> a
<> HsExpr -> HsImports
hsExprImports HsExpr
b)
(HsExpr -> [Asst ()]
hsExprConstraints HsExpr
a forall a. Semigroup a => a -> a -> a
<> HsExpr -> [Asst ()]
hsExprConstraints HsExpr
b)
(HsExpr -> Set (Name ())
hsExprTypeVariables HsExpr
a 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 = 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 (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 = forall l. l -> Exp l -> Exp l -> Exp l
Hs.App () (HsExpr -> Exp ()
hsExprSyntax HsExpr
e) (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) = 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 -> 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 -> 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 (forall l. l -> Literal l -> Exp l
Hs.Lit () (forall l. l -> String -> String -> Literal l
Hs.String () String
s String
s)) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Exp () -> Exp () -> Exp ()) -> HsExpr -> HsExpr -> HsExpr
combineHsExpr forall a b. a -> b -> a
const) (Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr Exp ()
e forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, HsExpr)]
fs)
where
e :: Exp ()
e = forall l. l -> QName l -> [FieldUpdate l] -> Exp l
Hs.RecConstr () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))
(forall a b. (a -> b) -> [a] -> [b]
map (\(Text
fieldNm, HsExpr
e') -> forall l. l -> QName l -> Exp l -> FieldUpdate l
Hs.FieldUpdate () (forall l. l -> Name l -> QName l
Hs.UnQual () (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 (forall l. l -> QName l -> Exp l
Hs.Var () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty 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 (forall l. l -> QName l -> Exp l
Hs.Var () (forall l. l -> Name l -> QName l
Hs.UnQual () (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])
forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
hsTyCon :: T.Text -> HsExpr
hsTyCon :: Text -> HsExpr
hsTyCon Text
nm = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (forall l. l -> QName l -> Exp l
Hs.Con () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
nm)))) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
hsInt :: (Integral a, Show a) => a -> HsExpr
hsInt :: forall a. (Integral a, Show a) => a -> HsExpr
hsInt a
i = Exp () -> HsImports -> [Asst ()] -> Set (Name ()) -> HsExpr
HsExpr (forall l. l -> Literal l -> Exp l
Hs.Lit () (forall l. l -> Integer -> String -> Literal l
Hs.Int () (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i) (forall a. Show a => a -> String
show a
i))) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
hsOp :: T.Text -> Hs.QOp ()
hsOp :: Text -> QOp ()
hsOp Text
nm = forall l. l -> QName l -> QOp l
Hs.QVarOp () (forall l. l -> Name l -> QName l
Hs.UnQual () (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 =
forall l.
l
-> Maybe (Overlap l) -> InstRule l -> Maybe [InstDecl l] -> Decl l
Hs.InstDecl () forall a. Maybe a
Nothing (forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing InstHead ()
instHead) forall a b. (a -> b) -> a -> b
$
case [InstDecl ()]
decls of
[] -> forall a. Maybe a
Nothing
[InstDecl ()]
_ -> forall a. a -> Maybe a
Just [InstDecl ()]
decls
where
instHead :: InstHead ()
instHead = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall l. l -> InstHead l -> Type l -> InstHead l
Hs.IHApp ()) (forall l. l -> QName l -> InstHead l
Hs.IHCon () (forall l. l -> Name l -> QName l
Hs.UnQual () (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)
forall l.
l
-> Maybe (DerivStrategy l)
-> Maybe (Overlap l)
-> InstRule l
-> Decl l
Hs.DerivDecl () forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing InstHead ()
instHead)
#else
Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead)
#endif
where
instHead :: InstHead ()
instHead = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall l. l -> InstHead l -> Type l -> InstHead l
Hs.IHApp ()) (forall l. l -> QName l -> InstHead l
Hs.IHCon () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () (Text -> String
T.unpack Text
classNm)))) [Type ()]
params
hsList, hsTuple :: [ HsExpr ] -> HsExpr
hsList :: [HsExpr] -> HsExpr
hsList = 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 (forall l. l -> [Exp l] -> Exp l
Hs.List () []) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
where
addList :: Exp () -> Exp () -> Exp ()
addList (Hs.List () [Exp ()]
ts) Exp ()
t = forall l. l -> [Exp l] -> Exp l
Hs.List () ([Exp ()]
ts forall a. [a] -> [a] -> [a]
++ [Exp ()
t])
addList Exp ()
_ Exp ()
_ = forall a. HasCallStack => String -> a
error String
"addList"
hsTuple :: [HsExpr] -> HsExpr
hsTuple = 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 (forall l. l -> Boxed -> [Exp l] -> Exp l
Hs.Tuple () Boxed
Hs.Boxed []) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
where
addTuple :: Exp () -> Exp () -> Exp ()
addTuple (Hs.Tuple () Boxed
boxed [Exp ()]
ts) Exp ()
t = forall l. l -> Boxed -> [Exp l] -> Exp l
Hs.Tuple () Boxed
boxed ([Exp ()]
ts forall a. [a] -> [a] -> [a]
++ [Exp ()
t])
addTuple Exp ()
_ Exp ()
_ = forall a. HasCallStack => String -> a
error String
"addTuple"
inst :: String -> Hs.InstRule ()
inst :: String -> InstRule ()
inst = forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
Hs.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> QName l -> InstHead l
Hs.IHCon () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Name l -> QName l
Hs.UnQual () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> String -> Name l
Hs.Ident ()
beamMigrateSqlBackend :: HsBackendConstraint
beamMigrateSqlBackend :: HsBackendConstraint
beamMigrateSqlBackend =
(Type () -> Asst ()) -> HsBackendConstraint
HsBackendConstraint forall a b. (a -> b) -> a -> b
$ \Type ()
beTy ->
#if MIN_VERSION_haskell_src_exts(1, 22, 0)
forall l. l -> Type l -> Asst l
Hs.TypeA () (forall l. l -> Type l -> Type l -> Type l
Hs.TyApp () (forall l. l -> QName l -> Type l
Hs.TyCon () (forall l. l -> Name l -> QName l
Hs.UnQual () (forall l. l -> String -> Name l
Hs.Ident () String
"BeamMigrateSqlBackend"))) Type ()
beTy)
#else
Hs.ClassA () (Hs.UnQual () (Hs.Ident () "BeamMigrateSqlBackend")) [ beTy ]
#endif
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