beam-migrate (empty) → 0.2.0.0
raw patch · 23 files changed
+4261/−0 lines, 23 filesdep +aesondep +basedep +beam-coresetup-changed
Dependencies added: aeson, base, beam-core, bytestring, containers, deepseq, dependent-map, dependent-sum, free, ghc-prim, hashable, haskell-src-exts, mtl, parallel, pqueue, pretty, scientific, text, time, unordered-containers, vector
Files
- ChangeLog.md +5/−0
- Database/Beam/Haskell/Syntax.hs +951/−0
- Database/Beam/Migrate.hs +90/−0
- Database/Beam/Migrate/Actions.hs +619/−0
- Database/Beam/Migrate/Backend.hs +165/−0
- Database/Beam/Migrate/Checks.hs +169/−0
- Database/Beam/Migrate/Generics.hs +36/−0
- Database/Beam/Migrate/Generics/Tables.hs +200/−0
- Database/Beam/Migrate/Generics/Types.hs +28/−0
- Database/Beam/Migrate/SQL.hs +22/−0
- Database/Beam/Migrate/SQL/BeamExtensions.hs +34/−0
- Database/Beam/Migrate/SQL/Builder.hs +204/−0
- Database/Beam/Migrate/SQL/SQL92.hs +180/−0
- Database/Beam/Migrate/SQL/Tables.hs +403/−0
- Database/Beam/Migrate/SQL/Types.hs +32/−0
- Database/Beam/Migrate/Serialization.hs +495/−0
- Database/Beam/Migrate/Simple.hs +69/−0
- Database/Beam/Migrate/Types.hs +146/−0
- Database/Beam/Migrate/Types/CheckedEntities.hs +199/−0
- Database/Beam/Migrate/Types/Predicates.hs +100/−0
- LICENSE +8/−0
- Setup.hs +2/−0
- beam-migrate.cabal +104/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for beam-migrate++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ Database/Beam/Haskell/Syntax.hs view
@@ -0,0 +1,951 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Instances that allow us to use Haskell as a backend syntax. This allows us+-- to use migrations defined a la 'Database.Beam.Migrate.SQL' to generate a beam+-- schema.+--+-- Mainly of interest to backends.+--+-- Unfortunately, we define some orphan 'Hashable' instances that aren't defined+-- for us in @haskell-src-exts@.+module Database.Beam.Haskell.Syntax where++import Database.Beam hiding (lookup)+import Database.Beam.Backend.SQL+import Database.Beam.Backend.SQL.Builder+import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.Serialization++import Data.Char (toLower, toUpper)+import Data.Hashable+import Data.List (find, nub)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import qualified Data.Set as S+import Data.String+import qualified Data.Text as T++import qualified Language.Haskell.Exts as Hs++import Text.PrettyPrint (render)++newtype HsDbField = HsDbField { buildHsDbField :: Hs.Type () -> Hs.Type () }++data HsConstraintDefinition+ = HsConstraintDefinition+ { hsConstraintDefinitionConstraint :: HsExpr }+ deriving (Show, Eq, Generic)+instance Hashable HsConstraintDefinition+instance Sql92DisplaySyntax HsConstraintDefinition where+ displaySyntax = show++newtype HsEntityName = HsEntityName { getHsEntityName :: String } deriving (Show, Eq, Ord, IsString)++data HsImport = HsImportAll | HsImportSome (S.Set (Hs.ImportSpec ()))+ deriving (Show, Eq, Generic)+instance Hashable HsImport+instance Monoid HsImport where+ mempty = HsImportSome mempty+ mappend HsImportAll _ = HsImportAll+ mappend _ HsImportAll = HsImportAll+ mappend (HsImportSome a) (HsImportSome b) =+ HsImportSome (a <> b)++importSome :: T.Text -> [ Hs.ImportSpec () ] -> HsImports+importSome modNm names = HsImports (M.singleton (Hs.ModuleName () (T.unpack modNm))+ (HsImportSome (S.fromList names)))++importTyNamed :: T.Text -> Hs.ImportSpec ()+importTyNamed = importVarNamed -- nm = Hs.IAbs () (Hs.TypeNamespace ()) (Hs.Ident () (T.unpack nm))++importVarNamed :: T.Text -> Hs.ImportSpec ()+importVarNamed nm = Hs.IVar () (Hs.Ident () (T.unpack nm))++newtype HsImports = HsImports (M.Map (Hs.ModuleName ()) HsImport)+ deriving (Show, Eq)+instance Hashable HsImports where+ hashWithSalt s (HsImports a) = hashWithSalt s (M.assocs a)+instance Monoid HsImports where+ mempty = HsImports mempty+ mappend (HsImports a) (HsImports b) =+ HsImports (M.unionWith mappend a b)++data HsDataType+ = HsDataType+ { hsDataTypeMigration :: HsExpr+ , hsDataTypeType :: HsType+ , hsDataTypeSerialized :: BeamSerializedDataType+ } deriving (Eq, Show, Generic)+instance Hashable HsDataType where+ hashWithSalt salt (HsDataType mig ty _) = hashWithSalt salt (mig, ty)+instance Sql92DisplaySyntax HsDataType where+ displaySyntax = show++data HsType+ = HsType+ { hsTypeSyntax :: Hs.Type ()+ , hsTypeImports :: HsImports+ } deriving (Show, Eq, Generic)+instance Hashable HsType++data HsExpr+ = HsExpr+ { hsExprSyntax :: Hs.Exp ()+ , hsExprImports :: HsImports+ , hsExprConstraints :: [ Hs.Asst () ]+ , hsExprTypeVariables :: S.Set (Hs.Name ())+ } deriving (Show, Eq, Generic)+instance Hashable HsExpr++data HsColumnSchema+ = HsColumnSchema+ { mkHsColumnSchema :: T.Text -> HsExpr+ , hsColumnSchemaType :: HsType+ }+instance Show HsColumnSchema where+ show (HsColumnSchema mk _) = show (mk "fieldNm")+instance Eq HsColumnSchema where+ HsColumnSchema a aTy == HsColumnSchema b bTy = a "fieldNm" == b "fieldNm" && aTy == bTy+instance Hashable HsColumnSchema where+ hashWithSalt s (HsColumnSchema mk ty) = hashWithSalt s (mk "fieldNm", ty)+instance Sql92DisplaySyntax HsColumnSchema where+ displaySyntax = show++data HsDecl+ = HsDecl+ { hsDeclSyntax :: Hs.Decl ()+ , hsDeclImports :: HsImports+ , hsDeclExports :: [ Hs.ExportSpec () ]+ }++data HsAction+ = HsAction+ { hsSyntaxMigration :: [ (Maybe (Hs.Pat ()), HsExpr) ]+ , hsSyntaxEntities :: [ HsEntity ]+ }++instance Monoid HsAction where+ mempty = HsAction [] []+ mappend (HsAction ma ea) (HsAction mb eb) =+ HsAction (ma <> mb) (ea <> eb)++newtype HsBackendConstraint = HsBackendConstraint { buildHsBackendConstraint :: Hs.Type () -> Hs.Asst () }++data HsBeamBackend f+ = HsBeamBackendSingle HsType f+ | HsBeamBackendConstrained [ HsBackendConstraint ]+ | HsBeamBackendNone++instance Monoid (HsBeamBackend f) where+ mempty = HsBeamBackendConstrained []+ mappend (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _)+ | aTy == bTy = HsBeamBackendSingle aTy aExp+ | otherwise = HsBeamBackendNone+ mappend a@HsBeamBackendSingle {} _ = a+ mappend _ b@HsBeamBackendSingle {} = b+ mappend HsBeamBackendNone _ = HsBeamBackendNone+ mappend _ HsBeamBackendNone = HsBeamBackendNone+ mappend (HsBeamBackendConstrained a) (HsBeamBackendConstrained b) =+ HsBeamBackendConstrained (a <> b)++data HsEntity+ = HsEntity+ { hsEntityBackend :: HsBeamBackend HsExpr+ , hsEntitySyntax :: HsBeamBackend ()++ , hsEntityName :: HsEntityName++ , hsEntityDecls :: [ HsDecl ]+ , hsEntityDbDecl :: HsDbField++ , hsEntityExp :: HsExpr+ }++newtype HsFieldLookup = HsFieldLookup { hsFieldLookup :: T.Text -> Maybe (T.Text, Hs.Type ()) }+newtype HsTableConstraint = HsTableConstraint (T.Text -> HsFieldLookup -> HsTableConstraintDecls)++data HsTableConstraintDecls+ = HsTableConstraintDecls+ { hsTableConstraintInstance :: [ Hs.InstDecl () ]+ , hsTableConstraintDecls :: [ HsDecl ]+ }++instance Monoid HsTableConstraintDecls where+ mempty = HsTableConstraintDecls [] []+ mappend (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) =+ HsTableConstraintDecls (ai <> bi) (ad <> bd)++data HsModule+ = HsModule+ { hsModuleName :: String+ , hsModuleEntities :: [ HsEntity ]+ , hsModuleMigration :: [ (Maybe (Hs.Pat ()), HsExpr) ]+ }++hsActionsToModule :: String -> [ HsAction ] -> HsModule+hsActionsToModule modNm actions =+ let HsAction ms es = mconcat actions+ in HsModule modNm es ms++unqual :: String -> Hs.QName ()+unqual = Hs.UnQual () . Hs.Ident ()++entityDbFieldName :: HsEntity -> String+entityDbFieldName entity = "_" ++ getHsEntityName (hsEntityName entity)++databaseTypeDecl :: [ HsEntity ] -> Hs.Decl ()+databaseTypeDecl entities =+ Hs.DataDecl () (Hs.DataType ()) Nothing+ declHead [ conDecl ]+ (Just deriving_)+ where+ declHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () "Db"))+ (Hs.UnkindedVar () (Hs.Ident () "entity"))+ conDecl = Hs.QualConDecl () Nothing Nothing+ (Hs.RecDecl () (Hs.Ident () "Db") (mkField <$> entities))+ deriving_ = Hs.Deriving () [ Hs.IRule () Nothing Nothing $+ Hs.IHCon () $ Hs.UnQual () $+ Hs.Ident () "Generic" ]++ mkField entity = Hs.FieldDecl () [ Hs.Ident () (entityDbFieldName entity) ]+ (buildHsDbField (hsEntityDbDecl entity) $+ Hs.TyVar () (Hs.Ident () "entity"))++migrationTypeDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> [Hs.Type ()] -> Hs.Decl ()+migrationTypeDecl be syntax inputs =+ Hs.TypeSig () [Hs.Ident () "migration"] migrationType+ where+ (syntaxAssts, syntaxVar) =+ case syntax of+ HsBeamBackendNone -> error "No syntax matches"+ HsBeamBackendSingle ty _ -> ([], hsTypeSyntax ty)+ HsBeamBackendConstrained cs ->+ ( map (flip buildHsBackendConstraint syntaxVar) cs+ , tyVarNamed "syntax" )+ (beAssts, beVar) =+ case be of+ HsBeamBackendNone -> error "No backend matches"+ HsBeamBackendSingle ty _ -> ([], hsTypeSyntax ty)+ HsBeamBackendConstrained cs ->+ ( map (flip buildHsBackendConstraint beVar) cs+ , tyVarNamed "be" )++ resultType = tyApp (tyConNamed "Migration")+ [ syntaxVar+ , tyApp (tyConNamed "CheckedDatabaseSettings")+ [ beVar+ , tyConNamed "Db" ] ]++ migrationUnconstrainedType+ | [] <- inputs = resultType+ | otherwise = functionTy (tyTuple inputs) resultType++ constraints = nub (syntaxAssts ++ beAssts)+ migrationType+ | [] <- constraints = migrationUnconstrainedType+ | [c] <- constraints = Hs.TyForall () Nothing (Just (Hs.CxSingle () c)) migrationUnconstrainedType+ | otherwise = Hs.TyForall () Nothing (Just (Hs.CxTuple () constraints)) migrationUnconstrainedType++migrationDecl :: HsBeamBackend HsExpr -> [Hs.Exp ()] -> [ (Maybe (Hs.Pat ()), HsExpr) ] -> [HsEntity] -> Hs.Decl ()+migrationDecl _ _ migrations entities =+ Hs.FunBind () [ Hs.Match () (Hs.Ident () "migration") [] (Hs.UnGuardedRhs () body) Nothing ]+ where+ body = Hs.Do () (map (\(pat, expr) ->+ let expr' = hsExprSyntax expr+ in case pat of+ Nothing -> Hs.Qualifier () expr'+ Just pat' -> Hs.Generator () pat' expr') migrations +++ [Hs.Qualifier () (hsExprSyntax finalReturn)])++ finalReturn = hsApp (hsVar "pure")+ [ hsRecCon "Db" (map (\e -> (fromString (entityDbFieldName e), hsEntityExp e)) entities) ]++dbTypeDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> Hs.Decl ()+dbTypeDecl be syntax =+ Hs.TypeSig () [ Hs.Ident () "db" ] dbType+ where+ unconstrainedDbType = tyApp (tyConNamed "DatabaseSettings")+ [ beVar, tyConNamed "Db" ]+ dbType+ | [c] <- constraints = Hs.TyForall () (Just bindings) (Just (Hs.CxSingle () c)) unconstrainedDbType+ | otherwise = Hs.TyForall () (Just bindings) (Just (Hs.CxTuple () constraints)) unconstrainedDbType++ constraints = monadBeamConstraint:nub (beAssts ++ syntaxAssts)+ (bindings, beAssts, beVar) =+ case be of+ HsBeamBackendNone -> error "No backend matches"+ HsBeamBackendSingle ty _ -> (standardBindings, [], hsTypeSyntax ty)+ HsBeamBackendConstrained cs ->+ ( tyVarBind "be":standardBindings+ , map (flip buildHsBackendConstraint beVar) cs+ , tyVarNamed "be" )++ (standardBindings, syntaxAssts, syntaxVar) =+ case syntax of+ HsBeamBackendNone -> error "No syntax matches"+ HsBeamBackendSingle ty _ -> ( [tyVarBind "hdl", tyVarBind "m"]+ , []+ , hsTypeSyntax ty )+ HsBeamBackendConstrained cs ->+ ( [tyVarBind "syntax", tyVarBind "hdl", tyVarBind "m"]+ , map (flip buildHsBackendConstraint syntaxVar) cs+ , tyVarNamed "syntax" )++ tyVarBind nm = Hs.UnkindedVar () (Hs.Ident () nm)++ monadBeamConstraint = Hs.ClassA () (Hs.UnQual () (Hs.Ident () "MonadBeam")) [ syntaxVar, beVar, tyVarNamed "hdl", tyVarNamed "m" ]++dbDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> [HsExpr] -> Hs.Decl ()+dbDecl _ syntax params =+ Hs.FunBind () [ Hs.Match () (Hs.Ident () "db") [] (Hs.UnGuardedRhs () body) Nothing ]+ where+ syntaxVar = case syntax of+ HsBeamBackendNone -> error "No syntax matches"+ HsBeamBackendSingle ty _ -> hsTypeSyntax ty+ HsBeamBackendConstrained _ -> tyVarNamed "syntax"++ body = hsExprSyntax $+ hsApp (hsVar "unCheckDatabase")+ [ hsApp (hsVarFrom "runMigrationSilenced" "Database.Beam.Migrate")+ [ hsApp (hsVisibleTyApp (hsVar "migration") syntaxVar) $+ case params of+ [] -> []+ _ -> [ hsTuple params ]+ ] ]++renderHsSchema :: HsModule -> Either String String+renderHsSchema (HsModule modNm entities migrations) =+ let hsMod = Hs.Module () (Just modHead) modPragmas imports decls++ modHead = Hs.ModuleHead () (Hs.ModuleName () modNm) Nothing (Just modExports)+ modExports = Hs.ExportSpecList () (commonExports ++ foldMap (foldMap hsDeclExports . hsEntityDecls) entities)+ commonExports = [ Hs.EVar () (unqual "db")+ , Hs.EVar () (unqual "migration")+ , Hs.EThingWith () (Hs.EWildcard () 0)+ (unqual "Db") [] ]++ modPragmas = [ Hs.LanguagePragma () [ Hs.Ident () "StandaloneDeriving"+ , Hs.Ident () "GADTs"+ , Hs.Ident () "ScopedTypeVariables"+ , Hs.Ident () "FlexibleContexts"+ , Hs.Ident () "FlexibleInstances"+ , Hs.Ident () "DeriveGeneric"+ , Hs.Ident () "TypeSynonymInstances"+ , Hs.Ident () "ExplicitNamespaces "] ]++ HsImports importedModules = foldMap (\e -> foldMap hsDeclImports (hsEntityDecls e) <>+ hsExprImports (hsEntityExp e)) entities <>+ foldMap (hsExprImports . snd) migrations <>+ importSome "Database.Beam.Migrate" [ importTyNamed "CheckedDatabaseSettings", importTyNamed "Migration"+ , importTyNamed "Sql92SaneDdlCommandSyntax"+ , importVarNamed "runMigrationSilenced"+ , importVarNamed "unCheckDatabase" ]+ imports = commonImports <>+ map (\(modName, spec) ->+ case spec of+ HsImportAll -> Hs.ImportDecl () modName False False False Nothing Nothing Nothing+ HsImportSome nms ->+ let importList = Hs.ImportSpecList () False (S.toList nms)+ in Hs.ImportDecl () modName False False False Nothing Nothing (Just importList)+ )+ (M.assocs importedModules)++ commonImports = [ Hs.ImportDecl () (Hs.ModuleName () "Database.Beam") False False False Nothing Nothing Nothing+ , Hs.ImportDecl () (Hs.ModuleName () "Control.Applicative") False False False Nothing Nothing Nothing ]++ backend = foldMap hsEntityBackend entities+ syntax = foldMap hsEntitySyntax entities++ decls = foldMap (map hsDeclSyntax . hsEntityDecls) entities +++ [ databaseTypeDecl entities++ , migrationTypeDecl backend syntax []+ , migrationDecl backend [] migrations entities++ , hsInstance "Database" [ tyConNamed "Db" ] []++ , dbTypeDecl backend syntax+ , dbDecl backend syntax [] ]++ in Right (render (Hs.prettyPrim hsMod))++-- * DDL Syntax definitions++data HsNone = HsNone deriving (Show, Eq, Ord, Generic)+instance Hashable HsNone++instance Monoid HsNone where+ mempty = HsNone+ mappend _ _ = HsNone++instance IsSql92DdlCommandSyntax HsAction where+ type Sql92DdlCommandCreateTableSyntax HsAction = HsAction+ type Sql92DdlCommandAlterTableSyntax HsAction = HsAction+ type Sql92DdlCommandDropTableSyntax HsAction = HsAction++ createTableCmd = id+ dropTableCmd = id+ alterTableCmd = id++instance IsSql92AlterTableSyntax HsAction where+ type Sql92AlterTableAlterTableActionSyntax HsAction = HsNone++ alterTableSyntax _ _ = error "alterTableSyntax"++instance IsSql92AlterTableActionSyntax HsNone where+ type Sql92AlterTableColumnSchemaSyntax HsNone = HsColumnSchema+ type Sql92AlterTableAlterColumnActionSyntax HsNone = HsNone++ alterColumnSyntax _ _ = HsNone+ addColumnSyntax _ _ = HsNone+ dropColumnSyntax _ = HsNone+ renameTableToSyntax _ = HsNone+ renameColumnToSyntax _ _ = HsNone++instance IsSql92AlterColumnActionSyntax HsNone where+ setNullSyntax = HsNone+ setNotNullSyntax = HsNone++instance IsSql92DropTableSyntax HsAction where+ dropTableSyntax nm = HsAction [ (Nothing, dropTable) ] []+ where+ dropTable = hsApp (hsVar "dropTable") [ hsVar ("_" <> nm) ]++instance IsSql92CreateTableSyntax HsAction where+ type Sql92CreateTableOptionsSyntax HsAction = HsNone+ type Sql92CreateTableTableConstraintSyntax HsAction = HsTableConstraint+ type Sql92CreateTableColumnSchemaSyntax HsAction = HsColumnSchema++ createTableSyntax _ nm fields cs =+ HsAction [ ( Just (Hs.PVar () (Hs.Ident () varName))+ , migration ) ]+ [ entity ]+ where+ (varName, tyName, tyConName) =+ case T.unpack nm of+ [] -> error "No name for table"+ x:xs -> let tyName' = toUpper x:xs+ in ( toLower x:xs, tyName' ++ "T", tyName')++ mkHsFieldName fieldNm = "_" ++ varName +++ case T.unpack fieldNm of+ [] -> error "empty field name"+ (x:xs) -> toUpper x:xs++ HsTableConstraintDecls tableInstanceDecls constraintDecls = foldMap (\(HsTableConstraint mkConstraint) -> mkConstraint (fromString tyConName) fieldLookup) cs+ fieldLookup = HsFieldLookup $ \fieldNm ->+ fmap (\(fieldNm', ty') -> (fromString (mkHsFieldName fieldNm'), ty')) $+ find ( (== fieldNm) . fst ) tyConFields++ migration =+ hsApp (hsVarFrom "createTable" "Database.Beam.Migrate")+ [ hsStr nm+ , hsApp (hsTyCon (fromString tyConName))+ (map (\(fieldNm, ty) -> mkHsColumnSchema ty fieldNm) fields) ]+ entity = HsEntity+ { hsEntityBackend = HsBeamBackendConstrained []+ , hsEntitySyntax = HsBeamBackendConstrained [ sql92SaneDdlCommandSyntax ]++ , hsEntityName = HsEntityName varName+ , hsEntityDecls = [ HsDecl tblDecl imports+ [ Hs.EThingWith () (Hs.EWildcard () 0) (unqual tyName) [] ]+ , HsDecl tblBeamable imports []++ , HsDecl tblPun imports [ Hs.EVar () (unqual tyName) ]++ , HsDecl tblShowInstance imports []+ , HsDecl tblEqInstance imports []++ , HsDecl tblInstanceDecl imports []+ ] +++ constraintDecls+ , hsEntityDbDecl = HsDbField (\f -> tyApp f [ tyApp (tyConNamed "TableEntity") [tyConNamed tyName] ])+ , hsEntityExp = hsVar (fromString varName)+ }++ imports = foldMap (\(_, ty) -> hsTypeImports (hsColumnSchemaType ty)) fields++ tblDecl = Hs.DataDecl () (Hs.DataType ()) Nothing+ tblDeclHead [ tblConDecl ] (Just deriving_)+ tblDeclHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () tyName))+ (Hs.UnkindedVar () (Hs.Ident () "f"))+ tblConDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () tyConName) tyConFieldDecls)++ tyConFieldDecls = map (\(fieldNm, ty) ->+ Hs.FieldDecl () [ Hs.Ident () (mkHsFieldName fieldNm) ] ty) tyConFields+ tyConFields = map (\(fieldNm, ty) -> ( fieldNm+ , tyApp (tyConNamed "Columnar")+ [ tyVarNamed "f"+ , hsTypeSyntax (hsColumnSchemaType ty) ])) fields++ deriving_ = Hs.Deriving () [ inst "Generic" ]++ tblBeamable = hsInstance "Beamable" [ tyConNamed tyName ] []+ tblPun = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () tyConName))+ (tyApp (tyConNamed tyName) [ tyConNamed "Identity" ])++ tblEqInstance = hsDerivingInstance "Eq" [ tyConNamed tyConName ]+ tblShowInstance = hsDerivingInstance "Show" [ tyConNamed tyConName]++ tblInstanceDecl = hsInstance "Table" [ tyConNamed tyName ] tableInstanceDecls++instance IsSql92ColumnSchemaSyntax HsColumnSchema where+ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax HsColumnSchema = HsConstraintDefinition+ type Sql92ColumnSchemaColumnTypeSyntax HsColumnSchema = HsDataType+ type Sql92ColumnSchemaExpressionSyntax HsColumnSchema = HsExpr++ columnSchemaSyntax dataType _ cs _ = HsColumnSchema (\nm -> fieldExpr nm)+ (modTy $ hsDataTypeType dataType)+ where+ notNullable = any ((==notNullConstraintSyntax) . hsConstraintDefinitionConstraint) cs+ modTy t = if notNullable then t else t { hsTypeSyntax = tyApp (tyConNamed "Maybe") [ hsTypeSyntax t ] }+ modDataTy e = if notNullable then e else hsApp (hsVarFrom "maybeType" "Database.Beam.Migrate") [e]++ fieldExpr nm = hsApp (hsVarFrom "field" "Database.Beam.Migrate")+ ([ hsStr nm+ , modDataTy (hsDataTypeMigration dataType) ] +++ map hsConstraintDefinitionConstraint cs)++instance IsSql92TableConstraintSyntax HsTableConstraint where+ primaryKeyConstraintSyntax fields =+ HsTableConstraint $ \tblNm tblFields ->+ let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] (Just primaryKeyDeriving)++ tableTypeNm = tblNm <> "T"+ tableTypeKeyNm = tblNm <> "Key"++ (fieldRecordNames, fieldTys) = unzip (fromMaybe (error "fieldTys") (mapM (hsFieldLookup tblFields) fields))++ primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ]+ primaryKeyConDecl = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys)+ primaryKeyDeriving = Hs.Deriving () [ inst "Generic" ]++ primaryKeyTypeDecl = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () (T.unpack tableTypeKeyNm)))+ (tyApp (tyConNamed "PrimaryKey")+ [ tyConNamed (T.unpack tableTypeNm)+ , tyConNamed "Identity" ])++ primaryKeyFunDecl = Hs.InsDecl () (Hs.FunBind () [Hs.Match () (Hs.Ident () "primaryKey") [] (Hs.UnGuardedRhs () primaryKeyFunBody) Nothing])+ primaryKeyFunBody = hsExprSyntax $+ hsApApp (hsVar tableTypeKeyNm)+ (map hsVar fieldRecordNames)++ decl d = HsDecl d mempty mempty++ in HsTableConstraintDecls [ primaryKeyDataDecl+ , primaryKeyFunDecl ]+ (HsDecl primaryKeyTypeDecl mempty [ Hs.EVar () (unqual (T.unpack tableTypeKeyNm)) ]:+ map decl [ hsInstance "Beamable" [ tyParens (tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm) ]) ] []+ , hsDerivingInstance "Eq" [ tyConNamed (T.unpack tableTypeKeyNm) ]+ , hsDerivingInstance "Show" [ tyConNamed (T.unpack tableTypeKeyNm) ]+ ])++instance IsSql92ColumnConstraintDefinitionSyntax HsConstraintDefinition where+ type Sql92ColumnConstraintDefinitionAttributesSyntax HsConstraintDefinition = HsNone+ type Sql92ColumnConstraintDefinitionConstraintSyntax HsConstraintDefinition = HsExpr++ constraintDefinitionSyntax Nothing expr Nothing = HsConstraintDefinition expr+ constraintDefinitionSyntax _ _ _ = error "constraintDefinitionSyntax{HsExpr}"++instance Sql92SerializableConstraintDefinitionSyntax HsConstraintDefinition where+ serializeConstraint _ = "unknown-constrainst"++instance IsSql92MatchTypeSyntax HsNone where+ fullMatchSyntax = HsNone+ partialMatchSyntax = HsNone+instance IsSql92ReferentialActionSyntax HsNone where+ referentialActionCascadeSyntax = HsNone+ referentialActionNoActionSyntax = HsNone+ referentialActionSetDefaultSyntax = HsNone+ referentialActionSetNullSyntax = HsNone++instance IsSql92ExpressionSyntax HsExpr where+ type Sql92ExpressionFieldNameSyntax HsExpr = HsExpr+ type Sql92ExpressionSelectSyntax HsExpr = SqlSyntaxBuilder+ type Sql92ExpressionValueSyntax HsExpr = HsExpr+ type Sql92ExpressionQuantifierSyntax HsExpr = HsExpr+ type Sql92ExpressionExtractFieldSyntax HsExpr = HsExpr+ type Sql92ExpressionCastTargetSyntax HsExpr = HsDataType++ valueE = hsApp (hsVar "valueE") . pure+ rowE = error "rowE"++ currentTimestampE = hsVar "currentTimestampE"+ defaultE = hsVar "defaultE"++ coalesceE = hsApp (hsVar "coalesceE")+ fieldE = hsApp (hsVar "fieldE") . pure++ betweenE a b c = hsApp (hsVar "betweenE") [a, b, c]++ andE a b = hsApp (hsVar "andE") [a, b]+ orE a b = hsApp (hsVar "orE") [a, b]+ addE a b = hsApp (hsVar "addE") [a, b]+ subE a b = hsApp (hsVar "subE") [a, b]+ mulE a b = hsApp (hsVar "mulE") [a, b]+ divE a b = hsApp (hsVar "divE") [a, b]+ modE a b = hsApp (hsVar "modE") [a, b]+ likeE a b = hsApp (hsVar "likeE") [a, b]+ overlapsE a b = hsApp (hsVar "overlapsE") [a, b]+ positionE a b = hsApp (hsVar "positionE") [a, b]++ notE = hsApp (hsVar "notE") . pure+ negateE = hsApp (hsVar "negateE") . pure+ absE = hsApp (hsVar "absE") . pure+ charLengthE = hsApp (hsVar "charLengthE") . pure+ octetLengthE = hsApp (hsVar "octetLengthE") . pure+ bitLengthE = hsApp (hsVar "bitLengthE") . pure++ existsE = error "existsE"+ uniqueE = error "uniqueE"+ subqueryE = error "subqueryE"++ caseE = error "caseE"+ nullIfE a b = hsApp (hsVar "nullIfE") [a, b]++ castE = error "castE"+ extractE = error "extractE"++ isNullE = hsApp (hsVar "isNullE") . pure+ isNotNullE = hsApp (hsVar "isNotNullE") . pure+ isTrueE = hsApp (hsVar "isTrueE") . pure+ isFalseE = hsApp (hsVar "isFalseE") . pure+ isNotTrueE = hsApp (hsVar "isNotTrueE") . pure+ isNotFalseE = hsApp (hsVar "isNotFalseE") . pure+ isUnknownE = hsApp (hsVar "isUnknownE") . pure+ isNotUnknownE = hsApp (hsVar "isNotUnknownE") . pure++ eqE q a b = hsApp (hsVar "eqE") [hsMaybe q, a, b]+ neqE q a b = hsApp (hsVar "neqE") [hsMaybe q, a, b]+ gtE q a b = hsApp (hsVar "gtE") [hsMaybe q, a, b]+ ltE q a b = hsApp (hsVar "ltE") [hsMaybe q, a, b]+ geE q a b = hsApp (hsVar "geE") [hsMaybe q, a, b]+ leE q a b = hsApp (hsVar "leE") [hsMaybe q, a, b]++ inE a b = hsApp (hsVar "inE") [a, hsList b]++instance IsSql92QuantifierSyntax HsExpr where+ quantifyOverAll = hsVar "quantifyOverAll"+ quantifyOverAny = hsVar "quantifyOverAny"++instance IsSql92ColumnConstraintSyntax HsExpr where+ type Sql92ColumnConstraintExpressionSyntax HsExpr = HsExpr+ type Sql92ColumnConstraintMatchTypeSyntax HsExpr = HsNone+ type Sql92ColumnConstraintReferentialActionSyntax HsExpr = HsNone++ notNullConstraintSyntax = hsVarFrom "notNull" "Database.Beam.Migrate"+ uniqueColumnConstraintSyntax = hsVar "unique"+ checkColumnConstraintSyntax = error "checkColumnConstraintSyntax"+ primaryKeyColumnConstraintSyntax = error "primaryKeyColumnConstraintSyntax"+ referencesConstraintSyntax = error "referencesConstraintSyntax"++instance IsSql92ConstraintAttributesSyntax HsNone where+ initiallyDeferredAttributeSyntax = HsNone+ initiallyImmediateAttributeSyntax = HsNone+ notDeferrableAttributeSyntax = HsNone+ deferrableAttributeSyntax = HsNone++instance HasSqlValueSyntax HsExpr Int where+ sqlValueSyntax = hsInt++instance IsSql92FieldNameSyntax HsExpr where+ qualifiedField tbl nm = hsApp (hsVar "qualifiedField") [ hsStr tbl, hsStr nm ]+ unqualifiedField nm = hsApp (hsVar "unqualifiedField") [ hsStr nm ]++hsErrorType :: String -> HsDataType+hsErrorType msg =+ HsDataType (hsApp (hsVar "error") [ hsStr ("Unknown type: " <> fromString msg) ]) (HsType (tyConNamed "Void") (importSome "Data.Void" [ importTyNamed "Void" ]))+ (BeamSerializedDataType "hsErrorType")++instance IsSql92DataTypeSyntax HsDataType where+ intType = HsDataType (hsVarFrom "int" "Database.Beam.Migrate") (HsType (tyConNamed "Int") mempty) intType+ smallIntType = HsDataType (hsVarFrom "smallint" "Database.Beam.Migrate") (HsType (tyConNamed "Int16") (importSome "Data.Int" [ importTyNamed "Int16" ])) intType+ doubleType = HsDataType (hsVarFrom "double" "Database.Beam.Migrate") (HsType (tyConNamed "Double") mempty) doubleType++ floatType width = HsDataType (hsApp (hsVarFrom "float" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "Scientific") (importSome "Data.Scientific" [ importTyNamed "Scientific" ]))+ (floatType width)++ realType = HsDataType (hsVarFrom "real" "Database.Beam.Migrate") (HsType (tyConNamed "Double") mempty) realType++ charType _ Just {} = error "char collation"+ charType width Nothing = HsDataType (hsApp (hsVarFrom "char" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "Text") (importSome "Data.Text" [ importTyNamed "Text" ]))+ (charType width Nothing)++ varCharType _ Just {} = error "varchar collation"+ varCharType width Nothing = HsDataType (hsApp (hsVarFrom "varchar" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "Text") (importSome "Data.Text" [ importTyNamed "Text" ]))+ (varCharType width Nothing)++ nationalCharType width = HsDataType (hsApp (hsVarFrom "nationalChar" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "Text") (importSome "Data.Text" [ importTyNamed "Text" ]))+ (nationalCharType width)++ nationalVarCharType width = HsDataType (hsApp (hsVarFrom "nationalVarchar" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "Text") (importSome "Data.Text" [ importTyNamed "Text" ]))+ (nationalVarCharType width)++ bitType width = HsDataType (hsApp (hsVarFrom "bit" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "SqlBits") mempty)+ (bitType width)++ varBitType width = HsDataType (hsApp (hsVarFrom "varbit" "Database.Beam.Migrate")+ [ hsMaybe (hsInt <$> width) ])+ (HsType (tyConNamed "SqlBits") mempty)+ (varBitType width)++ dateType = HsDataType (hsVarFrom "date" "Database.Beam.Migrate")+ (HsType (tyConNamed "Day") (importSome "Data.Time" [ importTyNamed "Day" ])) dateType++ timeType p False = HsDataType (hsVarFrom "time" "Database.Beam.Migrate")+ (HsType (tyConNamed "TimeOfDay") (importSome "Data.Time" [ importTyNamed "TimeOfDay" ]))+ (timeType p False)+ timeType _ _ = error "timeType"+ domainType _ = error "domainType"+ timestampType Nothing True =+ HsDataType (hsVarFrom "timestamptz" "Database.Beam.Migrate")+ (HsType (tyConNamed "LocalTime") (importSome "Data.Time" [ importTyNamed "LocalTime" ]))+ (timestampType Nothing True)+ timestampType Nothing False =+ HsDataType (hsVarFrom "timestamp" "Database.Beam.Migrate")+ (HsType (tyConNamed "LocalTime") (importSome "Data.Time" [ importTyNamed "LocalTime" ]))+ (timestampType Nothing False)+ timestampType _ _ = error "timestampType with prec"++ numericType precDec =+ HsDataType (hsApp (hsVarFrom "numeric" "Database.Beam.Migrate")+ [ hsMaybe (fmap (\(prec, dec) -> hsTuple [ hsInt prec, hsMaybe (fmap hsInt dec) ]) precDec) ])+ (HsType (tyConNamed "Scientific") (importSome "Data.Scientific" [ importTyNamed "Scientific" ]))+ (numericType precDec)++ decimalType = numericType++instance IsSql99DataTypeSyntax HsDataType where+ characterLargeObjectType =+ HsDataType (hsVarFrom "characterLargeObject" "Database.Beam.Migrate")+ (HsType (tyConNamed "Text") (importSome "Data.Text" [ importTyNamed "Text" ]))+ characterLargeObjectType+ binaryLargeObjectType =+ HsDataType (hsVarFrom "binaryLargeObject" "Database.Beam.Migrate")+ (HsType (tyConNamed "ByteString") (importSome "Data.ByteString" [ importTyNamed "ByteString" ]))+ binaryLargeObjectType+ booleanType =+ HsDataType (hsVarFrom "boolean" "Database.Beam.Migrate")+ (HsType (tyConNamed "Bool") mempty)+ booleanType+ arrayType (HsDataType migType (HsType typeExpr typeImports) serialized) len =+ HsDataType (hsApp (hsVarFrom "array" "Database.Beam.Migrate") [ migType, hsInt len ])+ (HsType (tyApp (tyConNamed "Vector") [typeExpr])+ (typeImports <> importSome "Data.Vector" [ importTyNamed "Vector" ]))+ (arrayType serialized len)+ rowType _ = error "row types"++instance IsSql2003BinaryAndVarBinaryDataTypeSyntax HsDataType where+ binaryType prec =+ HsDataType (hsApp (hsVarFrom "binary" "Database.Beam.Migrate") [ hsMaybe (hsInt <$> prec) ])+ (HsType (tyConNamed "Integer") mempty)+ (binaryType prec)+ varBinaryType prec =+ HsDataType (hsApp (hsVarFrom "varbinary" "Database.Beam.Migrate") [ hsMaybe (hsInt <$> prec) ])+ (HsType (tyConNamed "Integer") mempty)+ (varBinaryType prec)++instance IsSql2008BigIntDataTypeSyntax HsDataType where+ bigIntType =+ HsDataType (hsVarFrom "bigint" "Database.Beam.Migrate")+ (HsType (tyConNamed "Int64") (importSome "Data.Int" [ importTyNamed "Int64" ]))+ bigIntType++instance Sql92SerializableDataTypeSyntax HsDataType where+ serializeDataType = fromBeamSerializedDataType . hsDataTypeSerialized++-- * HsSyntax utilities++tyParens :: Hs.Type () -> Hs.Type ()+tyParens = Hs.TyParen ()++functionTy :: Hs.Type () -> Hs.Type () -> Hs.Type ()+functionTy = Hs.TyFun ()++tyTuple :: [ Hs.Type () ] -> Hs.Type ()+tyTuple = Hs.TyTuple () Hs.Boxed++tyApp :: Hs.Type () -> [ Hs.Type () ]+ -> Hs.Type ()+tyApp fn args = foldl (Hs.TyApp ()) fn args++tyConNamed :: String -> Hs.Type ()+tyConNamed nm = Hs.TyCon () (Hs.UnQual () (Hs.Ident () nm))++tyVarNamed :: String -> Hs.Type ()+tyVarNamed nm = Hs.TyVar () (Hs.Ident () nm)++combineHsExpr :: (Hs.Exp () -> Hs.Exp () -> Hs.Exp ())+ -> HsExpr -> HsExpr -> HsExpr+combineHsExpr f a b =+ HsExpr (f (hsExprSyntax a) (hsExprSyntax b))+ (hsExprImports a <> hsExprImports b)+ (hsExprConstraints a <> hsExprConstraints b)+ (hsExprTypeVariables a <> hsExprTypeVariables b)++hsApp :: HsExpr -> [HsExpr] -> HsExpr+hsApp fn args = foldl hsDoApp fn args+ where+ hsDoApp = combineHsExpr (Hs.App ())++hsVisibleTyApp :: HsExpr -> Hs.Type () -> HsExpr+hsVisibleTyApp e t = e { hsExprSyntax = Hs.App () (hsExprSyntax e) (Hs.TypeApp () t) }++hsApApp :: HsExpr -> [HsExpr] -> HsExpr+hsApApp fn [] = hsApp (hsVar "pure") [ fn ]+hsApApp fn (x:xs) = foldl mkAp (mkFmap fn x) xs+ where+ mkFmap = combineHsExpr (\a b -> Hs.InfixApp () a fmapOp b)+ mkAp = combineHsExpr (\a b -> Hs.InfixApp () a apOp b)++ fmapOp = hsOp "<$>"+ apOp = hsOp "<*>"++hsStr :: T.Text -> HsExpr+hsStr t = HsExpr (Hs.Lit () (Hs.String () s s)) mempty mempty mempty+ where s = T.unpack t++hsRecCon :: T.Text -> [ (T.Text, HsExpr) ] -> HsExpr+hsRecCon nm fs = foldl (combineHsExpr const) (HsExpr e mempty mempty mempty) (map snd fs)+ where+ e = Hs.RecConstr () (Hs.UnQual () (Hs.Ident () (T.unpack nm)))+ (map (\(fieldNm, e') -> Hs.FieldUpdate () (Hs.UnQual () (Hs.Ident () (T.unpack fieldNm)))+ (hsExprSyntax e')) fs)++hsMaybe :: Maybe HsExpr -> HsExpr+hsMaybe Nothing = hsTyCon "Nothing"+hsMaybe (Just e) = hsApp (hsTyCon "Just") [e]++hsVar :: T.Text -> HsExpr+hsVar nm = HsExpr (Hs.Var () (Hs.UnQual () (Hs.Ident () (T.unpack nm)))) mempty mempty mempty++hsVarFrom :: T.Text -> T.Text -> HsExpr+hsVarFrom nm modNm = HsExpr (Hs.Var () (Hs.UnQual () (Hs.Ident () (T.unpack nm)))) (importSome modNm [ importVarNamed nm])+ mempty mempty++hsTyCon :: T.Text -> HsExpr+hsTyCon nm = HsExpr (Hs.Con () (Hs.UnQual () (Hs.Ident () (T.unpack nm)))) mempty mempty mempty++hsInt :: (Integral a, Show a) => a -> HsExpr+hsInt i = HsExpr (Hs.Lit () (Hs.Int () (fromIntegral i) (show i))) mempty mempty mempty++hsOp :: T.Text -> Hs.QOp ()+hsOp nm = Hs.QVarOp () (Hs.UnQual () (Hs.Symbol () (T.unpack nm)))++hsInstance :: T.Text -> [ Hs.Type () ] -> [ Hs.InstDecl () ] -> Hs.Decl ()+hsInstance classNm params decls =+ Hs.InstDecl () Nothing (Hs.IRule () Nothing Nothing instHead) $+ case decls of+ [] -> Nothing+ _ -> Just decls+ where+ instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params++hsDerivingInstance :: T.Text -> [ Hs.Type () ] -> Hs.Decl ()+hsDerivingInstance classNm params = Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead)+ where+ instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params++hsList, hsTuple :: [ HsExpr ] -> HsExpr+hsList = foldl (combineHsExpr addList) (HsExpr (Hs.List () []) mempty mempty mempty)+ where+ addList (Hs.List () ts) t = Hs.List () (ts ++ [t])+ addList _ _ = error "addList"+hsTuple = foldl (combineHsExpr addTuple) (HsExpr (Hs.Tuple () Hs.Boxed []) mempty mempty mempty)+ where+ addTuple (Hs.Tuple () boxed ts) t = Hs.Tuple () boxed (ts ++ [t])+ addTuple _ _ = error "addTuple"++inst :: String -> Hs.InstRule ()+inst = Hs.IRule () Nothing Nothing . Hs.IHCon () . Hs.UnQual () . Hs.Ident ()++sql92SaneDdlCommandSyntax :: HsBackendConstraint+sql92SaneDdlCommandSyntax =+ HsBackendConstraint $ \syntaxTy ->+ Hs.ClassA () (Hs.UnQual () (Hs.Ident () "Sql92SaneDdlCommandSyntax")) [ syntaxTy ]++-- * Orphans++instance Hashable (Hs.Exp ())+instance Hashable (Hs.QName ())+instance Hashable (Hs.ModuleName ())+instance Hashable (Hs.IPName ())+instance Hashable (Hs.Asst ())+instance Hashable (Hs.Literal ())+instance Hashable (Hs.Name ())+instance Hashable (Hs.Type ())+instance Hashable (Hs.QOp ())+instance Hashable (Hs.TyVarBind ())+instance Hashable (Hs.Kind ())+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 ())+instance Hashable a => Hashable (S.Set a) where+ hashWithSalt s a = hashWithSalt s (S.toList a)
+ Database/Beam/Migrate.hs view
@@ -0,0 +1,90 @@+-- | Top-level module import for @beam-migrate@.+--+-- This is most often the only module you want to import, unless you're+-- extending @beam-migrate@, implementing migrations support in a backend, or+-- writing tooling. If you are doing any of these things, please see the+-- Advanced features section below.+--+-- The key abstractions in @beam-migrate@ are the /checked database/ and the+-- /migration/.+--+-- == Checked databases+--+-- A checked database is similar to the 'DatabaseSettings' type from+-- @beam-core@. Whereas a 'DatabaseSettings' object consists of a set of+-- database entities, a checked database (represented by the+-- 'CheckedDatabaseSettings' type) consists of a set of database entities along+-- with a set of /predicates/ (represented by types implementing+-- 'DatabasePredicate').except it comes with a set of /predicates/.The+-- /predicates/ are facts about a given database schema. For example, a checked+-- database with a table named "Customers", would have a 'TableExistsPredicate'+-- in its predicate set.+--+-- Predicates can be used to verify that a given beam schema is compatible with+-- a backend database or to generate migrations from a schema satisfying one set+-- of predicates to a schema satisfying another. Beam migrate provides a solver+-- for figuring out the exact sequence of steps needed to accomplish this. Beam+-- backends can provide additioqnal predicates and solvers to implement+-- backend-specific migrations. For example, the @beam-postgres@ backend+-- provides predicates to assert that extensions have been loaded, and solvers+-- for emitting proper @CREATE EXTENSION@ statements where appropriate.+--+-- Predicates may also be serialized to disk in JSON format, providing an easy+-- means to detect significant changes in a beam schema.+--+-- As one final point, @beam-migrate@ can generate schemas in any beam-supported+-- SQL DDL syntax. The @beam-migrate@ module provides a DDL syntax for Haskell+-- in 'Database.Beam.Haskell.Syntax'. This allows @beam-migrate@ to translate+-- predicate sets into the corresponding Haskell schema and the corresponding+-- Haskell migration script. This reflection allows tool based off of+-- @beam-migrate@ to support schema generation from an existing database.+--+-- For more information on checked databases, see the+-- 'Database.Beam.Migrate.Checks' module.+--+-- == Migrations+--+-- A migration is a value of type 'MigrationSteps a b', where @a@ and @b@ are+-- database types. Conceptually, a value of this type is a list of DDL commands+-- which can be used to bring a database of type @a@ to a database of type @b@.+-- For example, if @b@ is a database type containing all the tables as @a@, but+-- with a new table added, a migration with type 'MigrationSteps a b' may+-- represent a SQL @CREATE TABLE@ statement. Migrations can sometimes be+-- reversed to produce a value of type 'MigrationSteps b a'. In our example, the+-- corresponding reversed migration may be the appropriate @DROP TABLE@+-- statement.+--+-- Migration steps can used to modify a database schema, generate a migration+-- script in a given backend syntax, or generate an appropriate+-- 'DatabaseSettings' object for use with the rest of the beam ecosystem.+--+-- For more information in migrations see 'Database.Beam.Migrate.Types'+--+-- == Syntax+--+-- For low-level access to the underlying SQL syntax builders, see+-- 'Database.Beam.Migrate.Syntax'+--+-- == Advanced features+--+-- If you are writing a new beam backend, you will need to construct a value of+-- type 'BeamBackend'. See that module for more information.+--+-- If you are writing tooling, you will likely need to consume 'BeamBackend'.+-- You will likely also be interested in the migration generation. See the+-- documentation on 'heuristicSolver'.+++module Database.Beam.Migrate+ ( module Database.Beam.Migrate.Actions+ , module Database.Beam.Migrate.Checks+ , module Database.Beam.Migrate.Generics+ , module Database.Beam.Migrate.SQL+ , module Database.Beam.Migrate.Types+ ) where++import Database.Beam.Migrate.Actions+import Database.Beam.Migrate.Checks+import Database.Beam.Migrate.Generics+import Database.Beam.Migrate.SQL+import Database.Beam.Migrate.Types
+ Database/Beam/Migrate/Actions.hs view
@@ -0,0 +1,619 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++-- | Data types and functions to discover sequences of DDL commands to go from+-- one database state to another. Used for migration generation.+--+-- For our purposes, a database state is fully specified by the set of+-- predicates that apply to that database.+--+-- Migration generation is approached as a graph search problem over the+-- infinite graph of databases /G/. The nodes of /G/ are database states, which+-- (as said above) are simply sets of predicates (see 'DatabaseState' for the+-- realization of this concept in code). For two vertices /S1/ and /S2/ in /G/,+-- there is an edge between the two if and only if there is a DDL command that+-- can take a database at /S1/ to /S2/.+--+-- We generate migrations by exploring this graph, starting at the source state+-- and ending at the destination state. By default we use an optimizing solver+-- that weights each edge by the complexity of the particular command, and we+-- attempt to find the shortest path using Dijkstra's algorithm, although a user+-- may override this behavior and provide a custom edge selection mechanism (or+-- even defer this choice to the user).+--+-- In order to conduct the breadth-first search, we must know which edges lead+-- out of whichever vertex we're currently visiting. The solving algorithm thus+-- takes a set of 'ActionProvider's, which are means of discovering edges that+-- are incident to the current database state.+--+-- Conceptually, an 'ActionProvider' is a function of type 'ActionProviderFn',+-- which takes the current database state and produces a list of edges in the+-- form of 'PotentialAction' objects. For optimization purposes,+-- 'ActionProvider's also take in the desired destination state, which it can+-- use to select only edges that make sense. This does not affect the result,+-- just the amount of time it may take to get there.+--+-- Note that because the graph of database states is infinite, a breadth-first+-- search may easily end up continuing to explore when there is no chance of+-- reaching our goal. This would result in non-termination and is highly+-- undesirable. In order to prevent this, we limit ourselves to only exploring+-- edges that take us /closer/ to the destination state. Here, we measure+-- distance between two states as the number of elements in the symmetric+-- difference of two database states. Thus, every action we take must either+-- remove a predicate that doesn't exist in the destination state, or add a+-- predicate that does. If a potential action only adds predicates that do not+-- exist in the final state or removes predicates that do not exist in the+-- first, then we never explore that edge.+--+-- == A note on speed+--+-- There are some issues with this approach. Namely, if there is no solution, we+-- can end up exploring the entire action space, which may be quite a lot. While+-- @beam-migrate@ can solve all databases that can be made up of predicates in+-- this module, other beam backends may not make such strict guarantees+-- (although in practice, all do). Nevertheless, if you're hacking on this+-- module and notice what seems like an infinite loop, you may have accidentally+-- removed code that exposed the edge that leads to a solution to the migration.+--+--+module Database.Beam.Migrate.Actions+ (+ -- * Database state+ DatabaseStateSource(..)+ , DatabaseState(..)++ -- * Action generation+ , PotentialAction(..)++ , ActionProvider(..)+ , ActionProviderFn++ , ensuringNot_+ , justOne_++ , createTableActionProvider+ , dropTableActionProvider+ , addColumnProvider+ , addColumnNullProvider+ , dropColumnNullProvider+ , defaultActionProvider++ -- * Solver+ , Solver(..), FinalSolution(..)+ , finalSolution+ , heuristicSolver+ ) where++import Database.Beam.Migrate.Types+import Database.Beam.Migrate.Checks+import Database.Beam.Migrate.SQL++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies++import Data.Foldable++import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Monoid+import qualified Data.PQueue.Min as PQ+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable++import GHC.Generics++-- | Used to indicate whether a particular predicate is from the initial+-- database state, or due to a sequence of actions we've committed too. Used to+-- prevent runaway action generation based off of derived states.+data DatabaseStateSource+ = DatabaseStateSourceOriginal -- ^ Predicate is from the original set given by the user+ | DatabaseStateSourceDerived -- ^ Predicate is from an action we've committed to in this action chain+ deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData DatabaseStateSource++-- | Represents the state of a database as a migration is being generated+data DatabaseState cmd+ = DatabaseState+ { dbStateCurrentState :: !(HM.HashMap SomeDatabasePredicate DatabaseStateSource)+ -- ^ The current set of predicates that apply to this database as well as+ -- their source (user or from previous actions)+ , dbStateKey :: !(HS.HashSet SomeDatabasePredicate)+ -- ^ HS.fromMap of 'dbStateCurrentState', for maximal sharing+ , dbStateCmdSequence :: !(Seq.Seq cmd)+ -- ^ The current sequence of commands we've committed to in this state+ } deriving Show++instance NFData (DatabaseState cmd) where+ rnf d@DatabaseState {..} = d `seq` ()++-- | Wrapper for 'DatabaseState' that keeps track of the command sequence length+-- and goal distance. Used for sorting states when conducting the search.+data MeasuredDatabaseState cmd+ = MeasuredDatabaseState {-# UNPACK #-} !Int {-# UNPACK #-} !Int (DatabaseState cmd)+ deriving (Show, Generic)+instance NFData (MeasuredDatabaseState cmd)+instance Eq (MeasuredDatabaseState cmd) where+ a == b = measure a == measure b+instance Ord (MeasuredDatabaseState cmd) where+ compare a b = compare (measure a) (measure b)++measure :: MeasuredDatabaseState cmd -> Int+measure (MeasuredDatabaseState cmdLength estGoalDistance _) = cmdLength + 100 * estGoalDistance++measuredDbState :: MeasuredDatabaseState cmd -> DatabaseState cmd+measuredDbState (MeasuredDatabaseState _ _ s) = s++measureDb' :: HS.HashSet SomeDatabasePredicate+ -> HS.HashSet SomeDatabasePredicate+ -> Int+ -> DatabaseState cmd+ -> MeasuredDatabaseState cmd+measureDb' _ post cmdLength st@(DatabaseState _ repr _) =+ MeasuredDatabaseState cmdLength distToGoal st+ where++ distToGoal = HS.size ((repr `HS.difference` post) `HS.union`+ (post `HS.difference` repr))++-- | Represents an edge (or a path) in the database graph.+--+-- Given a particular starting point, the destination database is the database+-- where each predicate in 'actionPreConditions' has been removed and each+-- predicate in 'actionPostConditions' has been added.+--+--+--+data PotentialAction cmd+ = PotentialAction+ { actionPreConditions :: !(HS.HashSet SomeDatabasePredicate)+ -- ^ Preconditions that will no longer apply+ , actionPostConditions :: !(HS.HashSet SomeDatabasePredicate)+ -- ^ Conditions that will apply after we're done+ , actionCommands :: !(Seq.Seq cmd)+ -- ^ The sequence of commands that accomplish this movement in the database+ -- graph. For an edge, 'actionCommands' contains one command; for a path, it+ -- will contain more.+ , actionEnglish :: !Text+ -- ^ An english description of the movement+ , actionScore :: {-# UNPACK #-} !Int+ -- ^ A heuristic notion of complexity or weight; used to find the "easiest"+ -- path through the graph.+ }++-- | 'PotentialAction's can represent edges or paths. Monadically combining two+-- 'PotentialAction's results in the path between the source of the first and+-- the destination of the second. 'mempty' here returns the action that does+-- nothing (i.e., the edge going back to the same database state)+instance Monoid (PotentialAction cmd) where+ mempty = PotentialAction mempty mempty mempty "" 0+ mappend a b =+ PotentialAction (actionPreConditions a <> actionPreConditions b)+ (actionPostConditions a <> actionPostConditions b)+ (actionCommands a <> actionCommands b)+ (if T.null (actionEnglish a) then actionEnglish b+ else if T.null (actionEnglish b) then actionEnglish a+ else actionEnglish a <> "; " <> actionEnglish b)+ (actionScore a + actionScore b)++-- | See 'ActionProvider'+type ActionProviderFn cmd =+ (forall preCondition. Typeable preCondition => [ preCondition ]) {- The list of preconditions -}+ -> (forall postCondition. Typeable postCondition => [ postCondition ]) {- The list of postconditions (used for guiding action selection) -}+ -> [ PotentialAction cmd ] {- A list of actions that we could perform -}++-- | Edge discovery mechanism. A newtype wrapper over 'ActionProviderFn'.+--+-- An 'ActionProviderFn' takes two arguments. The first is the set of predicates+-- that exist in the current database.+--+-- The function should a set of edges from the database specified in the first+-- argument to possible destination databases. For optimization purposes, the+-- second argument is the set of predicates that ought to exist in the+-- destination database. This can be used to eliminate edges that will not lead+-- to a solution.+--+-- This second argument is just an optimization and doesn't change the final+-- result, although it can significantly impact the time it takes to get there.+--+-- Both the current database set and the destination database set are given as+-- polymorphic lists of predicates. When you instantiate the type, the current+-- database predicate set is queried for predicates of that type.+--+-- For example, 'dropTableActionProvider' provides a @DROP TABLE@ action edge+-- whenever it encounters a table that exists. In order to do this, it attempts+-- to find all 'TableExistsPredicate' that do not exist in the destination+-- database. Its 'ActionProviderFn' may be implemented like such:+--+-- > dropTableActionProvider preConditions postConditions = do+-- > TableExistsPredicate srcTblNm <- preConditions+-- > ensuringNot_ $ $+-- > do TableExistsPredicate destTblNm <- postConditions+-- > guard (srcTblNm == destTblNm)+--+-- 'ensuringNot_' is a function that causes the action provider to return no+-- results if there are any elements in the provided list. In this case, it's+-- used to stop @DROP TABLE@ action generation for tables which must be present+-- in the final database.+newtype ActionProvider cmd+ = ActionProvider { getPotentialActions :: ActionProviderFn cmd }++instance Monoid (ActionProvider cmd) where+ mempty = ActionProvider (\_ _ -> [])+ mappend (ActionProvider a) (ActionProvider b) =+ ActionProvider $ \pre post ->+ let aRes = a pre post+ bRes = b pre post++ in withStrategy (rparWith (parList rseq)) aRes `seq`+ withStrategy (rparWith (parList rseq)) bRes `seq`+ aRes ++ bRes++createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int+createTableWeight = 500+dropTableWeight = 100+addColumnWeight = 1+dropColumnWeight = 1++-- | Proceeds only if no predicate matches the given pattern. See the+-- implementation of 'dropTableActionProvider' for an example of usage.+ensuringNot_ :: Alternative m => [ a ] -> m ()+ensuringNot_ [] = pure ()+ensuringNot_ _ = empty++-- | Used to ensure that only one predicate matches the given pattern. See the+-- implementation of 'createTableActionProvider' for an example of usage.+justOne_ :: [ a ] -> [ a ]+justOne_ [x] = [x]+justOne_ _ = []++-- | Action provider for SQL92 @CREATE TABLE@ actions.+createTableActionProvider :: forall cmd+ . ( Sql92SaneDdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => ActionProvider cmd+createTableActionProvider =+ ActionProvider provider+ where+ provider :: ActionProviderFn cmd+ provider findPreConditions findPostConditions =+ do tblP@(TableExistsPredicate postTblNm) <- findPostConditions+ -- Make sure there's no corresponding predicate in the precondition+ ensuringNot_ $+ do TableExistsPredicate preTblNm <- findPreConditions+ guard (preTblNm == postTblNm)++ (columnsP, columns) <- pure . unzip $+ do columnP@+ (TableHasColumn tblNm colNm schema+ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd)) <-+ findPostConditions+ guard (tblNm == postTblNm)++ (constraintsP, constraints) <-+ pure . unzip $ do+ constraintP@+ (TableColumnHasConstraint tblNm' colNm' c+ :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd)) <-+ findPostConditions+ guard (postTblNm == tblNm')+ guard (colNm == colNm')++ pure (p constraintP, c)++ pure (p columnP:constraintsP, (colNm, schema, constraints))+ (primaryKeyP, primaryKey) <- justOne_ $ do+ primaryKeyP@(TableHasPrimaryKey tblNm primaryKey) <-+ findPostConditions+ guard (tblNm == postTblNm)+ pure (primaryKeyP, primaryKey)++ let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP+ cmd = createTableCmd (createTableSyntax Nothing postTblNm colsSyntax tblConstraints)+ tblConstraints = [ primaryKeyConstraintSyntax primaryKey ]+ colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns+ pure (PotentialAction mempty (HS.fromList postConditions) (Seq.singleton cmd) ("Create the table " <> postTblNm) createTableWeight)++-- | Action provider for SQL92 @DROP TABLE@ actions+dropTableActionProvider :: forall cmd+ . ( Sql92SaneDdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => ActionProvider cmd+dropTableActionProvider =+ ActionProvider provider+ where+ -- Look for tables that exist as a precondition but not a post condition+ provider :: ActionProviderFn cmd+ provider findPreConditions findPostConditions =+ do tblP@(TableExistsPredicate preTblNm) <- findPreConditions+ ensuringNot_ $+ do TableExistsPredicate postTblNm <- findPostConditions+ guard (preTblNm == postTblNm)++ relatedPreds <-+ pure $ do p'@(SomeDatabasePredicate pred') <- findPreConditions+ guard (pred' `predicateCascadesDropOn` tblP)+ pure p'++ -- Now, collect all preconditions that may be related to the dropped table+ let cmd = dropTableCmd (dropTableSyntax preTblNm)+ pure ({-trace ("Dropping table " <> show preTblNm <> " would drop " <> show relatedPreds) $ -}+ PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty (Seq.singleton cmd) ("Drop table " <> preTblNm) dropTableWeight)++-- | Action provider for SQL92 @ALTER TABLE ... ADD COLUMN ...@ actions+addColumnProvider :: forall cmd+ . ( Sql92SaneDdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => ActionProvider cmd+addColumnProvider =+ ActionProvider provider+ where+ provider :: ActionProviderFn cmd+ provider findPreConditions findPostConditions =+ do colP@(TableHasColumn tblNm colNm colType :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd))+ <- findPostConditions+ TableExistsPredicate tblNm' <- findPreConditions+ guard (tblNm' == tblNm)+ ensuringNot_ $ do+ TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <-+ findPreConditions+ guard (tblNm'' == tblNm && colNm == colNm') -- This column exists as a different type++ let cmd = alterTableCmd (alterTableSyntax tblNm (addColumnSyntax colNm schema))+ schema = columnSchemaSyntax colType Nothing [] Nothing+ pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP])+ (Seq.singleton cmd)+ ("Add column " <> colNm <> " to " <> tblNm)+ (addColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))++-- | Action provider for SQL92 @ALTER TABLE ... DROP COLUMN ...@ actions+dropColumnProvider :: forall cmd+ . ( Sql92SaneDdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => ActionProvider cmd+dropColumnProvider = ActionProvider provider+ where+ provider :: ActionProviderFn cmd+ provider findPreConditions _ =+ do colP@(TableHasColumn tblNm colNm _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd))+ <- findPreConditions++-- TableExistsPredicate tblNm' <- trace ("COnsider drop " <> show tblNm <> " " <> show colNm) findPreConditions+-- guard (any (\(TableExistsPredicate tblNm') -> tblNm' == tblNm) findPreConditions) --tblNm' == tblNm)+-- ensuringNot_ $ do+-- TableHasColumn tblNm' colNm' colType' :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <-+-- findPostConditions+-- guard (tblNm' == tblNm && colNm == colNm' && colType == colType') -- This column exists as a different type++ relatedPreds <- --pure []+ pure $ do p'@(SomeDatabasePredicate pred') <- findPreConditions+ guard (pred' `predicateCascadesDropOn` colP)+ pure p'++ let cmd = alterTableCmd (alterTableSyntax tblNm (dropColumnSyntax colNm))+ pure (PotentialAction (HS.fromList (SomeDatabasePredicate colP:relatedPreds)) mempty+ (Seq.singleton cmd)+ ("Drop column " <> colNm <> " from " <> tblNm)+ (dropColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))++-- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NULL@+addColumnNullProvider :: forall cmd+ . Sql92SaneDdlCommandSyntax cmd+ => ActionProvider cmd+addColumnNullProvider = ActionProvider provider+ where+ provider :: ActionProviderFn cmd+ provider findPreConditions findPostConditions =+ do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd))+ <- findPostConditions+-- TODO guard (c == notNullConstraintSyntax)++ TableExistsPredicate tblNm' <- findPreConditions+ guard (tblNm == tblNm')++ TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <- findPreConditions+ guard (tblNm == tblNm'' && colNm == colNm')++ let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNotNullSyntax))+ pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP]) (Seq.singleton cmd)+ ("Add not null constraint to " <> colNm <> " on " <> tblNm) 100)++-- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NOT NULL@+dropColumnNullProvider :: forall cmd+ . Sql92SaneDdlCommandSyntax cmd+ => ActionProvider cmd+dropColumnNullProvider = ActionProvider provider+ where+ provider :: ActionProviderFn cmd+ provider findPreConditions _ =+ do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd))+ <- findPreConditions+-- TODO guard (c == notNullConstraintSyntax)++ TableExistsPredicate tblNm' <- findPreConditions+ guard (tblNm == tblNm')++ TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <- findPreConditions+ guard (tblNm == tblNm'' && colNm == colNm')++ let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNullSyntax))+ pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty (Seq.singleton cmd)+ ("Drop not null constraint for " <> colNm <> " on " <> tblNm) 100)++-- | Default action providers for any SQL92 compliant syntax.+--+-- In particular, this provides edges consisting of the following statements:+--+-- * CREATE TABLE+-- * DROP TABLE+-- * ALTER TABLE ... ADD COLUMN ...+-- * ALTER TABLE ... DROP COLUMN ...+-- * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL+defaultActionProvider :: ( Sql92SaneDdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => ActionProvider cmd+defaultActionProvider =+ mconcat+ [ createTableActionProvider+ , dropTableActionProvider++ , addColumnProvider+ , dropColumnProvider++ , addColumnNullProvider+ , dropColumnNullProvider ]++-- | Represents current state of a database graph search.+--+-- If 'ProvideSolution', the destination database has been reached, and the+-- given list of commands provides the path from the source database to the+-- destination.+--+-- If 'SearchFailed', the search has failed. The provided 'DatabaseState's+-- represent the closest we could make it to the destination database. By+-- default, only the best 10 are kept around (to avoid unbounded memory growth).+--+-- If 'ChooseActions', we are still searching. The caller is provided with the+-- current state as well as a list of actions, provided as an opaque type @f@.+-- The 'getPotentialActionChoice' function can be used to get the+-- 'PotentialAction' corresponding to any given @f@. The caller is free to cull+-- the set of potential actions according however they'd like (for example, by+-- prompting the user). The selected actions to explore should be passed to the+-- 'continueSearch' function.+--+-- Use of the @f@ existential type may seem obtuse, but it prevents the caller+-- from injecting arbitrary actions. Instead the caller is limited to choosing+-- only valid actions as provided by the suppled 'ActionProvider'.+data Solver cmd where+ ProvideSolution :: [cmd] -> Solver cmd+ SearchFailed :: [ DatabaseState cmd ] -> Solver cmd+ ChooseActions :: { choosingActionsAtState :: !(DatabaseState cmd)+ -- ^ The current node we're searching at+ , getPotentialActionChoice :: f -> PotentialAction cmd+ -- ^ Convert the opaque @f@ type to a 'PotentialAction'.+ -- This can be used to present the actions to the user or+ -- to inspect the action to make a more informed choice+ -- on exploration strategies.+ , potentialActionChoices :: [ f ]+ -- ^ The possible actions that we can take, presented as+ -- an opaque list. Use the 'getPotentialActionChoice'+ -- function to get the corresponding 'PotentialAction'.+ , continueSearch :: [ f ] -> Solver cmd+ -- ^ Continue the search and get the next 'Solver'+ } -> Solver cmd++-- | Represents the final results of a search+data FinalSolution cmd+ = Solved [ cmd ]+ -- ^ The search found a path from the source to the destination database,+ -- and has provided a set of commands that would work+ | Candidates [ DatabaseState cmd ]+ -- ^ The search failed, but provided a set of 'DatbaseState's it encountered+ -- that were the closest to the destination database. By default, only 10+ -- candidates are provided.+ deriving Show++-- | Returns 'True' if the state has been solved+solvedState :: HS.HashSet SomeDatabasePredicate -> DatabaseState cmd -> Bool+solvedState goal (DatabaseState _ cur _) = goal == cur++-- | An exhaustive solving strategy that simply continues the search, while+-- exploring every possible action. If there is a solution, this will find it.+finalSolution :: Solver cmd -> FinalSolution cmd+finalSolution (SearchFailed sts) = Candidates sts+finalSolution (ProvideSolution cmds) = Solved cmds+finalSolution (ChooseActions _ _ actions next) =+ finalSolution (next actions)++{-# INLINE heuristicSolver #-}+-- | Conduct a breadth-first search of the database graph to find a path from+-- the source database to the destination database, using the given+-- 'ActionProvider' to discovere "edges" (i.e., DDL commands) between the+-- databases.+--+-- See the documentation on 'Solver' for more information on how to consume the+-- result.+heuristicSolver :: ActionProvider cmd -- ^ Edge discovery function+ -> [ SomeDatabasePredicate ] -- ^ Source database state+ -> [ SomeDatabasePredicate ] -- ^ Destination database state+ -> Solver cmd+heuristicSolver provider preConditionsL postConditionsL =++ heuristicSolver' initQueue mempty PQ.empty++ where+ -- Number of failed action chains to keep+ rejectedCount = 10++ postConditions = HS.fromList postConditionsL+ preConditions = HS.fromList preConditionsL+ allToFalsify = preConditions `HS.difference` postConditions+ measureDb = measureDb' allToFalsify postConditions++ initQueue = PQ.singleton (measureDb 0 initDbState)+ initDbState = DatabaseState (DatabaseStateSourceOriginal <$ HS.toMap preConditions)+ preConditions+ mempty++ findPredicate :: forall predicate. Typeable predicate+ => SomeDatabasePredicate+ -> [ predicate ] -> [ predicate ]+ findPredicate+ | Just (Refl :: predicate :~: SomeDatabasePredicate) <- eqT =+ (:)+ | otherwise =+ \(SomeDatabasePredicate pred') ps ->+ maybe ps (:ps) (cast pred')++ findPredicates :: forall predicate f. (Typeable predicate, Foldable f)+ => f SomeDatabasePredicate -> [ predicate ]+ findPredicates = foldr findPredicate []++ heuristicSolver' !q !visited !bestRejected =+ case PQ.minView q of+ Nothing -> SearchFailed (measuredDbState <$> PQ.toList bestRejected)+ Just (mdbState@(MeasuredDatabaseState _ _ dbState), q')+ | dbStateKey dbState `HS.member` visited -> heuristicSolver' q' visited bestRejected+ | solvedState postConditions (measuredDbState mdbState) ->+ ProvideSolution (toList (dbStateCmdSequence dbState))+ | otherwise ->+ let steps = getPotentialActions+ provider+ (findPredicates (dbStateKey dbState))+ (findPredicates postConditionsL)++ steps' = filter (not . (`HS.member` visited) . dbStateKey . measuredDbState . snd) $+ withStrategy (parList rseq) $+ map (\step -> let dbState' = applyStep step mdbState+ in dbState' `seq` (step, dbState')) steps++ applyStep step (MeasuredDatabaseState score _ dbState') =+ let dbState'' = dbStateAfterAction dbState' step+ in measureDb (score + 1) dbState''++ in case steps' of+ -- Since no steps were generated, this is a dead end. Add to the rejected queue+ [] -> heuristicSolver' q' visited (reject mdbState bestRejected)+ _ -> ChooseActions dbState fst steps' $ \chosenSteps ->+ let q'' = foldr (\(_, dbState') -> PQ.insert dbState') q' chosenSteps+ visited' = HS.insert (dbStateKey dbState) visited+ in withStrategy (rparWith rseq) q'' `seq` heuristicSolver' q'' visited' bestRejected++ reject :: MeasuredDatabaseState cmd -> PQ.MinQueue (MeasuredDatabaseState cmd)+ -> PQ.MinQueue (MeasuredDatabaseState cmd)+ reject mdbState q =+ let q' = PQ.insert mdbState q+ in PQ.fromAscList (PQ.take rejectedCount q')++ dbStateAfterAction (DatabaseState curState _ cmds) action =+ let curState' = ((curState `HM.difference` HS.toMap (actionPreConditions action))+ `HM.union` (DatabaseStateSourceDerived <$ HS.toMap (actionPostConditions action)))+ in DatabaseState curState' (HS.fromMap (() <$ curState'))+ (cmds <> actionCommands action)
+ Database/Beam/Migrate/Backend.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Definitions of interest to those implement a new beam backend.+--+-- Steps to defining a beam backend:+--+-- 1. Ensure the command syntax for your backend satisfies 'Sql92SaneDdlCommandSyntax'.+-- 2. Create a value of type 'BeamMigrationBackend'+-- 3. For compatibility with @beam-migrate-cli@, export this value in an+-- exposed module with the name 'migrationBackend'.+--+-- This may sound trivial, but it's a bit more involved. In particular, in order+-- to complete step 2, you will have to define several instances for some of+-- your syntax pieces (for example, data types and constraints will need to be+-- 'Hashable'). You will also need to provide a reasonable function to fetch+-- predicates from your database, and a function to convert all these predicates+-- to corresponding predicates in the Haskell syntax. If you have custom data+-- types or predicates, you will need to supply 'BeamDeserializers' to+-- deserialize them from JSON. Finally, if your backend has custom+-- 'DatabasePredicate's you will have to provide appropriate 'ActionProvider's+-- to discover potential actions for your backend. See the documentation for+-- 'Database.Beam.Migrate.Actions' for more information.+--+-- Tools may be interested in the 'SomeBeamMigrationBackend' data type which+-- provides a monomorphic type to wrap the polymorphic 'BeamMigrationBackend'+-- type. Currently, @beam-migrate-cli@ uses this type to get the underlying+-- 'BeamMigrationBackend' via the @hint@ package.+--+-- For an example migrate backend, see 'Database.Beam.Sqlite.Migrates'+module Database.Beam.Migrate.Backend+ ( BeamMigrationBackend(..)+ , DdlError++ -- * Haskell predicate conversion+ , HaskellPredicateConverter(..)+ , sql92HsPredicateConverters+ , hasColumnConverter+ , trivialHsConverter, hsPredicateConverter++ -- * For tooling authors+ , SomeBeamMigrationBackend(..) )+where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Migrate.Actions+import Database.Beam.Migrate.Checks+import Database.Beam.Migrate.Serialization+import Database.Beam.Migrate.SQL+import Database.Beam.Migrate.Types+ ( SomeDatabasePredicate(..), MigrationSteps )++import Database.Beam.Haskell.Syntax++import Control.Applicative+++import qualified Data.ByteString.Lazy as BL+import Data.Monoid+import Data.Text (Text)+import Data.Time++import Data.Typeable++-- | Type of errors that can be thrown by backends during DDL statement+-- execution. Currently just a synonym for 'String'+type DdlError = String++-- | Backends should create a value of this type and export it in an exposed+-- module under the name 'migrationBackend'. See the module documentation for+-- more details.+data BeamMigrationBackend be commandSyntax hdl where+ BeamMigrationBackend ::+ ( MonadBeam commandSyntax be hdl m+ , Typeable be+ , HasQBuilder (Sql92SelectSyntax commandSyntax)+ , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) LocalTime+ , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) (Maybe LocalTime)+ , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) Text+ , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) SqlNull+ , IsSql92Syntax commandSyntax+ , Sql92SanityCheck commandSyntax, Sql92SaneDdlCommandSyntax commandSyntax+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax commandSyntax)+ , Sql92ReasonableMarshaller be ) =>+ { backendName :: String+ , backendConnStringExplanation :: String+ , backendRenderSteps :: forall a. MigrationSteps commandSyntax () a -> BL.ByteString+ , backendGetDbConstraints :: m [ SomeDatabasePredicate ]+ , backendPredicateParsers :: BeamDeserializers commandSyntax+ , backendRenderSyntax :: commandSyntax -> String+ , backendFileExtension :: String+ , backendConvertToHaskell :: HaskellPredicateConverter+ , backendActionProvider :: ActionProvider commandSyntax+ , backendTransact :: forall a. String -> m a -> IO (Either DdlError a)+ } -> BeamMigrationBackend be commandSyntax hdl++-- | Monomorphic wrapper for use with plugin loaders that cannot handle+-- polymorphism+data SomeBeamMigrationBackend where+ SomeBeamMigrationBackend :: ( Typeable commandSyntax+ , IsSql92DdlCommandSyntax commandSyntax+ , IsSql92Syntax commandSyntax+ , Sql92SanityCheck commandSyntax ) =>+ BeamMigrationBackend be commandSyntax hdl+ -> SomeBeamMigrationBackend++-- | In order to support Haskell schema generation, backends need to provide a+-- way to convert arbitrary 'DatabasePredicate's generated by the backend's+-- 'backendGetDbConstraints' function into appropriate predicates in the Haskell+-- syntax. Not all predicates have any meaning when translated to Haskell, so+-- backends can choose to drop any predicate (simply return 'Nothing').+newtype HaskellPredicateConverter+ = HaskellPredicateConverter (SomeDatabasePredicate -> Maybe SomeDatabasePredicate)++-- | 'HaskellPredicateConverter's can be combined monoidally.+instance Monoid HaskellPredicateConverter where+ mempty = HaskellPredicateConverter $ \_ -> Nothing+ mappend (HaskellPredicateConverter a) (HaskellPredicateConverter b) =+ HaskellPredicateConverter $ \r -> a r <|> b r++-- | Converters for the 'TableExistsPredicate', 'TableHasPrimaryKey', and+-- 'TableHasColumn' (when supplied with a function to convert a backend data+-- type to a haskell one).+sql92HsPredicateConverters :: forall columnSchemaSyntax+ . Typeable columnSchemaSyntax+ => (Sql92ColumnSchemaColumnTypeSyntax columnSchemaSyntax -> Maybe HsDataType)+ -> HaskellPredicateConverter+sql92HsPredicateConverters convType =+ trivialHsConverter @TableExistsPredicate <>+ trivialHsConverter @TableHasPrimaryKey <>+ hasColumnConverter @columnSchemaSyntax convType++-- | Converter for 'TableHasColumn', when given a function to convert backend+-- data type to a haskell one.+hasColumnConverter :: forall columnSchemaSyntax+ . Typeable columnSchemaSyntax+ => (Sql92ColumnSchemaColumnTypeSyntax columnSchemaSyntax -> Maybe HsDataType)+ -> HaskellPredicateConverter+hasColumnConverter convType =+ hsPredicateConverter $+ \(TableHasColumn tbl col ty :: TableHasColumn columnSchemaSyntax) ->+ fmap SomeDatabasePredicate (TableHasColumn tbl col <$> convType ty :: Maybe (TableHasColumn HsColumnSchema))++-- | Some predicates have no dependence on a backend. For example, 'TableExistsPredicate' has no parameters that+-- depend on the backend. It can be converted straightforwardly:+--+-- @+-- trivialHsConverter @TableExistsPredicate+-- @+trivialHsConverter :: forall pred. Typeable pred => HaskellPredicateConverter+trivialHsConverter =+ HaskellPredicateConverter $ \orig@(SomeDatabasePredicate p') ->+ case cast p' of+ Nothing -> Nothing+ Just (_ :: pred) -> Just orig++-- | Utility function for converting a monomorphically typed predicate to a+-- haskell one.+hsPredicateConverter :: Typeable pred => (pred -> Maybe SomeDatabasePredicate) -> HaskellPredicateConverter+hsPredicateConverter f =+ HaskellPredicateConverter $ \(SomeDatabasePredicate p') ->+ case cast p' of+ Nothing -> Nothing+ Just p'' -> f p''+
+ Database/Beam/Migrate/Checks.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Defines common 'DatabasePredicate's that are shared among backends+module Database.Beam.Migrate.Checks where++import Database.Beam.Migrate.Serialization+import Database.Beam.Migrate.Types.Predicates+import Database.Beam.Migrate.SQL.SQL92++import Data.Aeson ((.:), (.=), withObject, object)+import Data.Aeson.Types (Parser, Value)+import Data.Hashable (Hashable(..))+import Data.Text (Text)+import Data.Monoid ((<>))+import Data.Typeable (Typeable, cast)++import GHC.Generics (Generic)+++-- * Table checks++-- | Asserts that a table with the given name exists in a database+data TableExistsPredicate = TableExistsPredicate Text {-^ Table name -}+ deriving (Show, Eq, Ord, Typeable, Generic)+instance Hashable TableExistsPredicate+instance DatabasePredicate TableExistsPredicate where+ englishDescription (TableExistsPredicate t) =+ "Table " <> show t <> " must exist"++ serializePredicate (TableExistsPredicate t) =+ object [ "table-exists" .= t ]++ predicateSpecificity _ = PredicateSpecificityAllBackends++-- | Asserts that the table specified has a column with the given data type. The+-- type paramater @syntax@ should be an instance of 'IsSql92ColumnSchemaSyntax'.+data TableHasColumn syntax where+ TableHasColumn+ :: Typeable (Sql92ColumnSchemaColumnTypeSyntax syntax)+ => { hasColumn_table :: Text {-^ Table name -}+ , hasColumn_column :: Text {-^ Column name -}+ , hasColumn_type :: Sql92ColumnSchemaColumnTypeSyntax syntax {-^ Data type -}+ }+ -> TableHasColumn syntax+instance Hashable (Sql92ColumnSchemaColumnTypeSyntax syntax) => Hashable (TableHasColumn syntax) where+ hashWithSalt salt (TableHasColumn t c s) = hashWithSalt salt (t, c, s)+instance Eq (Sql92ColumnSchemaColumnTypeSyntax syntax) => Eq (TableHasColumn syntax) where+ TableHasColumn aTbl aCol aDt == TableHasColumn bTbl bCol bDt =+ aTbl == bTbl && aCol == bCol && aDt == bDt+instance ( Typeable syntax+ , Sql92SerializableDataTypeSyntax (Sql92ColumnSchemaColumnTypeSyntax syntax)+ , Hashable (Sql92ColumnSchemaColumnTypeSyntax syntax)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnTypeSyntax syntax)+ , Eq (Sql92ColumnSchemaColumnTypeSyntax syntax) ) =>+ DatabasePredicate (TableHasColumn syntax) where+ englishDescription (TableHasColumn tbl col type_) =+ "Table " <> show tbl <> " must have a column " <> show col <> " of " <> displaySyntax type_++ predicateSpecificity _ = PredicateSpecificityAllBackends++ serializePredicate (TableHasColumn tbl col type_) =+ object [ "has-column" .= object [ "table" .= tbl, "column" .= col+ , "type" .= serializeDataType type_ ]]++ predicateCascadesDropOn (TableHasColumn tblNm _ _) p'+ | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm+ | otherwise = False++-- | Asserts that a particular column of a table has a given constraint. The+-- @syntax@ type parameter should be an instance of 'IsSql92ColumnSchemaSyntax'+data TableColumnHasConstraint syntax+ = TableColumnHasConstraint+ { hasConstraint_table :: Text {-^ Table name -}+ , hasConstraint_column :: Text {-^ Column name -}+ , hasConstraint_defn :: Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax {-^ Constraint definition -}+ } deriving Generic+instance Hashable (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) => Hashable (TableColumnHasConstraint syntax)+deriving instance Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) => Eq (TableColumnHasConstraint syntax)+instance ( Typeable syntax+ , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+ , Hashable (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+ , Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) ) =>+ DatabasePredicate (TableColumnHasConstraint syntax) where+ englishDescription (TableColumnHasConstraint tbl col cns) =+ "Column " <> show tbl <> "." <> show col <> " has constraint " <> displaySyntax cns++ predicateSpecificity _ = PredicateSpecificityAllBackends+ serializePredicate (TableColumnHasConstraint tbl col cns) =+ object [ "has-column-constraint" .= object [ "table" .= tbl, "column" .= col+ , "constraint" .= serializeConstraint cns ] ]++ predicateCascadesDropOn (TableColumnHasConstraint tblNm colNm _) p'+ | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm+ | Just (TableHasColumn tblNm' colNm' _ :: TableHasColumn syntax) <- cast p' = tblNm' == tblNm && colNm' == colNm+ | otherwise = False++-- | Asserts that the given table has a primary key made of the given columns.+-- The order of the columns is significant.+data TableHasPrimaryKey+ = TableHasPrimaryKey+ { hasPrimaryKey_table :: Text {-^ Table name -}+ , hasPrimaryKey_cols :: [Text] {-^ Column names -}+ } deriving (Show, Eq, Generic)+instance Hashable TableHasPrimaryKey+instance DatabasePredicate TableHasPrimaryKey where+ englishDescription (TableHasPrimaryKey tblName colNames) =+ "Table " <> show tblName <> " has primary key " <> show colNames++ predicateSpecificity _ = PredicateSpecificityAllBackends++ serializePredicate (TableHasPrimaryKey tbl cols) =+ object [ "has-primary-key" .= object [ "table" .= tbl+ , "columns" .= cols ] ]++ predicateCascadesDropOn (TableHasPrimaryKey tblNm _) p'+ | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm+ | otherwise = False++-- * Deserialization++-- | 'BeamDeserializers' for all the predicates defined in this module+beamCheckDeserializers+ :: forall cmd+ . ( IsSql92DdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+ , Sql92SerializableConstraintDefinitionSyntax (Sql92DdlCommandConstraintDefinitionSyntax cmd) )+ => BeamDeserializers cmd+beamCheckDeserializers = mconcat+ [ beamDeserializer (const deserializeTableExistsPredicate)+ , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate)+ , beamDeserializer deserializeTableHasColumnPredicate+ , beamDeserializer deserializeTableColumnHasConstraintPredicate+ ]+ where+ deserializeTableExistsPredicate :: Value -> Parser SomeDatabasePredicate+ deserializeTableExistsPredicate =+ withObject "TableExistPredicate" $ \v ->+ SomeDatabasePredicate <$> (TableExistsPredicate <$> v .: "table-exists")++ deserializeTableHasPrimaryKeyPredicate :: Value -> Parser SomeDatabasePredicate+ deserializeTableHasPrimaryKeyPredicate =+ withObject "TableHasPrimaryKey" $ \v ->+ v .: "has-primary-key" >>=+ (withObject "TableHasPrimaryKey" $ \v' ->+ SomeDatabasePredicate <$> (TableHasPrimaryKey <$> v' .: "table" <*> v' .: "columns"))++ deserializeTableHasColumnPredicate :: BeamDeserializers cmd'+ -> Value -> Parser SomeDatabasePredicate+ deserializeTableHasColumnPredicate d =+ withObject "TableHasColumn" $ \v ->+ v .: "has-column" >>=+ (withObject "TableHasColumn" $ \v' ->+ SomeDatabasePredicate <$>+ fmap (id @(TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd)))+ (TableHasColumn <$> v' .: "table" <*> v' .: "column"+ <*> (beamDeserialize d =<< v' .: "type")))++ deserializeTableColumnHasConstraintPredicate :: BeamDeserializers cmd'+ -> Value -> Parser SomeDatabasePredicate+ deserializeTableColumnHasConstraintPredicate d =+ withObject "TableColumnHasConstraint" $ \v ->+ v .: "has-column-constraint" >>=+ (withObject "TableColumnHasConstraint" $ \v' ->+ SomeDatabasePredicate <$>+ fmap (id @(TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd)))+ (TableColumnHasConstraint <$> v' .: "table" <*> v' .: "column"+ <*> (beamDeserialize d =<< v' .: "constraint")))
+ Database/Beam/Migrate/Generics.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Support for creating checked databases from Haskell ADTs, using 'Generic's.+--+-- For more information, see+-- <http://tathougies.github.io/beam/schema-guide/migrations/ the manual>++module Database.Beam.Migrate.Generics+ ( -- * Default checked database settings+ defaultMigratableDbSettings++ -- * Extending the defaulting sytem+ , HasDefaultSqlDataType(..), HasDefaultSqlDataTypeConstraints(..)+ , Sql92HasDefaultDataType+ ) where++import Database.Beam.Migrate.Types+import Database.Beam.Migrate.Generics.Tables+import Database.Beam.Migrate.Generics.Types++import Data.Proxy++import GHC.Generics++-- | Produce a checked database for the given Haskell database type+--+-- See <http://tathougies.github.io/beam/schema-guide/migrations/ the manual>+-- for more information on the defaults.+defaultMigratableDbSettings+ :: forall syntax be db.+ ( Generic (CheckedDatabaseSettings be db)+ , GAutoMigratableDb syntax (Rep (CheckedDatabaseSettings be db)) )+ => CheckedDatabaseSettings be db+defaultMigratableDbSettings =+ to (defaultMigratableDbSettings' (Proxy @syntax) :: Rep (CheckedDatabaseSettings be db) ())+
+ Database/Beam/Migrate/Generics/Tables.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Support for defaulting checked tables+module Database.Beam.Migrate.Generics.Tables+ ( -- * Field data type defaulting+ HasDefaultSqlDataType(..)+ , HasDefaultSqlDataTypeConstraints(..)+ , Sql92HasDefaultDataType++ -- * Internal+ , GMigratableTableSettings(..)+ ) where++import Database.Beam+import Database.Beam.Backend.SQL.Types+import Database.Beam.Backend.SQL.SQL2003++import Database.Beam.Migrate.Types.Predicates+import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.Checks++import Control.Applicative (Const(..))++import Data.Proxy+import Data.Text (Text)+import Data.Scientific (Scientific)+import Data.Time.Calendar (Day)+import Data.Int+import Data.Word++import GHC.Generics++class IsSql92DdlCommandSyntax syntax => GMigratableTableSettings syntax (i :: * -> *) fieldCheck where+ gDefaultTblSettingsChecks :: Proxy syntax -> Proxy i -> Bool -> fieldCheck ()++instance (IsSql92DdlCommandSyntax syntax, GMigratableTableSettings syntax xId fieldCheckId) =>+ GMigratableTableSettings syntax (M1 t s xId) (M1 t s fieldCheckId) where+ gDefaultTblSettingsChecks syntax Proxy embedded =+ M1 (gDefaultTblSettingsChecks syntax (Proxy @xId) embedded)++instance ( IsSql92DdlCommandSyntax syntax+ , GMigratableTableSettings syntax aId aFieldCheck+ , GMigratableTableSettings syntax bId bFieldCheck ) =>+ GMigratableTableSettings syntax (aId :*: bId) (aFieldCheck :*: bFieldCheck) where+ gDefaultTblSettingsChecks syntax Proxy embedded =+ gDefaultTblSettingsChecks syntax (Proxy @aId) embedded :*:+ gDefaultTblSettingsChecks syntax (Proxy @bId) embedded++instance ( HasDefaultSqlDataType (Sql92DdlCommandDataTypeSyntax syntax) haskTy+ , HasDefaultSqlDataTypeConstraints (Sql92DdlCommandColumnSchemaSyntax syntax) haskTy+ , HasNullableConstraint (NullableStatus haskTy) (Sql92DdlCommandColumnSchemaSyntax syntax)++ , IsSql92DdlCommandSyntax syntax+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax syntax) ) =>+ GMigratableTableSettings syntax (Rec0 haskTy) (Rec0 (Const [FieldCheck] haskTy)) where++ gDefaultTblSettingsChecks _ _ embedded =+ K1 (Const (nullableConstraint (Proxy @(NullableStatus haskTy)) (Proxy @(Sql92DdlCommandColumnSchemaSyntax syntax)) +++ defaultSqlDataTypeConstraints (Proxy @haskTy) (Proxy @(Sql92DdlCommandColumnSchemaSyntax syntax)) embedded +++ [ FieldCheck (\tblNm nm -> p (TableHasColumn tblNm nm (defaultSqlDataType (Proxy @haskTy) embedded)+ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax syntax))) ]))++instance ( Generic (embeddedTbl (Const [FieldCheck]))+ , IsSql92DdlCommandSyntax syntax+ , GMigratableTableSettings syntax (Rep (embeddedTbl Identity)) (Rep (embeddedTbl (Const [FieldCheck]))) ) =>+ GMigratableTableSettings syntax (Rec0 (embeddedTbl Identity)) (Rec0 (embeddedTbl (Const [FieldCheck]))) where++ gDefaultTblSettingsChecks syntax _ _ =+ K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl Identity))) True))++-- * Nullability check++type family NullableStatus (x :: *) :: Bool where+ NullableStatus (Maybe x) = 'True+ NullableStatus x = 'False++class IsSql92ColumnSchemaSyntax syntax => HasNullableConstraint (x :: Bool) syntax where+ nullableConstraint :: Proxy x -> Proxy syntax -> [ FieldCheck ]++instance ( IsSql92ColumnSchemaSyntax syntax+ , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) ) =>+ HasNullableConstraint 'False syntax where+ nullableConstraint _ _ =+ let c = constraintDefinitionSyntax Nothing notNullConstraintSyntax Nothing+ in [ FieldCheck $ \tblNm colNm -> p (TableColumnHasConstraint tblNm colNm c :: TableColumnHasConstraint syntax) ]+instance IsSql92ColumnSchemaSyntax syntax =>+ HasNullableConstraint 'True syntax where+ nullableConstraint _ _ = []++-- * Default data types++-- | Certain data types also come along with constraints. For example, @SERIAL@+-- types in Postgres generate an automatic @DEFAULT@ constraint.+--+-- You need an instance of this class for any type for which you want beam to be+-- able to infer the SQL data type. If your data type does not have any+-- constraint requirements, you can just declare an empty instance+class IsSql92ColumnSchemaSyntax columnSchemaSyntax =>+ HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty where++ -- | Provide arbitrary constraints on a field of the requested type. See+ -- 'FieldCheck' for more information on the formatting of constraints.+ defaultSqlDataTypeConstraints+ :: Proxy ty -- ^ Concrete representation of the type+ -> Proxy columnSchemaSyntax -- ^ Concrete representation of the syntax+ -> Bool -- ^ 'True' if this field is embedded in a+ -- foreign key, 'False' otherwise. For+ -- example, @SERIAL@ types in postgres get a+ -- @DEFAULT@ constraint, but @SERIAL@ types in+ -- a foreign key do not.+ -> [ FieldCheck ]+ defaultSqlDataTypeConstraints _ _ _ = []++-- | Used to define a default SQL data type for a haskell type in a particular+-- data type syntax.+--+-- Beam defines instances for several standard SQL types, which are polymorphic+-- over any standard data type syntax. Backends or extensions which provide+-- custom types should instantiate instances of this class and+-- 'HasDefaultSqlDataTypeConstraints' for any types they provide for which they+-- would like checked schema migrations+class IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax ty where++ -- | Provide a data type for the given type+ defaultSqlDataType :: Proxy ty -- ^ Concrete representation of the type+ -> Bool -- ^ 'True' if this field is in an embedded+ -- key or table, 'False' otherwise+ -> dataTypeSyntax++instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) =>+ HasDefaultSqlDataType dataTypeSyntax (Auto ty) where+ defaultSqlDataType _ = defaultSqlDataType (Proxy @ty)+instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) =>+ HasDefaultSqlDataTypeConstraints columnSchemaSyntax (Auto ty) where+ defaultSqlDataTypeConstraints _ = defaultSqlDataTypeConstraints (Proxy @ty)++instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) =>+ HasDefaultSqlDataType dataTypeSyntax (Maybe ty) where+ defaultSqlDataType _ = defaultSqlDataType (Proxy @ty)+instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) =>+ HasDefaultSqlDataTypeConstraints columnSchemaSyntax (Maybe ty) where+ defaultSqlDataTypeConstraints _ = defaultSqlDataTypeConstraints (Proxy @ty)++-- TODO Not sure if individual databases will want to customize these types++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int where+ defaultSqlDataType _ _ = intType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int32 where+ defaultSqlDataType _ _ = intType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int32+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int16 where+ defaultSqlDataType _ _ = intType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int16+instance IsSql2008BigIntDataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int64 where+ defaultSqlDataType _ _ = bigIntType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int64++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word where+ defaultSqlDataType _ _ = numericType (Just (10, Nothing))+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word16 where+ defaultSqlDataType _ _ = numericType (Just (5, Nothing))+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word16+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word32 where+ defaultSqlDataType _ _ = numericType (Just (10, Nothing))+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word32+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word64 where+ defaultSqlDataType _ _ = numericType (Just (20, Nothing))+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word64++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Text where+ defaultSqlDataType _ _ = varCharType Nothing Nothing+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Text+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax SqlBitString where+ defaultSqlDataType _ _ = varBitType Nothing+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax SqlBitString++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Double where+ defaultSqlDataType _ _ = realType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Double+instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Scientific where+ defaultSqlDataType _ _ = numericType (Just (20, Just 10))+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Scientific++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Day where+ defaultSqlDataType _ _ = dateType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Day++instance IsSql99DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Bool where+ defaultSqlDataType _ _ = booleanType+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Bool++-- | Constraint synonym to use if you want to assert that a particular+-- 'IsSql92Syntax' syntax supports defaulting for a particular data type+type Sql92HasDefaultDataType syntax ty =+ ( HasDefaultSqlDataType (Sql92DdlCommandDataTypeSyntax syntax) ty+ , HasDefaultSqlDataTypeConstraints (Sql92DdlCommandColumnSchemaSyntax syntax) ty )
+ Database/Beam/Migrate/Generics/Types.hs view
@@ -0,0 +1,28 @@+module Database.Beam.Migrate.Generics.Types where++import Database.Beam.Migrate.Types++import Data.Proxy+import qualified Data.Text as T++import GHC.Generics++class GAutoMigratableDb syntax x where+ defaultMigratableDbSettings' :: Proxy syntax -> x ()++instance GAutoMigratableDb syntax x => GAutoMigratableDb syntax (D1 f x) where+ defaultMigratableDbSettings' syntax = M1 $ defaultMigratableDbSettings' syntax++instance GAutoMigratableDb syntax x => GAutoMigratableDb syntax (C1 f x) where+ defaultMigratableDbSettings' syntax = M1 $ defaultMigratableDbSettings' syntax++instance (GAutoMigratableDb syntax x, GAutoMigratableDb syntax y) =>+ GAutoMigratableDb syntax (x :*: y) where+ defaultMigratableDbSettings' syntax = defaultMigratableDbSettings' syntax :*: defaultMigratableDbSettings' syntax++instance ( Selector f, IsCheckedDatabaseEntity be x+ , CheckedDatabaseEntityDefaultRequirements be x syntax ) =>+ GAutoMigratableDb syntax (S1 f (Rec0 (CheckedDatabaseEntity be db x))) where++ defaultMigratableDbSettings' syntax = M1 (K1 (CheckedDatabaseEntity (checkedDbEntityAuto syntax name) []))+ where name = T.pack (selName (undefined :: S1 f (Rec0 (CheckedDatabaseEntity be db x)) ()))
+ Database/Beam/Migrate/SQL.hs view
@@ -0,0 +1,22 @@+-- | Manual alternative to the 'CheckedDatabaseSettings' mechanism.+--+-- Database schemas are given as sequences of DDL commands expressed in a+-- @beam-migrate@ DSL. The 'runMigrationSilenced' function can be used to+-- recover the 'CheckedDatabaseSettings' that represents the database settings+-- as well as the database predicates corresponding to the sequence of DDL+-- commands.+--+-- This is often a more concise way of specifying a database schema when your+-- database names are wildly different from the defaults beam assigns or you+-- multiple constraints that make modifying the auto-generated schema too+-- difficult.++module Database.Beam.Migrate.SQL+ ( module Database.Beam.Migrate.SQL.SQL92+ , module Database.Beam.Migrate.SQL.Tables+ , module Database.Beam.Migrate.SQL.Types ) where++import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.SQL.Tables+import Database.Beam.Migrate.SQL.Types+
+ Database/Beam/Migrate/SQL/BeamExtensions.hs view
@@ -0,0 +1,34 @@+-- | Beam extensions are optional functionality that do not conform to any+-- standard and may have wildly different interpretations across backends.+--+-- In spite of these drawbacks, these are provided for the purposes of+-- pragmatism and convenience.+module Database.Beam.Migrate.SQL.BeamExtensions where++import Database.Beam.Backend.SQL+import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.SQL.Tables++import Data.Text (Text)++-- | Used to designate that a field should provide a default auto-incrementing value.+--+-- Usage:+--+-- @+-- field "Key" int genericSerial+-- @+--+-- Then, when inserting into the table, you can use 'default_' to request the+-- database automatically assign a new value to the column. See+-- 'runInsertReturning' for another Beam extension that may help if you want+-- to know which value was assigned.+--+-- Note that this is only provided for convenience. Backends often implement+-- auto-incrementing keys wildly differently. Many have restrictions on where+-- 'genericSerial' may appear and may fail at run-time if these conditions+-- aren't met. Please refer to the backend of your choice for more+-- information.+class IsSql92ColumnSchemaSyntax syntax =>+ IsBeamSerialColumnSchemaSyntax syntax where+ genericSerial :: FieldReturnType 'False 'False syntax (SqlSerial Int) a => Text -> a
+ Database/Beam/Migrate/SQL/Builder.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | DDL syntax instances for 'SqlSyntaxBuilder'+module Database.Beam.Migrate.SQL.Builder where++import Database.Beam.Backend.SQL.Builder+import Database.Beam.Migrate.SQL+import Database.Beam.Migrate.Serialization++import Control.Applicative++import Data.ByteString.Builder (Builder, byteString, toLazyByteString)+import qualified Data.ByteString.Lazy.Char8 as BCL+import Data.Monoid++-- | Options for @CREATE TABLE@. Given as a separate ADT because the options may+-- go in different places syntactically.+--+-- You never really need to use this type directly.+data SqlSyntaxBuilderCreateTableOptions+ = SqlSyntaxBuilderCreateTableOptions+ SqlSyntaxBuilder+ SqlSyntaxBuilder+ deriving Eq++instance IsSql92DdlCommandSyntax SqlSyntaxBuilder where+ type Sql92DdlCommandCreateTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92DdlCommandDropTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92DdlCommandAlterTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ createTableCmd = id+ alterTableCmd = id+ dropTableCmd = id++instance IsSql92DropTableSyntax SqlSyntaxBuilder where+ dropTableSyntax tblNm =+ SqlSyntaxBuilder $+ byteString "DROP TABLE " <> quoteSql tblNm++instance IsSql92AlterTableSyntax SqlSyntaxBuilder where+ type Sql92AlterTableAlterTableActionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder++ alterTableSyntax tblNm action =+ SqlSyntaxBuilder $+ byteString "ALTER TABLE " <> quoteSql tblNm <> byteString " " <> buildSql action++instance IsSql92AlterTableActionSyntax SqlSyntaxBuilder where+ type Sql92AlterTableAlterColumnActionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92AlterTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder++ alterColumnSyntax colNm action =+ SqlSyntaxBuilder $+ byteString "ALTER COLUMN " <> quoteSql colNm <> byteString " " <> buildSql action++ addColumnSyntax colNm colSchema =+ SqlSyntaxBuilder $+ byteString "ADD COLUMN " <> quoteSql colNm <> byteString " " <> buildSql colSchema+ dropColumnSyntax colNm =+ SqlSyntaxBuilder $+ byteString "DROP COLUMN " <> quoteSql colNm++ renameColumnToSyntax oldNm newNm =+ SqlSyntaxBuilder $+ byteString "RENAME COLUMN " <> quoteSql oldNm <> " TO " <> quoteSql newNm+ renameTableToSyntax newNm =+ SqlSyntaxBuilder $+ byteString "RENAME TO " <> quoteSql newNm++instance IsSql92AlterColumnActionSyntax SqlSyntaxBuilder where+ setNotNullSyntax = SqlSyntaxBuilder (byteString "SET NOT NULL")+ setNullSyntax = SqlSyntaxBuilder (byteString "DROP NOT NULL")++instance IsSql92CreateTableSyntax SqlSyntaxBuilder where+ type Sql92CreateTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92CreateTableTableConstraintSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92CreateTableOptionsSyntax SqlSyntaxBuilder = SqlSyntaxBuilderCreateTableOptions++ createTableSyntax tableOptions tableName fieldSchemas constraints =+ SqlSyntaxBuilder $+ byteString "CREATE " <>+ maybe mempty (\b -> buildSql b <> byteString " ") beforeOptions <>+ byteString " TABLE " <>++ quoteSql tableName <>++ byteString "(" <>+ buildSepBy (byteString ", ")+ (map (\(nm, schema) -> quoteSql nm <> byteString " " <> buildSql schema) fieldSchemas <>+ map buildSql constraints) <>+ byteString ")" <>++ maybe mempty (\a -> buildSql a <> byteString " ") afterOptions++ where+ (beforeOptions, afterOptions) =+ case tableOptions of+ Just (SqlSyntaxBuilderCreateTableOptions b a) -> (Just b, Just a)+ Nothing -> (Nothing, Nothing)++instance IsSql92TableConstraintSyntax SqlSyntaxBuilder where+ primaryKeyConstraintSyntax fs =+ SqlSyntaxBuilder $+ byteString "PRIMARY KEY(" <> buildSepBy (byteString ", ") (map quoteSql fs) <> byteString ")"++-- | Some backends use this to represent their constraint attributes. Does not+-- need to be used in practice.+data ConstraintAttributeTiming = InitiallyDeferred | InitiallyImmediate+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | Valid 'IsSql92ConstraintAttributesSyntax' shared among some backends.+data SqlConstraintAttributesBuilder+ = SqlConstraintAttributesBuilder+ { _sqlConstraintAttributeTiming :: Maybe ConstraintAttributeTiming+ , _sqlConstraintAttributeDeferrable :: Maybe Bool }+ deriving (Show, Eq)++instance Monoid SqlConstraintAttributesBuilder where+ mempty = SqlConstraintAttributesBuilder Nothing Nothing+ mappend a b =+ SqlConstraintAttributesBuilder+ (_sqlConstraintAttributeTiming b <|> _sqlConstraintAttributeTiming a)+ (_sqlConstraintAttributeDeferrable b <|> _sqlConstraintAttributeDeferrable a)++-- | Convert a 'SqlConstraintAttributesBuilder' to its @SQL92@ representation in+-- the returned 'ByteString' 'Builder'.+fromSqlConstraintAttributes :: SqlConstraintAttributesBuilder -> Builder+fromSqlConstraintAttributes (SqlConstraintAttributesBuilder timing deferrable) =+ maybe mempty timingBuilder timing <> maybe mempty deferrableBuilder deferrable+ where timingBuilder InitiallyDeferred = byteString "INITIALLY DEFERRED"+ timingBuilder InitiallyImmediate = byteString "INITIALLY IMMEDIATE"+ deferrableBuilder False = byteString "NOT DEFERRABLE"+ deferrableBuilder True = byteString "DEFERRABLE"++-- | Serialize a 'SqlConstraintAttributesBuilder'+sqlConstraintAttributesSerialized :: SqlConstraintAttributesBuilder -> BeamSerializedConstraintAttributes+sqlConstraintAttributesSerialized (SqlConstraintAttributesBuilder timing deferrable) =+ mconcat [ maybe mempty serializeTiming timing+ , maybe mempty serializeDeferrable deferrable ]++ where+ serializeTiming InitiallyDeferred = initiallyDeferredAttributeSyntax+ serializeTiming InitiallyImmediate = initiallyImmediateAttributeSyntax++ serializeDeferrable True = deferrableAttributeSyntax+ serializeDeferrable False = notDeferrableAttributeSyntax++instance IsSql92ConstraintAttributesSyntax SqlConstraintAttributesBuilder where+ initiallyDeferredAttributeSyntax = SqlConstraintAttributesBuilder (Just InitiallyDeferred) Nothing+ initiallyImmediateAttributeSyntax = SqlConstraintAttributesBuilder (Just InitiallyImmediate) Nothing+ deferrableAttributeSyntax = SqlConstraintAttributesBuilder Nothing (Just True)+ notDeferrableAttributeSyntax = SqlConstraintAttributesBuilder Nothing (Just False)++instance IsSql92ColumnSchemaSyntax SqlSyntaxBuilder where+ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92ColumnSchemaColumnTypeSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92ColumnSchemaExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder++ columnSchemaSyntax type_ default_ constraints collation =+ SqlSyntaxBuilder $+ buildSql type_ <>+ maybe mempty (\d -> byteString " DEFAULT " <> buildSql d) default_ <>+ (case constraints of+ [] -> mempty+ _ -> foldMap (\c -> byteString " " <> buildSql c) constraints) <>+ maybe mempty (\nm -> byteString " COLLATE " <> quoteSql nm) collation++instance IsSql92ColumnConstraintDefinitionSyntax SqlSyntaxBuilder where+ type Sql92ColumnConstraintDefinitionConstraintSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92ColumnConstraintDefinitionAttributesSyntax SqlSyntaxBuilder = SqlConstraintAttributesBuilder++ constraintDefinitionSyntax nm c attrs =+ SqlSyntaxBuilder $+ maybe mempty (\nm' -> byteString "CONSTRAINT " <> quoteSql nm' <> byteString " ") nm <>+ buildSql c <>+ maybe mempty fromSqlConstraintAttributes attrs++instance IsSql92ColumnConstraintSyntax SqlSyntaxBuilder where+ type Sql92ColumnConstraintMatchTypeSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92ColumnConstraintReferentialActionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+ type Sql92ColumnConstraintExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder++ notNullConstraintSyntax = SqlSyntaxBuilder (byteString "NOT NULL")+ uniqueColumnConstraintSyntax = SqlSyntaxBuilder (byteString "UNIQUE")+ primaryKeyColumnConstraintSyntax = SqlSyntaxBuilder (byteString "PRIMARY KEY")+ checkColumnConstraintSyntax e = SqlSyntaxBuilder ("CHECK (" <> buildSql e <> ")")+ referencesConstraintSyntax tbl fields match onUpdate onDelete =+ SqlSyntaxBuilder $+ "REFERENCES " <> quoteSql tbl <> "(" <>+ buildSepBy ", " (map quoteSql fields) <> ")" <>+ maybe mempty (\m -> " " <> buildSql m) match <>+ maybe mempty (\a -> " ON UPDATE " <> buildSql a) onUpdate <>+ maybe mempty (\a -> " ON DELETE " <> buildSql a) onDelete++instance IsSql92MatchTypeSyntax SqlSyntaxBuilder where+ fullMatchSyntax = SqlSyntaxBuilder "FULL"+ partialMatchSyntax = SqlSyntaxBuilder "PARTIAL"++instance IsSql92ReferentialActionSyntax SqlSyntaxBuilder where+ referentialActionCascadeSyntax = SqlSyntaxBuilder "CASCADE"+ referentialActionNoActionSyntax = SqlSyntaxBuilder "NO ACTION"+ referentialActionSetDefaultSyntax = SqlSyntaxBuilder "SET DEFAULT"+ referentialActionSetNullSyntax = SqlSyntaxBuilder "SET NULL"++instance Sql92DisplaySyntax SqlSyntaxBuilder where+ displaySyntax = BCL.unpack . toLazyByteString . buildSql
+ Database/Beam/Migrate/SQL/SQL92.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ConstraintKinds #-}+-- | Finally-tagless encoding of SQL92 DDL commands.+--+-- If you're writing a beam backend driver and you want to support migrations,+-- making an instance of your command syntax for 'IsSql92DdlCommandSyntax' and+-- making it satisfy 'Sql92SaneDdlCommandSyntax'.+module Database.Beam.Migrate.SQL.SQL92 where++import Database.Beam.Backend.SQL.SQL92++import Data.Aeson (Value)+import Data.Hashable+import Data.Text (Text)+import Data.Typeable++-- * Convenience type synonyms++-- | Command syntaxes that can be used to issue DDL commands.+type Sql92SaneDdlCommandSyntax cmd =+ ( IsSql92DdlCommandSyntax cmd+ , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+ , Sql92SerializableConstraintDefinitionSyntax (Sql92DdlCommandConstraintDefinitionSyntax cmd)+ , Typeable (Sql92DdlCommandColumnSchemaSyntax cmd)+ , Sql92AlterTableColumnSchemaSyntax+ (Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax cmd)) ~+ Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd) )+++type Sql92DdlCommandDataTypeSyntax syntax =+ Sql92ColumnSchemaColumnTypeSyntax (Sql92DdlCommandColumnSchemaSyntax syntax)+type Sql92DdlCommandColumnSchemaSyntax syntax = Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax syntax)+type Sql92DdlCommandConstraintDefinitionSyntax syntax =+ Sql92ColumnSchemaColumnConstraintDefinitionSyntax (Sql92DdlCommandColumnSchemaSyntax syntax)+type Sql92DdlColumnSchemaConstraintSyntax syntax =+ Sql92ColumnConstraintDefinitionConstraintSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+type Sql92DdlCommandColumnConstraintSyntax syntax =+ Sql92DdlColumnSchemaConstraintSyntax (Sql92DdlCommandColumnSchemaSyntax syntax)+type Sql92DdlCommandMatchTypeSyntax syntax =+ Sql92ColumnConstraintMatchTypeSyntax (Sql92DdlCommandColumnConstraintSyntax syntax)+type Sql92DdlCommandReferentialActionSyntax syntax =+ Sql92ColumnConstraintReferentialActionSyntax (Sql92DdlCommandColumnConstraintSyntax syntax)+type Sql92DdlCommandConstraintAttributesSyntax syntax =+ Sql92ColumnConstraintDefinitionAttributesSyntax (Sql92DdlCommandConstraintDefinitionSyntax syntax)+type Sql92DdlCommandAlterTableActionSyntax syntax =+ Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax)++-- | Type classes for syntaxes which can be displayed+class Sql92DisplaySyntax syntax where++ -- | Render the syntax as a 'String', representing the SQL expression it+ -- stands for+ displaySyntax :: syntax -> String++class ( IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax)+ , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax)+ , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) =>+ IsSql92DdlCommandSyntax syntax where+ type Sql92DdlCommandCreateTableSyntax syntax :: *+ type Sql92DdlCommandAlterTableSyntax syntax :: *+ type Sql92DdlCommandDropTableSyntax syntax :: *++ createTableCmd :: Sql92DdlCommandCreateTableSyntax syntax -> syntax+ dropTableCmd :: Sql92DdlCommandDropTableSyntax syntax -> syntax+ alterTableCmd :: Sql92DdlCommandAlterTableSyntax syntax -> syntax++class ( IsSql92TableConstraintSyntax (Sql92CreateTableTableConstraintSyntax syntax)+ , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax) ) =>+ IsSql92CreateTableSyntax syntax where+ type Sql92CreateTableColumnSchemaSyntax syntax :: *+ type Sql92CreateTableTableConstraintSyntax syntax :: *+ type Sql92CreateTableOptionsSyntax syntax :: *++ createTableSyntax :: Maybe (Sql92CreateTableOptionsSyntax syntax)+ -> Text+ -> [ (Text, Sql92CreateTableColumnSchemaSyntax syntax) ]+ -> [ Sql92CreateTableTableConstraintSyntax syntax ]+ -> syntax++class IsSql92DropTableSyntax syntax where+ dropTableSyntax :: Text -> syntax++class IsSql92AlterTableActionSyntax (Sql92AlterTableAlterTableActionSyntax syntax) =>+ IsSql92AlterTableSyntax syntax where+ type Sql92AlterTableAlterTableActionSyntax syntax :: *+ alterTableSyntax :: Text -> Sql92AlterTableAlterTableActionSyntax syntax+ -> syntax++class ( IsSql92ColumnSchemaSyntax (Sql92AlterTableColumnSchemaSyntax syntax)+ , IsSql92AlterColumnActionSyntax (Sql92AlterTableAlterColumnActionSyntax syntax) ) =>+ IsSql92AlterTableActionSyntax syntax where+ type Sql92AlterTableAlterColumnActionSyntax syntax :: *+ type Sql92AlterTableColumnSchemaSyntax syntax :: *+ alterColumnSyntax :: Text -> Sql92AlterTableAlterColumnActionSyntax syntax+ -> syntax+ addColumnSyntax :: Text -> Sql92AlterTableColumnSchemaSyntax syntax -> syntax+ dropColumnSyntax :: Text -> syntax+ renameTableToSyntax :: Text -> syntax+ renameColumnToSyntax :: Text -> Text -> syntax++class IsSql92AlterColumnActionSyntax syntax where+ setNotNullSyntax, setNullSyntax :: syntax++class ( IsSql92ColumnConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema)+ , IsSql92DataTypeSyntax (Sql92ColumnSchemaColumnTypeSyntax columnSchema)+ , Typeable (Sql92ColumnSchemaColumnTypeSyntax columnSchema)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnTypeSyntax columnSchema)+ , Hashable (Sql92ColumnSchemaColumnTypeSyntax columnSchema)+ , Eq (Sql92ColumnSchemaColumnTypeSyntax columnSchema)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema)+ , Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema)+ , Hashable (Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema)+ , IsSql92ExpressionSyntax (Sql92ColumnSchemaExpressionSyntax columnSchema)+ , Typeable columnSchema, Sql92DisplaySyntax columnSchema, Eq columnSchema, Hashable columnSchema ) =>+ IsSql92ColumnSchemaSyntax columnSchema where+ type Sql92ColumnSchemaColumnTypeSyntax columnSchema :: *+ type Sql92ColumnSchemaExpressionSyntax columnSchema :: *+ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema :: *++ columnSchemaSyntax :: Sql92ColumnSchemaColumnTypeSyntax columnSchema {-^ Column type -}+ -> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema) {-^ Default value -}+ -> [ Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema ] {-^ Column constraints -}+ -> Maybe Text {-^ Default collation -}+ -> columnSchema++class Typeable constraint => IsSql92TableConstraintSyntax constraint where+ primaryKeyConstraintSyntax :: [ Text ] -> constraint++class Typeable match => IsSql92MatchTypeSyntax match where+ fullMatchSyntax :: match+ partialMatchSyntax :: match++class Typeable refAction => IsSql92ReferentialActionSyntax refAction where+ referentialActionCascadeSyntax :: refAction+ referentialActionSetNullSyntax :: refAction+ referentialActionSetDefaultSyntax :: refAction+ referentialActionNoActionSyntax :: refAction++class ( IsSql92ColumnConstraintSyntax (Sql92ColumnConstraintDefinitionConstraintSyntax constraint)+ , IsSql92ConstraintAttributesSyntax (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)+ , Typeable constraint ) =>+ IsSql92ColumnConstraintDefinitionSyntax constraint where+ type Sql92ColumnConstraintDefinitionConstraintSyntax constraint :: *+ type Sql92ColumnConstraintDefinitionAttributesSyntax constraint :: *++ constraintDefinitionSyntax :: Maybe Text -> Sql92ColumnConstraintDefinitionConstraintSyntax constraint+ -> Maybe (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)+ -> constraint++class (Monoid attrs, Typeable attrs) => IsSql92ConstraintAttributesSyntax attrs where+ initiallyDeferredAttributeSyntax :: attrs+ initiallyImmediateAttributeSyntax :: attrs+ notDeferrableAttributeSyntax :: attrs+ deferrableAttributeSyntax :: attrs++class ( IsSql92MatchTypeSyntax (Sql92ColumnConstraintMatchTypeSyntax constraint)+ , IsSql92ReferentialActionSyntax (Sql92ColumnConstraintReferentialActionSyntax constraint)+ , Typeable (Sql92ColumnConstraintExpressionSyntax constraint)+ , Typeable constraint ) =>+ IsSql92ColumnConstraintSyntax constraint where+ type Sql92ColumnConstraintMatchTypeSyntax constraint :: *+ type Sql92ColumnConstraintReferentialActionSyntax constraint :: *+ type Sql92ColumnConstraintExpressionSyntax constraint :: *++ notNullConstraintSyntax :: constraint+ uniqueColumnConstraintSyntax :: constraint+ primaryKeyColumnConstraintSyntax :: constraint+ checkColumnConstraintSyntax :: Sql92ColumnConstraintExpressionSyntax constraint -> constraint+ referencesConstraintSyntax :: Text -> [ Text ]+ -> Maybe (Sql92ColumnConstraintMatchTypeSyntax constraint)+ -> Maybe (Sql92ColumnConstraintReferentialActionSyntax constraint) {-^ On update -}+ -> Maybe (Sql92ColumnConstraintReferentialActionSyntax constraint) {-^ On delete -}+ -> constraint++-- | 'IsSql92DataTypeSyntax'es that can be serialized to JSON+class Sql92SerializableDataTypeSyntax dataType where+ serializeDataType :: dataType -> Value++-- | 'IsSql92ColumnConstraintDefinitionSyntax'es that can be serialized to JSON+class Sql92SerializableConstraintDefinitionSyntax constraint where+ serializeConstraint :: constraint -> Value
+ Database/Beam/Migrate/SQL/Tables.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}++module Database.Beam.Migrate.SQL.Tables+ ( -- * Table manipulation++ -- ** Creation and deletion+ createTable, dropTable+ , preserve++ -- ** @ALTER TABLE@+ , TableMigration(..)+ , ColumnMigration(..)+ , alterTable++ , renameTableTo, renameColumnTo+ , addColumn, dropColumn++ -- * Field specification+ , DefaultValue, Constraint(..)++ , field++ , defaultTo_, notNull+ , int, smallint, bigint+ , char, varchar, double+ , characterLargeObject, binaryLargeObject, array+ , boolean, numeric, date, time+ , timestamp, timestamptz+ , binary, varbinary++ , maybeType, autoType++ -- ** Internal classes+ -- Provided without documentation for use in type signatures+ , FieldReturnType(..)+ ) where++import Database.Beam+import Database.Beam.Schema.Tables+import Database.Beam.Backend.SQL++import Database.Beam.Migrate.Types+import Database.Beam.Migrate.Checks+import Database.Beam.Migrate.SQL.Types+import Database.Beam.Migrate.SQL.SQL92++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.Writer.Strict+import Control.Monad.State++import Data.Text (Text)+import Data.Vector (Vector)+import Data.ByteString (ByteString)+import Data.Typeable+import Data.Time (LocalTime, TimeOfDay)+import Data.Scientific (Scientific)++import GHC.TypeLits++-- * Table manipulation++-- | Add a @CREATE TABLE@ statement to this migration+--+-- The first argument is the name of the table.+--+-- The second argument is a table containing a 'FieldSchema' for each field.+-- See documentation on the 'Field' command for more information.+createTable :: ( Beamable table, Table table+ , IsSql92DdlCommandSyntax syntax ) =>+ Text -> TableSchema (Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax syntax)) table+ -> Migration syntax (CheckedDatabaseEntity be db (TableEntity table))+createTable newTblName tblSettings =+ do let createTableCommand =+ createTableSyntax Nothing newTblName+ (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings)+ [ primaryKeyConstraintSyntax (allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings)) ]++ command = createTableCmd createTableCommand++ tbl' = changeBeamRep (\(Columnar' (TableFieldSchema name _ _)) -> Columnar' (TableField name)) tblSettings++ fieldChecks = changeBeamRep (\(Columnar' (TableFieldSchema _ _ cs)) -> Columnar' (Const cs)) tblSettings++ tblChecks = [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableExistsPredicate tblName)) ] +++ primaryKeyCheck++ primaryKeyCheck =+ case allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings) of+ [] -> []+ cols -> [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableHasPrimaryKey tblName cols)) ]++ upDown command Nothing+ pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable newTblName tbl') tblChecks fieldChecks) [])++-- | Add a @DROP TABLE@ statement to this migration.+dropTable :: IsSql92DdlCommandSyntax syntax+ => CheckedDatabaseEntity be db (TableEntity table)+ -> Migration syntax ()+dropTable (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm _) _ _) _) =+ let command = dropTableCmd (dropTableSyntax tblNm)+ in upDown command Nothing++-- | Copy a table schema from one database to another+preserve :: CheckedDatabaseEntity be db e+ -> Migration syntax (CheckedDatabaseEntity be db' e)+preserve (CheckedDatabaseEntity desc checks) = pure (CheckedDatabaseEntity desc checks)++-- * Alter table++-- | A column in the process of being altered+data ColumnMigration a+ = ColumnMigration+ { columnMigrationFieldName :: Text+ , columnMigrationFieldChecks :: [FieldCheck] }++-- | Monad representing a series of @ALTER TABLE@ statements+newtype TableMigration syntax a+ = TableMigration (WriterT [Sql92DdlCommandAlterTableSyntax syntax] (State (Text, [TableCheck])) a)++-- | @ALTER TABLE ... RENAME TO@ command+renameTableTo :: Sql92SaneDdlCommandSyntax syntax+ => Text -> table ColumnMigration+ -> TableMigration syntax (table ColumnMigration)+renameTableTo newName oldTbl = TableMigration $ do+ (curNm, _) <- get+ tell [ alterTableSyntax curNm (renameTableToSyntax newName) ]+ return oldTbl++-- | @ALTER TABLE ... RENAME COLUMN ... TO ...@ command+renameColumnTo :: Sql92SaneDdlCommandSyntax syntax+ => Text -> ColumnMigration a+ -> TableMigration syntax (ColumnMigration a)+renameColumnTo newName column = TableMigration $ do+ (curTblNm, _) <- get+ tell [ alterTableSyntax curTblNm+ (renameColumnToSyntax (columnMigrationFieldName column) newName) ]+ pure column { columnMigrationFieldName = newName }++-- | @ALTER TABLE ... DROP COLUMN ...@ command+dropColumn :: Sql92SaneDdlCommandSyntax syntax+ => ColumnMigration a -> TableMigration syntax ()+dropColumn column = TableMigration $ do+ (curTblNm, _)<- get+ tell [ alterTableSyntax curTblNm (dropColumnSyntax (columnMigrationFieldName column)) ]++-- | @ALTER TABLE ... ADD COLUMN ...@ command+addColumn :: Sql92SaneDdlCommandSyntax syntax+ => TableFieldSchema (Sql92DdlCommandColumnSchemaSyntax syntax) a+ -> TableMigration syntax (ColumnMigration a)+addColumn (TableFieldSchema nm (FieldSchema fieldSchemaSyntax) checks) =+ TableMigration $+ do (curTblNm, _) <- get+ tell [ alterTableSyntax curTblNm (addColumnSyntax nm fieldSchemaSyntax) ]+ pure (ColumnMigration nm checks)++-- | Compose a series of @ALTER TABLE@ commands+--+-- Example usage+--+-- @+-- migrate (OldDb oldTbl) = do+-- alterTable oldTbl $ \oldTbl' ->+-- field2 <- renameColumnTo "NewNameForField2" (_field2 oldTbl')+-- dropColumn (_field3 oldTbl')+-- renameTableTo "NewTableName"+-- field4 <- addColumn (field "ANewColumn" smallint notNull (defaultTo_ (val_ 0)))+-- return (NewTable (_field1 oldTbl') field2 field4)+-- @+--+-- The above would result in commands like:+--+-- @+-- ALTER TABLE <oldtable> RENAME COLUMN <field2> TO "NewNameForField2";+-- ALTER TABLE <oldtable> DROP COLUMN <field3>;+-- ALTER TABLE <oldtable> RENAME TO "NewTableName";+-- ALTER TABLE "NewTableName" ADD COLUMN "ANewColumn" SMALLINT NOT NULL DEFAULT 0;+-- @+--+alterTable :: forall be db db' table table' syntax+ . (Table table', IsSql92DdlCommandSyntax syntax)+ => CheckedDatabaseEntity be db (TableEntity table)+ -> (table ColumnMigration -> TableMigration syntax (table' ColumnMigration))+ -> Migration syntax (CheckedDatabaseEntity be db' (TableEntity table'))+alterTable (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm tbl) tblChecks tblFieldChecks) entityChecks) alterColumns =+ let initialTbl = runIdentity $+ zipBeamFieldsM+ (\(Columnar' (TableField nm) :: Columnar' (TableField table) x)+ (Columnar' (Const checks) :: Columnar' (Const [FieldCheck]) x) ->+ pure (Columnar' (ColumnMigration nm checks)+ :: Columnar' ColumnMigration x))+ tbl tblFieldChecks++ TableMigration alterColumns' = alterColumns initialTbl+ ((newTbl, cmds), (tblNm', tblChecks')) = runState (runWriterT alterColumns') (tblNm, tblChecks)++ fieldChecks' = changeBeamRep (\(Columnar' (ColumnMigration _ checks) :: Columnar' ColumnMigration a) ->+ Columnar' (Const checks) :: Columnar' (Const [FieldCheck]) a)+ newTbl+ tbl' = changeBeamRep (\(Columnar' (ColumnMigration nm _) :: Columnar' ColumnMigration a) ->+ Columnar' (TableField nm) :: Columnar' (TableField table') a)+ newTbl+ in forM_ cmds (\cmd -> upDown (alterTableCmd cmd) Nothing) >>+ pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm' tbl') tblChecks' fieldChecks') entityChecks)++-- * Fields++-- | Build a schema for a field. This function takes the name and type of the+-- field and a variable number of modifiers, such as constraints and default+-- values. GHC will complain at you if the modifiers do not make sense. For+-- example, you cannot apply the 'notNull' constraint to a column with a 'Maybe'+-- type.+--+-- Example of creating a table named "Employee" with three columns: "FirstName",+-- "LastName", and "HireDate"+--+-- @+-- data Employee f =+-- Employee { _firstName :: C f Text+-- , _lastName :: C f Text+-- , _hireDate :: C f (Maybe LocalTime)+-- } deriving Generic+-- instance Beamable Employee+--+-- instance Table Employee where+-- data PrimaryKey Employee f = EmployeeKey (C f Text) (C f Text) deriving Generic+-- primaryKey = EmployeeKey <$> _firstName <*> _lastName+--+-- instance Beamable PrimaryKey Employee f+--+-- data EmployeeDb entity+-- = EmployeeDb { _employees :: entity (TableEntity Employee) }+-- deriving Generic+-- instance Database EmployeeDb+--+-- migration :: IsSql92DdlCommandSyntax syntax => Migration syntax () EmployeeDb+-- migration = do+-- employees <- createTable "EmployeesTable"+-- (Employee (field "FirstNameField" (varchar (Just 15)) notNull)+-- (field "last_name" (varchar Nothing) notNull (defaultTo_ (val_ "Smith")))+-- (field "hiredDate" (maybeType timestamp)))+-- return (EmployeeDb employees)+-- @+field :: ( IsSql92ColumnSchemaSyntax syntax ) =>+ FieldReturnType 'False 'False syntax resTy a => Text -> DataType (Sql92ColumnSchemaColumnTypeSyntax syntax) resTy -> a+field name (DataType ty) = field' (Proxy @'False) (Proxy @'False) name ty Nothing Nothing []++-- ** Default values++-- | Represents the default value of a field with a given column schema syntax and type+newtype DefaultValue syntax a = DefaultValue (Sql92ColumnSchemaExpressionSyntax syntax)++-- | Build a 'DefaultValue' from a 'QExpr'. GHC will complain if you supply more+-- than one default value.+defaultTo_ :: IsSql92ExpressionSyntax (Sql92ColumnSchemaExpressionSyntax syntax) =>+ (forall s. QExpr (Sql92ColumnSchemaExpressionSyntax syntax) s a)+ -> DefaultValue syntax a+defaultTo_ (QExpr e) =+ DefaultValue (e "t")++-- ** Constraints++-- | Represents a constraint in the given column schema syntax+newtype Constraint syntax+ = Constraint (Sql92ColumnConstraintDefinitionConstraintSyntax+ (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax))++-- | The SQL92 @NOT NULL@ constraint+notNull :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax+notNull = Constraint notNullConstraintSyntax++-- ** Data types++-- | SQL92 @INTEGER@ data type+int :: (IsSql92DataTypeSyntax syntax, Integral a) => DataType syntax a+int = DataType intType++-- | SQL92 @SMALLINT@ data type+smallint :: (IsSql92DataTypeSyntax syntax, Integral a) => DataType syntax a+smallint = DataType smallIntType++-- | SQL2008 Optional @BIGINT@ data type+bigint :: (IsSql2008BigIntDataTypeSyntax syntax, Integral a) => DataType syntax a+bigint = DataType bigIntType++-- TODO is Integer the right type to use here?+-- | SQL2003 Optional @BINARY@ data type+binary :: IsSql2003BinaryAndVarBinaryDataTypeSyntax syntax+ => Maybe Word -> DataType syntax Integer+binary prec = DataType (binaryType prec)++-- | SQL2003 Optional @VARBINARY@ data type+varbinary :: IsSql2003BinaryAndVarBinaryDataTypeSyntax syntax+ => Maybe Word -> DataType syntax Integer+varbinary prec = DataType (varBinaryType prec)++-- TODO should this be Day or something?+-- | SQL92 @DATE@ data type+date :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime+date = DataType dateType++-- | SQL92 @CHAR@ data type+char :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax Text+char prec = DataType (charType prec Nothing)++-- | SQL92 @VARCHAR@ data type+varchar :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax Text+varchar prec = DataType (varCharType prec Nothing)++-- | SQL92 @DOUBLE@ data type+double :: IsSql92DataTypeSyntax syntax => DataType syntax Double+double = DataType doubleType++-- | SQL92 @NUMERIC@ data type+numeric :: IsSql92DataTypeSyntax syntax => Maybe (Word, Maybe Word) -> DataType syntax Scientific+numeric x = DataType (numericType x)++-- | SQL92 @TIMESTAMP WITH TIME ZONE@ data type+timestamptz :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime+timestamptz = DataType (timestampType Nothing True)++-- | SQL92 @TIMESTAMP WITHOUT TIME ZONE@ data type+timestamp :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime+timestamp = DataType (timestampType Nothing False)++-- | SQL92 @TIME@ data type+time :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax TimeOfDay+time prec = DataType (timeType prec False)++-- | SQL99 @BOOLEAN@ data type+boolean :: IsSql99DataTypeSyntax syntax => DataType syntax Bool+boolean = DataType booleanType++-- | SQL99 @CLOB@ data type+characterLargeObject :: IsSql99DataTypeSyntax syntax => DataType syntax Text+characterLargeObject = DataType characterLargeObjectType++-- | SQL99 @BLOB@ data type+binaryLargeObject :: IsSql99DataTypeSyntax syntax => DataType syntax ByteString+binaryLargeObject = DataType binaryLargeObjectType++-- | SQL99 array data types+array :: (Typeable a, IsSql99DataTypeSyntax syntax)+ => DataType syntax a -> Int+ -> DataType syntax (Vector a)+array (DataType ty) sz = DataType (arrayType ty sz)++-- | Haskell requires 'DataType's to match exactly. Use this function to convert+-- a 'DataType' that expects a concrete value to one expecting a 'Maybe'+maybeType :: DataType syntax a -> DataType syntax (Maybe a)+maybeType (DataType sqlTy) = DataType sqlTy++-- | Wrap a 'DataType' in 'Auto'+autoType :: DataType syntax a -> DataType syntax (Auto a)+autoType (DataType sqlTy) = DataType sqlTy+++-- ** 'field' variable arity classes++class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) syntax resTy a | a -> syntax resTy where+ field' :: IsSql92ColumnSchemaSyntax syntax =>+ Proxy defaultGiven -> Proxy collationGiven+ -> Text+ -> Sql92ColumnSchemaColumnTypeSyntax syntax+ -> Maybe (Sql92ColumnSchemaExpressionSyntax syntax)+ -> Maybe Text -> [ Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax ]+ -> a++instance FieldReturnType 'True collationGiven syntax resTy a =>+ FieldReturnType 'False collationGiven syntax resTy (DefaultValue syntax resTy -> a) where+ field' _ collationGiven nm ty _ collation constraints (DefaultValue e) =+ field' (Proxy @'True) collationGiven nm ty (Just e) collation constraints++instance FieldReturnType defaultGiven collationGiven syntax resTy a =>+ FieldReturnType defaultGiven collationGiven syntax resTy (Constraint syntax -> a) where+ field' defaultGiven collationGiven nm ty default_' collation constraints (Constraint e) =+ field' defaultGiven collationGiven nm ty default_' collation (constraints ++ [ constraintDefinitionSyntax Nothing e Nothing ])++instance ( FieldReturnType 'True collationGiven syntax resTy a+ , TypeError ('Text "Only one DEFAULT clause can be given per 'field' invocation") ) =>+ FieldReturnType 'True collationGiven syntax resTy (DefaultValue syntax resTy -> a) where++ field' = error "Unreachable because of GHC Custom Type Errors"++instance ( FieldReturnType defaultGiven collationGiven syntax resTy a+ , TypeError ('Text "Only one type declaration allowed per 'field' invocation")) =>+ FieldReturnType defaultGiven collationGiven syntax resTy (DataType syntax' x -> a) where+ field' = error "Unreachable because of GHC Custom Type Errors"++instance ( Typeable syntax, Typeable (Sql92ColumnSchemaColumnTypeSyntax syntax)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnTypeSyntax syntax), Eq (Sql92ColumnSchemaColumnTypeSyntax syntax)+ , Sql92DisplaySyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax), Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+ , IsSql92ColumnSchemaSyntax syntax+ , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)+ , Sql92SerializableDataTypeSyntax (Sql92ColumnSchemaColumnTypeSyntax syntax) ) =>+ FieldReturnType defaultGiven collationGiven syntax resTy (TableFieldSchema syntax resTy) where+ field' _ _ nm ty default_' collation constraints =+ TableFieldSchema nm (FieldSchema (columnSchemaSyntax ty default_' constraints collation)) checks+ where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn syntax)) ] +++ map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint syntax))) constraints
+ Database/Beam/Migrate/SQL/Types.hs view
@@ -0,0 +1,32 @@+-- | Some common SQL data types+module Database.Beam.Migrate.SQL.Types+ ( TableSchema, TableFieldSchema(..)+ , FieldSchema(..), DataType(..)+ ) where++import Database.Beam.Migrate.Types.Predicates+import Database.Beam.Migrate.SQL.SQL92++import Data.Text (Text)++-- | A table schema, produced by 'createTable'+type TableSchema fieldSchemaSyntax tbl =+ tbl (TableFieldSchema fieldSchemaSyntax)++-- | A schema for a field within a given table+data TableFieldSchema fieldSchemaSyntax a+ = TableFieldSchema Text (FieldSchema fieldSchemaSyntax a) [FieldCheck]++-- | A schema for a field which hasn't been named yet+newtype FieldSchema syntax a = FieldSchema syntax+ deriving (Show, Eq)++-- | A data type in a given 'IsSql92DataTypeSyntax' which describes a SQL type+-- mapping to the Haskell type @a@+newtype DataType syntax a = DataType syntax++instance Sql92DisplaySyntax syntax => Show (DataType syntax a) where+ show (DataType syntax) = "DataType (" ++ displaySyntax syntax ++ ")"++instance Eq syntax => Eq (DataType syntax a) where+ DataType a == DataType b = a == b
+ Database/Beam/Migrate/Serialization.hs view
@@ -0,0 +1,495 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}++-- | Serialization and deserialization helpers for beam data types.+--+-- Used to read and write machine-readable schema descriptions.++module Database.Beam.Migrate.Serialization+ ( -- * Serialization helpers+ -- $serialization+ BeamSerializedDataType(..)+ , BeamSerializedConstraintDefinition(..)+ , BeamSerializedConstraintAttributes(..)+ , BeamSerializedConstraint(..)+ , BeamSerializedMatchType(..)+ , BeamSerializedReferentialAction(..)+ , BeamSerializedExpression(..)++ , beamSerializeJSON, serializePrecAndDecimal++ -- * Deserialization helpers+ -- $deserialization++ , BeamDeserializers(..)++ , beamDeserialize, beamDeserializeMaybe+ , beamDeserializer, sql92Deserializers+ , sql99DataTypeDeserializers+ , sql2003BinaryAndVarBinaryDataTypeDeserializers+ , sql2008BigIntDataTypeDeserializers+ ) where++import Database.Beam.Backend.SQL+import Database.Beam.Migrate.SQL.SQL92++import Control.Applicative+import Control.Monad++import Data.Aeson+import Data.Aeson.Types (Parser)+import qualified Data.Dependent.Map as D+import qualified Data.GADT.Compare as D+import Data.Monoid ((<>))+import Data.Text (Text, unpack)+import Data.Typeable (Typeable, (:~:)( Refl ), eqT, typeRep, typeOf)+import qualified Data.Vector as V++-- * Serialization helpers++-- | An 'IsSql92DataTypeSyntax' for JSON. Supports all superclasses of+-- `IsSql92DataTypeSyntax` declared in @beam-core@.+newtype BeamSerializedDataType+ = BeamSerializedDataType { fromBeamSerializedDataType :: Value }+ deriving (Show, Eq)++instance IsSql92DataTypeSyntax BeamSerializedDataType where+ domainType nm = BeamSerializedDataType (object [ "domain" .= nm])+ charType prec collation =+ BeamSerializedDataType (object [ "char" .= object [ "prec" .= prec+ , "collation" .= collation ]])+ varCharType prec collation =+ BeamSerializedDataType (object [ "varchar" .= object [ "prec" .= prec+ , "collation" .= collation ]])+ nationalCharType prec =+ BeamSerializedDataType (object [ "national-char" .= object [ "prec" .= prec ]])+ nationalVarCharType prec =+ BeamSerializedDataType (object [ "national-varchar" .= object [ "prec" .= prec ]])++ bitType prec =+ BeamSerializedDataType (object [ "bit" .= object [ "prec" .= prec ]])+ varBitType prec =+ BeamSerializedDataType (object [ "varbit" .= object [ "prec" .= prec ]])++ numericType precAndDecimal =+ BeamSerializedDataType (object [ "numeric" .= serializePrecAndDecimal precAndDecimal ])+ decimalType precAndDecimal =+ BeamSerializedDataType (object [ "decimal" .= serializePrecAndDecimal precAndDecimal ])++ intType = BeamSerializedDataType "int"+ smallIntType = BeamSerializedDataType "smallint"+ floatType prec =+ BeamSerializedDataType (object [ "float" .= object [ "prec" .= prec ] ])+ doubleType = BeamSerializedDataType "double"+ realType = BeamSerializedDataType "real"++ dateType = BeamSerializedDataType "date"+ timeType prec withTz =+ BeamSerializedDataType (object [ "time" .= object [ "prec" .= prec+ , "timezone" .= withTz ]])+ timestampType prec withTz =+ BeamSerializedDataType (object [ "timestamp" .= object [ "prec" .= prec+ , "timezone" .= withTz ]])++instance IsSql99DataTypeSyntax BeamSerializedDataType where+ characterLargeObjectType = BeamSerializedDataType "clob"+ binaryLargeObjectType = BeamSerializedDataType "blob"+ booleanType = BeamSerializedDataType "boolean"+ arrayType ty count = BeamSerializedDataType (object [ "array" .= object [ "of" .= ty+ , "count" .= count ]])+ rowType tys = BeamSerializedDataType (object [ "row" .= tys ])++instance IsSql2003BinaryAndVarBinaryDataTypeSyntax BeamSerializedDataType where+ binaryType sz = BeamSerializedDataType (object [ "binary" .= sz ])+ varBinaryType sz = BeamSerializedDataType (object [ "varbinary" .= sz ])++instance IsSql2008BigIntDataTypeSyntax BeamSerializedDataType where+ bigIntType = BeamSerializedDataType "bigint"++instance ToJSON BeamSerializedDataType where+ toJSON = fromBeamSerializedDataType++-- | 'IsSql92ColumnConstraintDefinitionSyntax' type for JSON+newtype BeamSerializedConstraintDefinition+ = BeamSerializedConstraintDefinition+ { fromBeamSerializedConstraintDefinition :: Value+ } deriving (Show, Eq)++-- | 'IsSql92ConstraintAttributesSyntax' type for JSON+newtype BeamSerializedConstraintAttributes+ = BeamSerializedConstraintAttributes+ { fromBeamSerializedConstraintAttributes :: [ Value ]+ } deriving (Show, Eq, Monoid)++-- | 'IsSql92ColumnConstraintSyntax' type for JSON+newtype BeamSerializedConstraint+ = BeamSerializedConstraint+ { fromBeamSerializedConstraint :: Value+ } deriving (Show, Eq)++-- | 'IsSql92MatchTypeSyntax' type for JSON+newtype BeamSerializedMatchType+ = BeamSerializedMatchType+ { fromBeamSerializedMatchType :: Value+ } deriving (Show, Eq)++-- | 'IsSql92ReferentialActionSyntax' type for JSON+newtype BeamSerializedReferentialAction+ = BeamSerializedReferentialAction+ { fromBeamSerializedReferentialAction :: Value+ } deriving (Show, Eq)++-- | 'IsSql92ExpressionSyntax' is too complex for us to store in JSON.+-- Additionally, many backends provide substantial amounts of extensions to the+-- syntax that would make storing this highly unfeasible. Expressions are+-- therefore represented as their full text rendering.+--+-- This means that expressions only match as equal if they match /exactly/.+-- While this may seem overly pedantic, it's not much of a concern if your+-- migrations are generated solely by @beam-migrate@. If you've modified the+-- schema yourself, you may have to use 'IsCustomSqlSyntax' to provide an exact+-- expression.+newtype BeamSerializedExpression+ = BeamSerializedExpression+ { fromBeamSerializedExpression :: Text+ } deriving (Show, Eq)++instance IsSql92ColumnConstraintDefinitionSyntax BeamSerializedConstraintDefinition where+ type Sql92ColumnConstraintDefinitionAttributesSyntax BeamSerializedConstraintDefinition =+ BeamSerializedConstraintAttributes+ type Sql92ColumnConstraintDefinitionConstraintSyntax BeamSerializedConstraintDefinition =+ BeamSerializedConstraint++ constraintDefinitionSyntax nm constraint attrs =+ BeamSerializedConstraintDefinition $+ object [ "name" .= nm+ , "attributes" .= fmap fromBeamSerializedConstraintAttributes attrs+ , "constraint" .= fromBeamSerializedConstraint constraint ]++instance IsSql92ColumnConstraintSyntax BeamSerializedConstraint where+ type Sql92ColumnConstraintMatchTypeSyntax BeamSerializedConstraint =+ BeamSerializedMatchType+ type Sql92ColumnConstraintReferentialActionSyntax BeamSerializedConstraint =+ BeamSerializedReferentialAction+ type Sql92ColumnConstraintExpressionSyntax BeamSerializedConstraint =+ BeamSerializedExpression++ notNullConstraintSyntax = BeamSerializedConstraint "not-null"+ uniqueColumnConstraintSyntax = BeamSerializedConstraint "unique"+ primaryKeyColumnConstraintSyntax = BeamSerializedConstraint "primary-key"+ checkColumnConstraintSyntax e = BeamSerializedConstraint (object [ "check-column" .= fromBeamSerializedExpression e])+ referencesConstraintSyntax tbl fields matchType onUpdate onDelete =+ BeamSerializedConstraint (object [ "references" .=+ object [ "table" .= tbl, "fields" .= fields+ , "match-type" .= fmap fromBeamSerializedMatchType matchType+ , "on-update" .= fmap fromBeamSerializedReferentialAction onUpdate+ , "on-delete" .= fmap fromBeamSerializedReferentialAction onDelete ] ])++instance IsSql92MatchTypeSyntax BeamSerializedMatchType where+ fullMatchSyntax = BeamSerializedMatchType "full"+ partialMatchSyntax = BeamSerializedMatchType "partial"++instance IsSql92ReferentialActionSyntax BeamSerializedReferentialAction where+ referentialActionCascadeSyntax = BeamSerializedReferentialAction "cascade"+ referentialActionSetNullSyntax = BeamSerializedReferentialAction "set-null"+ referentialActionSetDefaultSyntax = BeamSerializedReferentialAction "set-default"+ referentialActionNoActionSyntax = BeamSerializedReferentialAction "nothing"++instance IsSql92ConstraintAttributesSyntax BeamSerializedConstraintAttributes where+ initiallyDeferredAttributeSyntax = BeamSerializedConstraintAttributes [ "initially-deferred" ]+ initiallyImmediateAttributeSyntax = BeamSerializedConstraintAttributes [ "initially-immediate" ]+ notDeferrableAttributeSyntax = BeamSerializedConstraintAttributes [ "not-deferrable" ]+ deferrableAttributeSyntax = BeamSerializedConstraintAttributes [ "deferrable" ]++-- | Some backends serialize data that can only be read by that backend. If so,+-- they should wrap these data in 'beamSerializeJSON', which provides a standard+-- syntax for specifying backend specific data, as well as which backend the+-- data are valid for.+--+-- The first argument is a string that is unique to a given backend+beamSerializeJSON :: Text -> Value -> Value+beamSerializeJSON backend v =+ object [ "be-specific" .= backend+ , "be-data" .= v ]++-- | Helper for serializing the precision and decimal count parameters to+-- 'decimalType', etc.+serializePrecAndDecimal :: Maybe (Word, Maybe Word) -> Value+serializePrecAndDecimal Nothing =+ object []+serializePrecAndDecimal (Just (prec, Nothing)) =+ object [ "prec" .= prec ]+serializePrecAndDecimal (Just (prec, Just decimal)) =+ object [ "prec" .= prec+ , "decimal" .= decimal ]++-- * Deserialization helpers++-- ** Data types++newtype BeamDeserializer syntax+ = BeamDeserializer (forall cmd. BeamDeserializers cmd -> Value -> Parser syntax)++-- | Provides a collection of deserializers from aeson 'Value's for arbitrary+-- types. The @cmd@ type parameter is a phantom type parameter. Notionally, all+-- deserializers within this 'BeamDeserializers' relate to the @cmd@ syntax.+newtype BeamDeserializers cmd+ = BeamDeserializers+ { beamArbitraryDeserializers :: D.DMap BeamDeserializerLabel BeamDeserializer+ }++instance Monoid (BeamDeserializer cmd) where+ mempty = BeamDeserializer (const (const mzero))+ mappend (BeamDeserializer a) (BeamDeserializer b) =+ BeamDeserializer $ \d o ->+ a d o <|> b d o++instance Monoid (BeamDeserializers cmd) where+ mempty = BeamDeserializers mempty+ mappend (BeamDeserializers a) (BeamDeserializers b) =+ BeamDeserializers (D.unionWithKey (const mappend) a b)++-- | Helper function to deserialize data from a 'Maybe' 'Value'.+--+-- @+-- beamDeserializeMaybe _ Nothing = pure Nothing+-- beamDeserializeMaybe d (Just v) = Just <$> beamDeserialize d v+-- @+--+beamDeserializeMaybe :: Typeable a+ => BeamDeserializers cmd+ -> Maybe Value+ -> Parser (Maybe a)+beamDeserializeMaybe _ Nothing = pure Nothing+beamDeserializeMaybe d (Just v) =+ Just <$> beamDeserialize d v++-- | Deserialize the requested type from the given deserializers and aeson 'Value'.+beamDeserialize :: forall a cmd. Typeable a+ => BeamDeserializers cmd -> Value+ -> Parser a+beamDeserialize allD@(BeamDeserializers d) v =+ case D.lookup (BeamDeserializerLabel :: BeamDeserializerLabel a) d of+ Nothing -> fail ("beamDeserialize: No deserializer for " ++ show (typeOf (undefined :: a)))+ Just (BeamDeserializer doParse) ->+ doParse allD v++data BeamDeserializerLabel ty where+ BeamDeserializerLabel :: Typeable ty+ => BeamDeserializerLabel ty+instance D.GEq BeamDeserializerLabel where+ geq a b =+ case D.gcompare a b of+ D.GEQ -> Just Refl+ _ -> Nothing+instance D.GCompare BeamDeserializerLabel where+ gcompare a@(BeamDeserializerLabel :: BeamDeserializerLabel a)+ b@(BeamDeserializerLabel :: BeamDeserializerLabel b) =+ case eqT of+ Just (Refl :: a :~: b)-> D.GEQ+ Nothing ->+ case compare (typeRep a) (typeRep b) of+ LT -> D.GLT+ GT -> D.GGT+ EQ -> error "Impossible"++beamDeserializer :: Typeable ty+ => (forall cmd'. BeamDeserializers cmd' -> Value -> Parser ty)+ -> BeamDeserializers cmd+beamDeserializer parse =+ BeamDeserializers (D.singleton BeamDeserializerLabel (BeamDeserializer parse))++-- | Deserializers for SQL92 syntaxes+sql92Deserializers :: forall cmd+ . IsSql92DdlCommandSyntax cmd+ => BeamDeserializers cmd+sql92Deserializers = mconcat+ [ beamDeserializer deserializeSql92DataType+ , beamDeserializer deserializeSql92ConstraintDefinition+ , beamDeserializer deserializeSql92Constraint+ , beamDeserializer deserializeSql92MatchType+ , beamDeserializer deserializeSql92ReferentialAction+ , beamDeserializer deserializeSql92Attributes ]+ where+ parseSub nm o key parse =+ withObject (unpack (nm <> "." <> key)) parse =<< o .: key++ deserializeSql92DataType :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandDataTypeSyntax cmd)+ deserializeSql92DataType _ o =+ deserializeSql92DataTypeObject o <|>+ deserializeSql92DataTypeScalar o++ deserializeSql92DataTypeScalar "int" = pure intType+ deserializeSql92DataTypeScalar "smallint" = pure smallIntType+ deserializeSql92DataTypeScalar "double" = pure dateType+ deserializeSql92DataTypeScalar "real" = pure realType+ deserializeSql92DataTypeScalar "date" = pure dateType+ deserializeSql92DataTypeScalar _ = mzero++ deserializeSql92DataTypeObject =+ withObject "Sql92DataType" $ \o ->+ let (==>) = parseSub "Sql92DataType" o+ in (domainType <$> o .: "domain") <|>+ ("char" ==> \v ->+ charType <$> v .: "prec" <*> v .: "collation") <|>+ ("varchar" ==> \v ->+ varCharType <$> v .: "prec" <*> v .: "collation") <|>+ ("national-char" ==> \v ->+ nationalCharType <$> v .: "prec") <|>+ ("national-varchar" ==> \v ->+ nationalVarCharType <$> v .: "prec") <|>+ ("bit" ==> \v ->+ bitType <$> v .: "prec") <|>+ ("varbit" ==> \v ->+ varBitType <$> v .: "prec") <|>+ ("numeric" ==> \v ->+ numericType <$> deserializePrecAndDecimal v) <|>+ ("decimal" ==> \v ->+ decimalType <$> deserializePrecAndDecimal v) <|>+ ("float" ==> \v ->+ floatType <$> v .: "prec") <|>+ ("time" ==> \v ->+ timeType <$> v .: "prec" <*> v .: "timezone") <|>+ ("timestamp" ==> \v ->+ timestampType <$> v .: "prec" <*> v .: "timezone")++ deserializePrecAndDecimal o =+ Just <$> (((,) <$> o .: "prec" <*> (Just <$> o .: "decimal")) <|>+ ((,Nothing) <$> o .: "prec")) <|>+ pure Nothing++ deserializeSql92ConstraintDefinition :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandConstraintDefinitionSyntax cmd)+ deserializeSql92ConstraintDefinition d =+ withObject "Sql92ColumnConstraintDefinition" $ \o ->+ constraintDefinitionSyntax <$> o .: "name"+ <*> (beamDeserialize d =<< o .: "constraint")+ <*> (beamDeserializeMaybe d =<< o .: "attributes")++ deserializeSql92Constraint :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandColumnConstraintSyntax cmd)+ deserializeSql92Constraint d o =+ case o of+ "not-null" -> pure notNullConstraintSyntax+ "unique" -> pure uniqueColumnConstraintSyntax+ _ -> withObject "Sql92ColumnConstraint" parseObject o+ where+ parseObject v =+ let (==>) = parseSub "Sql92ColumnConstraint" v+ in checkColumnConstraintSyntax <$> (beamDeserialize d =<< v .: "check-column") <|>+ ("references" ==> \v' ->+ referencesConstraintSyntax <$> v' .: "table" <*> v' .: "fields"+ <*> (beamDeserializeMaybe d =<< v' .: "match-type")+ <*> (beamDeserializeMaybe d =<< v' .: "on-update")+ <*> (beamDeserializeMaybe d =<< v' .: "on-delete"))++ deserializeSql92MatchType :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandMatchTypeSyntax cmd)+ deserializeSql92MatchType _ v =+ case v of+ "full" -> pure fullMatchSyntax+ "partial" -> pure partialMatchSyntax+ _ -> mzero++ deserializeSql92ReferentialAction :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandReferentialActionSyntax cmd)+ deserializeSql92ReferentialAction _ v =+ case v of+ "cascade" -> pure referentialActionCascadeSyntax+ "set-null" -> pure referentialActionSetNullSyntax+ "set-default" -> pure referentialActionSetDefaultSyntax+ "nothing" -> pure referentialActionNoActionSyntax+ _ -> mzero++ deserializeSql92Attributes :: BeamDeserializers cmd' -> Value+ -> Parser (Sql92DdlCommandConstraintAttributesSyntax cmd)+ deserializeSql92Attributes _ =+ withArray "Sql92Attributes" $ \a ->+ pure (foldr (\o accum ->+ case o of+ "initially-deferred" -> initiallyDeferredAttributeSyntax <> accum+ "initially-immediate" -> initiallyImmediateAttributeSyntax <> accum+ "not-deferrable" -> notDeferrableAttributeSyntax <> accum+ "deferrable" -> deferrableAttributeSyntax <> accum+ _ -> accum+ ) mempty a)++-- | Deserializes data types that are instances of 'IsSql99DataTypeSyntax'+sql99DataTypeDeserializers+ :: forall cmd+ . ( IsSql92DdlCommandSyntax cmd+ , IsSql99DataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => BeamDeserializers cmd+sql99DataTypeDeserializers =+ beamDeserializer $ \d v ->+ fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+ case v of+ "clob" -> pure characterLargeObjectType+ "blob" -> pure binaryLargeObjectType+ _ -> withObject "Sql99DataType" (parseObject d) v+ where+ parseObject d v =+ arrayType <$> (beamDeserialize d =<< v .: "of") <*> v .: "count" <|>+ rowType <$> (do rowTypes <- v .: "row"+ let parseArray a =+ forM (V.toList a) $ \a' -> do+ (nm, a'') <- parseJSON a'+ (nm,) <$> beamDeserialize d a''+ withArray "Sql99DataType.rowType" parseArray rowTypes)++-- | Deserialize data types that are instances of 'IsSql2003BinaryAndVarBinaryDataTypeSyntax'+sql2003BinaryAndVarBinaryDataTypeDeserializers+ :: forall cmd+ . ( IsSql92DdlCommandSyntax cmd+ , IsSql2003BinaryAndVarBinaryDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => BeamDeserializers cmd+sql2003BinaryAndVarBinaryDataTypeDeserializers =+ beamDeserializer $ \_ v ->+ fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+ withObject "Sql2003DataType"+ (\o -> (binaryType <$> o .: "binary") <|>+ (varBinaryType <$> o .: "varbinary"))+ v++-- | Deserialize data types that are instance of 'IsSql2008BigIntDataTypeSyntax'+sql2008BigIntDataTypeDeserializers+ :: forall cmd+ . ( IsSql92DdlCommandSyntax cmd+ , IsSql2008BigIntDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )+ => BeamDeserializers cmd+sql2008BigIntDataTypeDeserializers =+ beamDeserializer $ \_ v ->+ fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+ case v of+ "bigint" -> pure bigIntType+ _ -> fail "Sql2008DataType.bigint: expected 'bigint'"++-- $serialization+-- Below we provide various instances of Beam SQL syntax types that produce an+-- aeson 'Value' that reflects the call tree. This allows us to read back+-- these data types in various syntaxes.+--+-- Because these are formatted as standard beam syntaxes, backends can easily+-- serialize their data to disk. For an example of what we mean by this, see+-- the instance of 'IsSql92DataTypeSyntax' for 'SqliteDataTypeSyntax' in+-- @beam-sqlite@.+++-- $deserialization+--+-- Deserialization requires that knowledge of every type of data we can+-- deserialize is stored in one place. While this is not much of an issue when+-- compiling full Haskell applications, due to the type class mechanism,+-- beam-migrate tools load backends dynamically. This means that we need a+-- separate way to discover deserialization instances for types we care about.+--+-- Values of the 'BeamDeserializers' type represent a set of deserializers all+-- related to one kind of command syntax. You can ask for the deserializers to+-- deserialize any type from an aeson 'Value'. The deserialization will+-- succeed only if a deserializer for the requested type exists and the+-- deserializer was able to parse the 'Value'.+--+-- 'BeamDeserializers' compose monoidally. Thus, you can extend any+-- 'BeamDeserializers' with your own custom deserializers, by 'mappend'ing it+-- with a new 'BeamDeserializers', created by calling 'beamDeserializer'.
+ Database/Beam/Migrate/Simple.hs view
@@ -0,0 +1,69 @@++-- | Utility functions for common use cases+module Database.Beam.Migrate.Simple+ ( simpleSchema, simpleMigration+ , runSimpleMigration, backendMigrationScript++ , module Database.Beam.Migrate.Actions+ , module Database.Beam.Migrate.Types ) where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Migrate.Backend+import Database.Beam.Migrate.Types+import Database.Beam.Migrate.Actions++import qualified Data.Text as T++-- | Attempt to find a SQL schema given an 'ActionProvider' and a checked+-- database. Returns 'Nothing' if no schema could be found, which usually means+-- you have chosen the wrong 'ActionProvider', or the backend you're using is+-- buggy.+simpleSchema :: Database db+ => ActionProvider cmd+ -> CheckedDatabaseSettings be db+ -> Maybe [cmd]+simpleSchema provider settings =+ let allChecks = collectChecks settings+ solver = heuristicSolver provider [] allChecks+ in case finalSolution solver of+ Solved cmds -> Just cmds+ Candidates {} -> Nothing++-- | Given a migration backend, a handle to a database, and a checked database,+-- attempt to find a schema. This should always return 'Just', unless the+-- backend has incomplete migrations support.+--+-- 'BeamMigrationBackend's can usually be found in a module named+-- @Database.Beam.<Backend>.Migrate@ with the name@migrationBackend@+simpleMigration :: ( MonadBeam cmd be handle m+ , Database db )+ => BeamMigrationBackend be cmd handle+ -> handle+ -> CheckedDatabaseSettings be db+ -> IO (Maybe [cmd])+simpleMigration BeamMigrationBackend { backendGetDbConstraints = getCs+ , backendActionProvider = action } hdl db = do+ pre <- withDatabase hdl getCs++ let post = collectChecks db+ solver = heuristicSolver action pre post++ case finalSolution solver of+ Solved cmds -> pure (Just cmds)+ Candidates {} -> pure Nothing++-- | Run a sequence of commands on a database+runSimpleMigration :: MonadBeam cmd be hdl m+ => hdl -> [cmd] -> IO ()+runSimpleMigration hdl =+ withDatabase hdl . mapM_ runNoReturn++-- | Given a function to convert a command to a 'String', produce a script that+-- will execute the given migration. Usually, the function you provide+-- eventually calls 'displaySyntax' to rendere the command.+backendMigrationScript :: (cmd -> String)+ -> Migration cmd a+ -> String+backendMigrationScript render mig =+ migrateScript ((++"\n") . T.unpack) ((++"\n") . render) (migrationStep "Migration Script" (\() -> mig))
+ Database/Beam/Migrate/Types.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Beam.Migrate.Types+ ( -- * Checked database entities+ CheckedDatabaseSettings++ , IsCheckedDatabaseEntity(..)+ , CheckedDatabaseEntityDescriptor(..)+ , CheckedDatabaseEntity(..)++ , unCheckDatabase, collectChecks++ -- ** Modifyinging checked entities+ --+ -- The functions in this section can be used to modify 'CheckedDatabaseSettings' objects.+ , CheckedFieldModification++ , modifyCheckedTable+ , checkedTableModification++ -- * Predicates+ , DatabasePredicate(..)+ , SomeDatabasePredicate(..)+ , PredicateSpecificity(..)++ , p++ -- * Entity checks+ , TableCheck(..), DomainCheck(..)+ , FieldCheck(..)++ -- * Migrations+ , MigrationStep(..), MigrationSteps(..)+ , Migration, MigrationF(..)++ , migrationStepsToMigration, runMigrationSilenced+ , runMigrationVerbose, executeMigration+ , eraseMigrationType, migrationStep, upDown++ , migrateScript, evaluateDatabase, stepNames ) where++import Database.Beam+import Database.Beam.Backend++import Database.Beam.Migrate.Types.CheckedEntities+import Database.Beam.Migrate.Types.Predicates++import Control.Monad.Free.Church+import Control.Arrow+import Control.Category (Category)++import Data.Monoid+import Data.Text (Text)++-- * Migration types++data MigrationStep syntax next where+ MigrationStep :: Text -> Migration syntax a -> (a -> next) -> MigrationStep syntax next+deriving instance Functor (MigrationStep syntax)+newtype MigrationSteps syntax from to = MigrationSteps (Kleisli (F (MigrationStep syntax)) from to)+ deriving (Category, Arrow)++data MigrationF syntax next where+ MigrationRunCommand+ :: { _migrationUpCommand :: syntax {-^ What to execute when applying the migration -}+ , _migrationDownCommand :: Maybe syntax {-^ What to execute when unapplying the migration -}+ , _migrationNext :: next }+ -> MigrationF syntax next+deriving instance Functor (MigrationF syntax)+type Migration syntax = F (MigrationF syntax)+++migrationStepsToMigration :: Int -> Maybe Int+ -> MigrationSteps syntax () a+ -> (forall a'. Text -> Migration syntax a' -> IO a')+ -> IO a+migrationStepsToMigration firstIdx lastIdx (MigrationSteps steps) runMigration =+ runF (runKleisli steps ()) finish step 0+ where finish x _ = pure x+ step (MigrationStep nm doStep next) i =+ if i >= firstIdx && maybe True (i <) lastIdx+ then runMigration nm doStep >>= \x -> next x (i + 1)+ else next (runMigrationSilenced doStep) (i + 1)++runMigrationSilenced :: Migration syntax a -> a+runMigrationSilenced m = runF m id step+ where+ step (MigrationRunCommand _ _ next) = next++runMigrationVerbose :: MonadBeam syntax be hdl m => (syntax -> String)+ -> Migration syntax a -> m a+runMigrationVerbose renderMigrationSyntax steps =+ runF steps finish step+ where finish = pure+ step (MigrationRunCommand up _ next) =+ do liftIO (putStrLn (renderMigrationSyntax up))+ runNoReturn up+ next++eraseMigrationType :: a -> MigrationSteps syntax a a' -> MigrationSteps syntax () ()+eraseMigrationType a (MigrationSteps steps) = MigrationSteps (arr (const a) >>> steps >>> arr (const ()))++migrationStep :: Text -> (a -> Migration syntax a') -> MigrationSteps syntax a a'+migrationStep stepName migration =+ MigrationSteps (Kleisli (\a -> liftF (MigrationStep stepName (migration a) id)))++upDown :: syntax -> Maybe syntax -> Migration syntax ()+upDown up down = liftF (MigrationRunCommand up down ())++migrateScript :: forall syntax m a.+ Monoid m => (Text -> m) -> (syntax -> m) -> MigrationSteps syntax () a -> m+migrateScript renderMigrationHeader renderMigrationSyntax (MigrationSteps steps) =+ runF (runKleisli steps ()) (\_ x -> x)+ (\(MigrationStep header migration next) x ->+ let (res, script) = renderMigration migration mempty+ in next res (x <> renderMigrationHeader header <> script)) mempty+ where+ renderMigration :: forall a'. Migration syntax a' -> m -> (a', m)+ renderMigration migrationSteps =+ runF migrationSteps (,)+ (\(MigrationRunCommand a _ next) x -> next (x <> renderMigrationSyntax a))++-- | Execute a given migration, provided a command to execute arbitrary syntax.+-- You usually use this with 'runNoReturn'.+executeMigration :: Applicative m => (syntax -> m ()) -> Migration syntax a -> m a+executeMigration runSyntax go = runF go pure doStep+ where+ doStep (MigrationRunCommand cmd _ next) =+ runSyntax cmd *> next++evaluateDatabase :: forall syntax a. MigrationSteps syntax () a -> a+evaluateDatabase (MigrationSteps f) = runF (runKleisli f ()) id (\(MigrationStep _ migration next) -> next (runMigration migration))+ where+ runMigration :: forall a'. Migration syntax a' -> a'+ runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next)++stepNames :: forall syntax a. MigrationSteps syntax () a -> [Text]+stepNames (MigrationSteps f) = runF (runKleisli f ()) (\_ x -> x) (\(MigrationStep nm migration next) x -> next (runMigration migration) (x ++ [nm])) []+ where+ runMigration :: forall a'. Migration syntax a' -> a'+ runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next)++-- * Checked database entities
+ Database/Beam/Migrate/Types/CheckedEntities.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Checked database types+module Database.Beam.Migrate.Types.CheckedEntities where++import Database.Beam+import Database.Beam.Schema.Tables++import Database.Beam.Migrate.Types.Predicates+import Database.Beam.Migrate.Generics.Tables+import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.Checks++import Control.Applicative+import Control.Monad.Writer+import Control.Monad.Identity++import Data.Proxy+import Data.Text (Text)+import Data.String++import GHC.Types+import GHC.Generics++-- * Checked Database Entities++-- | Like 'IsDatabaseEntity' in @beam-core@, but for entities against which we+-- can generate 'DatabasePredicate's. Conceptually, this is the same as+-- 'IsDatabaseEntity', but with one extra function to generate+-- 'DatabasePredicate's from the description.+class IsDatabaseEntity be entity => IsCheckedDatabaseEntity be entity where+ -- | The type of the descriptor for this checked entity. Usually this wraps+ -- the corresponding 'DatabaseEntityDescriptor' from 'IsDatabaseEntity', along+ -- with some mechanism for generating 'DatabasePredicate's.+ data CheckedDatabaseEntityDescriptor be entity :: *++ -- | Like 'DatabaseEntityDefaultRequirements' but for checked entities+ type CheckedDatabaseEntityDefaultRequirements be entity syntax :: Constraint++ -- | Produce the corresponding 'DatabaseEntityDescriptior'+ unCheck :: CheckedDatabaseEntityDescriptor be entity -> DatabaseEntityDescriptor be entity++ -- | Produce the set of 'DatabasePredicate's that apply to this entity+ collectEntityChecks :: CheckedDatabaseEntityDescriptor be entity -> [ SomeDatabasePredicate ]++ -- | Like 'dbEntityAuto' but for checked databases. Most often, this wraps+ -- 'dbEntityAuto' and provides some means to generate 'DatabasePredicate's+ checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements be entity syntax+ => Proxy syntax -> Text -> CheckedDatabaseEntityDescriptor be entity++-- | Like 'DatabaseEntity' but for checked databases+data CheckedDatabaseEntity be (db :: (* -> *) -> *) entityType where+ CheckedDatabaseEntity :: IsCheckedDatabaseEntity be entityType+ => CheckedDatabaseEntityDescriptor be entityType+ -> [ SomeDatabasePredicate ]+ -> CheckedDatabaseEntity be db entityType++-- | The type of a checked database descriptor. Conceptually, this is just a+-- 'DatabaseSettings' with a set of predicates. Use 'unCheckDatabase' to get the+-- regular 'DatabaseSettings' object and 'collectChecks' to access the+-- predicates.+type CheckedDatabaseSettings be db = db (CheckedDatabaseEntity be db)++-- | Convert a 'CheckedDatabaseSettings' to a regular 'DatabaseSettings'. The+-- return value is suitable for use in any regular beam query or DML statement.+unCheckDatabase :: forall be db. Database db => CheckedDatabaseSettings be db -> DatabaseSettings be db+unCheckDatabase db = runIdentity $ zipTables (Proxy @be) (\(CheckedDatabaseEntity x _) _ -> pure $ DatabaseEntity (unCheck x)) db db++-- | A @beam-migrate@ database schema is defined completely by the set of+-- predicates that apply to it. This function allows you to access this+-- definition for a 'CheckedDatabaseSettings' object.+collectChecks :: forall be db. Database db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ]+collectChecks db = let (_ :: CheckedDatabaseSettings be db, a) =+ runWriter $ zipTables (Proxy @be)+ (\(CheckedDatabaseEntity entity cs :: CheckedDatabaseEntity be db entityType) b ->+ do tell (collectEntityChecks entity)+ tell cs+ pure b) db db+ in a++instance IsCheckedDatabaseEntity be (DomainTypeEntity ty) where+ data CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty) =+ CheckedDatabaseDomainType (DatabaseEntityDescriptor be (DomainTypeEntity ty))+ [ DomainCheck ]+ type CheckedDatabaseEntityDefaultRequirements be (DomainTypeEntity ty) syntax =+ DatabaseEntityDefaultRequirements be (DomainTypeEntity ty)++ unCheck (CheckedDatabaseDomainType x _) = x+ collectEntityChecks (CheckedDatabaseDomainType (DatabaseDomainType domName) domainChecks) =+ map (\(DomainCheck mkCheck) -> mkCheck domName) domainChecks+ checkedDbEntityAuto _ domTypeName =+ CheckedDatabaseDomainType (dbEntityAuto domTypeName) []++instance Beamable tbl => IsCheckedDatabaseEntity be (TableEntity tbl) where+ data CheckedDatabaseEntityDescriptor be (TableEntity tbl) where+ CheckedDatabaseTable :: Table tbl+ => DatabaseEntityDescriptor be (TableEntity tbl)+ -> [ TableCheck ]+ -> tbl (Const [FieldCheck])+ -> CheckedDatabaseEntityDescriptor be (TableEntity tbl)++ type CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl) syntax =+ ( DatabaseEntityDefaultRequirements be (TableEntity tbl)+ , Generic (tbl (Const [FieldCheck]))+ , GMigratableTableSettings syntax (Rep (tbl Identity)) (Rep (tbl (Const [FieldCheck])))+ , IsSql92DdlCommandSyntax syntax )++ unCheck (CheckedDatabaseTable x _ _) = x++ collectEntityChecks (CheckedDatabaseTable (DatabaseTable tbl tblFields) tblChecks tblFieldChecks) =+ map (\(TableCheck mkCheck) -> mkCheck tbl tblFields) tblChecks <>+ execWriter (zipBeamFieldsM (\(Columnar' (TableField fieldNm)) c@(Columnar' (Const fieldChecks)) ->+ tell (map (\(FieldCheck mkCheck) -> mkCheck tbl fieldNm) fieldChecks) >>+ pure c)+ tblFields tblFieldChecks)++ checkedDbEntityAuto syntax tblTypeName =+ let tblChecks =+ [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableExistsPredicate tblName))+ , TableCheck (\tblName tblFields ->+ let pkFields = allBeamValues (\(Columnar' (TableField x)) -> x) (primaryKey tblFields)+ in SomeDatabasePredicate (TableHasPrimaryKey tblName pkFields)) ]++ fieldChecks = to (gDefaultTblSettingsChecks syntax (Proxy @(Rep (tbl Identity))) False)+ in CheckedDatabaseTable (dbEntityAuto tblTypeName) tblChecks fieldChecks++-- | Purposefully opaque type describing how to modify a table field. Used to+-- parameterize the second argument to 'modifyCheckedTable'. For now, the only+-- way to construct a value is the 'IsString' instance, which allows you to+-- rename the field.+data CheckedFieldModification tbl a+ = CheckedFieldModification+ (TableField tbl a -> TableField tbl a)+ ([FieldCheck] -> [FieldCheck])++instance IsString (CheckedFieldModification tbl a) where+ fromString s = CheckedFieldModification (const . TableField . fromString $ s) id++instance Beamable tbl => RenamableWithRule (tbl (CheckedFieldModification tbl)) where+ renamingFields renamer =+ runIdentity $+ zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->+ pure (Columnar' (CheckedFieldModification (renameField (Proxy @(TableField tbl)) (Proxy @x) renamer) id :: CheckedFieldModification tbl x) ::+ Columnar' (CheckedFieldModification tbl) x))+ (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl)++-- | Modify a checked table.+--+-- The first argument is a function that takes the original table name as+-- input and produces a new table name.+--+-- The second argument gives instructions on how to rename each field in the+-- table. Use 'checkedTableModification' to create a value of this type which+-- does no renaming. Each field in the table supplied here has the type+-- 'CheckedFieldModification'. Most commonly, the programmer will use the+-- @OverloadedStrings@ instance to provide a new name.+--+-- == Examples+--+-- Rename a table, without renaming any of its fields:+--+-- @+-- modifyCheckedTable (\_ -> "NewTblNm") checkedTableModification+-- @+--+-- Modify a table, renaming the field called @_field1@ in Haskell to+-- "FirstName". Note that below, @"FirstName"@ represents a+-- 'CheckedFieldModification' object.+--+-- @+-- modifyCheckedTable id (checkedTableModification { _field1 = "FirstName" })+-- @++modifyCheckedTable+ :: ( Text -> Text )+ -> tbl (CheckedFieldModification tbl)+ -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl)+modifyCheckedTable renamer modFields =+ EntityModification (\(CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable nm fields) tblChecks fieldChecks) extraChecks) ->+ let fields' = runIdentity $+ zipBeamFieldsM (\(Columnar' (CheckedFieldModification fieldMod _)) (Columnar' field) ->+ pure $ Columnar' (fieldMod field))+ modFields fields+ fieldChecks' = runIdentity $+ zipBeamFieldsM (\(Columnar' (CheckedFieldModification _ csMod)) (Columnar' (Const cs)) ->+ pure $ Columnar' (Const (csMod cs)))+ modFields fieldChecks+ in CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable (renamer nm) fields') tblChecks fieldChecks') extraChecks)++-- | Produce a table field modification that does nothing+--+-- Most commonly supplied as the second argument to 'modifyCheckedTable' when+-- you just want to rename the table, not the fields.+checkedTableModification :: forall tbl. Beamable tbl => tbl (CheckedFieldModification tbl)+checkedTableModification =+ runIdentity $+ zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->+ pure (Columnar' (CheckedFieldModification id id :: CheckedFieldModification tbl x)))+ (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl)
+ Database/Beam/Migrate/Types/Predicates.hs view
@@ -0,0 +1,100 @@+-- | Common 'DatabasePredicate's used for defining schemas+module Database.Beam.Migrate.Types.Predicates where++import Database.Beam++import Control.DeepSeq++import Data.Aeson+import Data.Text (Text)+import Data.Hashable+import Data.Typeable++-- * Predicates++-- | A predicate is a type that describes some condition that the database+-- schema must meet. Beam represents database schemas as the set of all+-- predicates that apply to a database schema. The 'Hashable' and 'Eq' instances+-- allow us to build 'HashSet's of predicates to represent schemas in this way.+class (Typeable p, Hashable p, Eq p) => DatabasePredicate p where+ -- | An english language description of this predicate. For example, "There is+ -- a table named 'TableName'"+ englishDescription :: p -> String++ -- | Whether or not this predicate applies to all backends or only one+ -- backend. This is used when attempting to translate schemas between+ -- backends. If you are unsure, provide 'PredicateSpecificityOnlyBackend'+ -- along with an identifier unique to your backend.+ predicateSpecificity :: proxy p -> PredicateSpecificity++ -- | Serialize a predicate to a JSON 'Value'.+ serializePredicate :: p -> Value++ -- | Some predicates require other predicates to be true. For example, in+ -- order for a table to have a column, that table must exist. This function+ -- takes in the current predicate and another arbitrary database predicate. It+ -- should return 'True' if this predicate needs the other predicate to be true+ -- in order to exist.+ --+ -- By default, this simply returns 'False', which makes sense for many+ -- predicates.+ predicateCascadesDropOn :: DatabasePredicate p' => p -> p' -> Bool+ predicateCascadesDropOn _ _ = False++-- | A Database predicate is a value of any type which satisfies+-- 'DatabasePredicate'. We often want to store these in lists and sets, so we+-- need a monomorphic container that can store these polymorphic values.+data SomeDatabasePredicate where+ SomeDatabasePredicate :: DatabasePredicate p =>+ p -> SomeDatabasePredicate++instance NFData SomeDatabasePredicate where+ rnf p' = p' `seq` ()++instance Show SomeDatabasePredicate where+ showsPrec _ (SomeDatabasePredicate p') =+ ('(':) . shows (typeOf p') . (": " ++) . (englishDescription p' ++) . (')':)+instance Eq SomeDatabasePredicate where+ SomeDatabasePredicate a == SomeDatabasePredicate b =+ case cast a of+ Nothing -> False+ Just a' -> a' == b+instance Hashable SomeDatabasePredicate where+ hashWithSalt salt (SomeDatabasePredicate p') = hashWithSalt salt (typeOf p', p')++-- | Some predicates make sense in any backend. Others only make sense in one.+-- This denotes the difference.+data PredicateSpecificity+ = PredicateSpecificityOnlyBackend String+ | PredicateSpecificityAllBackends+ deriving (Show, Eq, Generic)+instance Hashable PredicateSpecificity++instance ToJSON PredicateSpecificity where+ toJSON PredicateSpecificityAllBackends = "all"+ toJSON (PredicateSpecificityOnlyBackend s) = object [ "backend" .= toJSON s ]+instance FromJSON PredicateSpecificity where+ parseJSON "all" = pure PredicateSpecificityAllBackends+ parseJSON (Object o) = PredicateSpecificityOnlyBackend <$> o .: "backend"+ parseJSON _ = fail "PredicateSource"++-- | Convenience synonym for 'SomeDatabasePredicate'+p :: DatabasePredicate p => p -> SomeDatabasePredicate+p = SomeDatabasePredicate++-- * Entity checks+--+-- When building checked database schemas, oftentimes the names of entities+-- may change. For example, a 'defaulMigratableDbSettings' object can have its+-- tables renamed. The checks need to update in order to reflect these name+-- changes. The following types represent predicates whose names have not yet+-- been determined.++-- | A predicate that depends on the name of a table as well as its fields+newtype TableCheck = TableCheck (forall tbl. Table tbl => Text -> tbl (TableField tbl) -> SomeDatabasePredicate)++-- | A predicate that depends on the name of a domain type+newtype DomainCheck = DomainCheck (Text -> SomeDatabasePredicate)++-- | A predicate that depedns on the name of a table and one of its fields+newtype FieldCheck = FieldCheck (Text -> Text -> SomeDatabasePredicate)
+ LICENSE view
@@ -0,0 +1,8 @@+The MIT License (MIT)+Copyright (c) 2017-2018 Travis Athougies++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ beam-migrate.cabal view
@@ -0,0 +1,104 @@+-- Initial beam-migrate.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: beam-migrate+version: 0.2.0.0+synopsis: SQL DDL support and migrations support library for Beam+description: This package provides type classes to allow backends to implement+ SQL DDL support for beam. This allows you to use beam syntax to+ write type-safe schema generation code.++ The package also provides features to introspect beam schemas,+ and support for automatic generation of migrations in SQL and+ Haskell formats.++ This is mostly a low-level support library. Most often, this+ library is used to write tooling to support DDL manipulation in+ your project, or to enable migrations support in beam backends.++ For a more turnkey solution for database migrations, consider+ the <http://hackage.haskell.org/package/beam-migrate-cli beam-migrate>+ command line tool. This provides out-of-the-box support for migrations,+ schema change management, and version control, based on the features+ provided in this library.++homepage: https://travis.athougies.net/projects/beam.html+license: MIT+license-file: LICENSE+author: Travis Athougies+maintainer: travis@athougies.net+copyright: Copyright (C) 2017-2018 Travis Athougies+category: Database+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Database.Beam.Migrate++ Database.Beam.Migrate.Types+ Database.Beam.Migrate.Checks+ Database.Beam.Migrate.Actions+ Database.Beam.Migrate.Backend+ Database.Beam.Migrate.Serialization++ Database.Beam.Migrate.SQL+ Database.Beam.Migrate.SQL.Builder+ Database.Beam.Migrate.SQL.Tables+ Database.Beam.Migrate.SQL.SQL92+ Database.Beam.Migrate.SQL.BeamExtensions++ Database.Beam.Migrate.Generics++ Database.Beam.Migrate.Simple++ Database.Beam.Haskell.Syntax++ other-modules: Database.Beam.Migrate.Generics.Types+ Database.Beam.Migrate.Generics.Tables+ Database.Beam.Migrate.SQL.Types+ Database.Beam.Migrate.Types.CheckedEntities+ Database.Beam.Migrate.Types.Predicates+ -- other-extensions: + build-depends: base >=4.9 && <4.11,+ beam-core ==0.6.0.0,+ text >=1.2 && <1.3,+ aeson >=0.11 && <1.3,+ bytestring >=0.10 && <0.11,+ free >=4.12 && <4.13,+ time >=1.6 && <1.10,+ mtl >=2.2 && <2.3,+ scientific >=0.3 && <0.4,+ vector >=0.11 && <0.13,+ containers >=0.5 && <0.6,+ unordered-containers >=0.2 && <0.3,+ hashable >=1.2 && <1.3,+ parallel >=3.2 && <3.3,+ deepseq >=1.4 && <1.5,+ ghc-prim >=0.5 && <0.6,+ containers >=0.5 && <0.6,+ haskell-src-exts >=1.18 && <1.20,+ pretty >=1.1 && <1.2,+ dependent-map >=0.2 && <0.3,+ dependent-sum >=0.4 && <0.5,+ pqueue >=1.3 && <1.4+ -- hs-source-dirs: + default-language: Haskell2010+ default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts,+ StandaloneDeriving, GADTs, DeriveFunctor, RankNTypes, ScopedTypeVariables,+ FlexibleInstances, TypeOperators, TypeApplications, MultiParamTypeClasses,+ DataKinds, DeriveGeneric+ ghc-options: -Wall+ if flag(werror)+ ghc-options: -Werror++flag werror+ description: Enable -Werror during development+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/tathougies/beam.git+ subdir: beam-migrate+