ihp-schema-compiler (empty) → 1.5.0
raw patch · 7 files changed
+1813/−0 lines, 7 filesdep +basedep +bytestringdep +classy-prelude
Dependencies added: base, bytestring, classy-prelude, countable-inflections, directory, filepath, ihp, ihp-postgres-parser, ihp-schema-compiler, interpolate, neat-interpolation, split, string-conversions, text, with-utf8
Files
- IHP/SchemaCompiler.hs +1637/−0
- IHP/SchemaCompiler/Parser.hs +21/−0
- LICENSE +21/−0
- changelog.md +16/−0
- data/IHPSchema.sql +10/−0
- exe/IHP/CLI/BuildGeneratedCode.hs +14/−0
- ihp-schema-compiler.cabal +94/−0
+ IHP/SchemaCompiler.hs view
@@ -0,0 +1,1637 @@+module IHP.SchemaCompiler+( compile+, compileStatementPreview+, compileStatementPreviewWith+, CompilerOptions(..)+, fullCompileOptions+, previewCompilerOptions+, compileCreateStatement+, compileUpdateStatement+, compileFetchByIdStatement+, compileCreateManyStatement+, compileRowDecoderModule+, Schema(..)+) where++import ClassyPrelude+import Data.Bits (bit)+import Data.Maybe (fromJust)+import Data.String.Conversions (cs)+import "interpolate" Data.String.Interpolate (i)+import IHP.NameSupport (tableNameToModelName, columnNameToFieldName, enumValueToControllerName)+import qualified Data.Text as Text+import qualified System.Directory.OsPath as Directory+import IHP.HaskellSupport+import qualified IHP.SchemaCompiler.Parser as SchemaDesigner+import qualified IHP.Postgres.Parser as PostgresParser+import IHP.Postgres.Types+import qualified Control.Exception as Exception+import qualified System.Environment+import NeatInterpolation+import Text.Countable (pluralize)+import System.OsPath (OsPath, encodeUtf, decodeUtf)+import qualified System.OsPath as OsPath+++data CompileException = CompileException ByteString deriving (Show)+instance Exception CompileException where+ displayException (CompileException message) = cs message++compile :: IO ()+compile = do+ relationSupport <- System.Environment.lookupEnv "IHP_RELATION_SUPPORT"+ let options = fullCompileOptions { compileRelationSupport = relationSupport /= Just "0" }+ SchemaDesigner.parseSchemaSql >>= \case+ Left parserError -> Exception.throwIO (CompileException parserError)+ Right statements -> do+ -- let validationErrors = validate database+ -- unless (null validationErrors) (error $ "Schema.hs contains errors: " <> cs (unsafeHead validationErrors))+ Directory.createDirectoryIfMissing True "build/Generated"+ Directory.createDirectoryIfMissing True "build/Generated/ActualTypes"+ Directory.createDirectoryIfMissing True "build/Generated/Statements"++ forEach (compileModules options (Schema statements)) \(path, body) -> do+ writeIfDifferent path body++compileModules :: CompilerOptions -> Schema -> [(OsPath, Text)]+compileModules options schema =+ let ?compilerOptions = options+ in [ ("build/Generated/Enums.hs", compileEnums options schema)+ , ("build/Generated/ActualTypes/PrimaryKeys.hs", compilePrimaryKeysModule schema)+ ]+ <> actualTypesTableModules schema+ <> [ ("build/Generated/ActualTypes.hs", compileTypes options schema) ]+ <> tableModules options schema+ <> statementModules schema+ <> [ ("build/Generated/Statements.hs", compileStatementsIndex schema)+ , ("build/Generated/Types.hs", compileIndex schema)+ ]++applyTables :: (CreateTable -> (OsPath, Text)) -> Schema -> [(OsPath, Text)]+applyTables applyFunction schema =+ let ?schema = schema+ in+ schema.statements+ |> mapMaybe (\case+ StatementCreateTable table | tableHasPrimaryKey table -> Just (applyFunction table)+ otherwise -> Nothing+ )++actualTypesTableModules :: (?compilerOptions :: CompilerOptions) => Schema -> [(OsPath, Text)]+actualTypesTableModules schema =+ let ?schema = schema+ in applyTables actualTypesTableModule schema++actualTypesTableModule :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> (OsPath, Text)+actualTypesTableModule table =+ ((OsPath.</>) "build/Generated/ActualTypes" (either (error . show) id (encodeUtf (cs (tableNameToModelName table.name) <> ".hs"))), body)+ where+ body = Text.unlines+ [ prelude+ , compileActualTypesForTable table+ ]+ moduleName = "Generated.ActualTypes." <> tableNameToModelName table.name+ prelude = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving #-}+ {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches -Wno-ambiguous-fields #-}+ module $moduleName where+ $defaultImports+ import Generated.Enums+ import Generated.ActualTypes.PrimaryKeys+ |]++tableModules :: (?compilerOptions :: CompilerOptions) => CompilerOptions -> Schema -> [(OsPath, Text)]+tableModules options schema =+ let ?schema = schema+ in+ applyTables (tableModule options) schema+ <> if options.compileRelationSupport+ then applyTables tableIncludeModule schema+ else []++tableModule :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CompilerOptions -> CreateTable -> (OsPath, Text)+tableModule options table =+ ((OsPath.</>) "build/Generated" (either (error . show) id (encodeUtf (cs (tableNameToModelName table.name) <> ".hs"))), body)+ where+ body = Text.unlines+ [ prelude+ , tableModuleBody options table+ ]+ moduleName = "Generated." <> tableNameToModelName table.name+ modelName = tableNameToModelName table.name+ statementImports = Text.unlines+ [ "import qualified Generated.Statements.RowDecoder" <> modelName+ , "import qualified Generated.Statements.Create" <> modelName+ , "import qualified Generated.Statements.Update" <> modelName+ , "import qualified Generated.Statements.CreateMany" <> modelName+ ]+ prelude = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving #-}+ {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches -Wno-ambiguous-fields #-}+ module $moduleName where+ $defaultImports+ import Generated.ActualTypes+ $statementImports+ |]++tableIncludeModule :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> (OsPath, Text)+tableIncludeModule table =+ ((OsPath.</>) "build/Generated" (either (error . show) id (encodeUtf (cs (tableNameToModelName table.name) <> "Include.hs"))), prelude <> compileInclude table)+ where+ moduleName = "Generated." <> tableNameToModelName table.name <> "Include"+ prelude = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ module $moduleName where+ import Generated.ActualTypes+ import IHP.ModelSupport (Include, GetModelById)+ |] <> "\n\n"+++tableModuleBody :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CompilerOptions -> CreateTable -> Text+tableModuleBody options table = Text.unlines $ filter (not . Text.null)+ [ compileInputValueInstance table+ , compileFromRowInstance table+ , compileFromRowHasqlInstance table+ , compileGetModelName table+ , compileCreate table+ , compileUpdate table+ , compileBuild table+ , compileFilterPrimaryKeyInstance table+ , if needsHasFieldId table+ then compileHasFieldId table+ else ""+ , if options.compileGetAndSetFieldInstances+ then compileSetFieldInstances table <> compileUpdateFieldInstances table+ else ""+ , compileFieldBitInstances table+ ]++newtype Schema = Schema { statements :: [Statement] }++data CompilerOptions = CompilerOptions {+ -- | We can toggle the generation of @SetField@ and @GetField@ instances.+ -- This is e.g. disabled when showing the code preview in the schema designer+ -- as it's very noisy and does not add any values. But of course it's needed+ -- when do a compilation for the Types.hs+ compileGetAndSetFieldInstances :: Bool,+ -- | When disabled, generates simpler types without Include\/fetchRelated type machinery.+ -- This removes type parameters from record types, removes has-many QueryBuilder fields,+ -- and skips generating Include modules. Set @IHP_RELATION_SUPPORT=0@ to disable.+ compileRelationSupport :: Bool+ }++fullCompileOptions :: CompilerOptions+fullCompileOptions = CompilerOptions { compileGetAndSetFieldInstances = True, compileRelationSupport = True }++previewCompilerOptions :: CompilerOptions+previewCompilerOptions = CompilerOptions { compileGetAndSetFieldInstances = False, compileRelationSupport = True }++atomicType :: PostgresType -> Text+atomicType = \case+ PSmallInt -> "Int"+ PInt -> "Int"+ PBigInt -> "Integer"+ PJSONB -> "Data.Aeson.Value"+ PText -> "Text"+ PBoolean -> "Bool"+ PTimestampWithTimezone -> "UTCTime"+ PUUID -> "UUID"+ PSerial -> "Int"+ PBigserial -> "Integer"+ PReal -> "Float"+ PDouble -> "Double"+ PDate -> "Data.Time.Calendar.Day"+ PBinary -> "(Binary ByteString)"+ PTime -> "TimeOfDay"+ (PInterval _) -> "Interval"+ PCustomType theType -> tableNameToModelName theType+ PTimestamp -> "LocalTime"+ (PNumeric _ _) -> "Scientific"+ (PVaryingN _) -> "Text"+ (PCharacterN _) -> "Text"+ PArray type_ -> "[" <> atomicType type_ <> "]"+ PPoint -> "Point"+ PPolygon -> "Polygon"+ PInet -> "Inet"+ PTSVector -> "Tsvector"+ PSingleChar -> "Text"+ PTrigger -> error "atomicType: PTrigger not supported"+ PEventTrigger -> error "atomicType: PEventTrigger not supported"++haskellType :: (?schema :: Schema) => CreateTable -> Column -> Text+haskellType table@CreateTable { name = tableName, primaryKeyConstraint } column@Column { name, columnType, notNull, generator }+ | [name] == primaryKeyColumnNames primaryKeyConstraint = "(" <> primaryKeyTypeName tableName <> ")"+ | otherwise =+ let+ actualType =+ case findForeignKeyConstraint table column of+ Just fk@(ForeignKeyConstraint { referenceTable, referenceColumn })+ | isForeignKeyReferencingPK fk -> "(" <> primaryKeyTypeName referenceTable <> ")"+ | otherwise ->+ -- FK references a non-PK column; use the referenced column's actual type+ case referenceColumn >>= \refCol -> findTableByName referenceTable >>= \t -> find (\c -> c.name == refCol) t.columns of+ Just refColumn -> atomicType refColumn.columnType+ Nothing -> atomicType columnType+ _ -> atomicType columnType+ in+ if not notNull || isJust generator+ then "(Maybe " <> actualType <> ")"+ else actualType+-- haskellType table (HasMany {name}) = "(QueryBuilder.QueryBuilder " <> tableNameToModelName name <> ")"+++writeIfDifferent :: OsPath -> Text -> IO ()+writeIfDifferent path content = do+ fp <- decodeUtf path+ alreadyExists <- Directory.doesFileExist path+ existingContent <- if alreadyExists then readFile fp else pure ""+ when (existingContent /= cs content) do+ putStrLn $ "Updating " <> cs fp+ writeFile fp (cs content)++compileTypes :: (?compilerOptions :: CompilerOptions) => CompilerOptions -> Schema -> Text+compileTypes options schema@(Schema statements) = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-}+ module Generated.ActualTypes ($rexports) where+ import Generated.Enums+ import Generated.ActualTypes.PrimaryKeys+ $perTableImports+ |]+ where+ tableModelNames =+ statements+ |> mapMaybe (\case+ StatementCreateTable table | tableHasPrimaryKey table -> Just (tableNameToModelName table.name)+ otherwise -> Nothing+ )++ perTableModuleNames = map (\n -> "Generated.ActualTypes." <> n) tableModelNames++ perTableImports = perTableModuleNames+ |> map (\n -> "import " <> n)+ |> Text.unlines++ rexports = ("module Generated.Enums" : "module Generated.ActualTypes.PrimaryKeys" : map (\n -> "module " <> n) perTableModuleNames)+ |> Text.intercalate ", "++compileActualTypesForTable :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileActualTypesForTable table = Text.unlines+ [ compileData table+ , compileTypeAlias table+ , compileHasTableNameInstance table+ , compileTableInstance table+ ]++-- | Like 'compileActualTypesForTable' but includes PrimaryKey and Default Id' instances inline.+-- Used by 'compileStatementPreviewWith' so the IDE preview and tests see a self-contained output.+compileActualTypesForTablePreview :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileActualTypesForTablePreview table = Text.unlines+ [ compileData table+ , compilePrimaryKeyInstance table+ , compileTypeAlias table+ , compileHasTableNameInstance table+ , compileDefaultIdInstance table+ , compileTableInstance table+ ]++compileIndex :: (?compilerOptions :: CompilerOptions) => Schema -> Text+compileIndex schema = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ module Generated.Types ($rexports) where+ import Generated.ActualTypes+ $tableModuleImports+ |]+ where+ tableModuleNames =+ schema.statements+ |> map (\case+ StatementCreateTable table ->+ let modelName = tableNameToModelName table.name+ in+ [ "Generated." <> modelName ]+ <> if ?compilerOptions.compileRelationSupport+ then [ "Generated." <> modelName <> "Include" ]+ else []+ otherwise -> []+ )+ |> concat+ tableModuleImports = tableModuleNames+ |> map (\name -> "import " <> name)+ |> Text.unlines++ rexportedModules = ["Generated.ActualTypes"] <> tableModuleNames++ rexports = rexportedModules+ |> map (\moduleName -> "module " <> moduleName)+ |> Text.intercalate ", "+++defaultImports = [trimming|+ import IHP.HaskellSupport+ import IHP.ModelSupport+ import CorePrelude hiding (id)+ import Data.Time.Clock+ import Data.Time.LocalTime+ import qualified Data.Time.Calendar+ import qualified Data.List as List+ import qualified Data.ByteString as ByteString+ import Database.PostgreSQL.Simple+ import Database.PostgreSQL.Simple.FromRow+ import Database.PostgreSQL.Simple.FromField hiding (Field, name)+ import Database.PostgreSQL.Simple.ToField hiding (Field)+ import qualified IHP.Controller.Param+ import GHC.TypeLits+ import Data.UUID (UUID)+ import Data.Default+ import qualified IHP.QueryBuilder as QueryBuilder+ import qualified Data.Proxy+ import GHC.Records+ import Data.Data+ import qualified Data.String.Conversions+ import qualified Data.Text.Encoding+ import qualified Data.Aeson+ import Database.PostgreSQL.Simple.Types (Query (Query), Binary ( .. ))+ import qualified Database.PostgreSQL.Simple.Types+ import IHP.Job.Types+ import IHP.Job.Queue (textToEnumJobStatus)+ import qualified Control.DeepSeq as DeepSeq+ import qualified Data.Dynamic+ import Data.Scientific+ import IHP.Hasql.FromRow (FromRowHasql(..))+ import qualified Hasql.Decoders as Decoders+ import qualified Hasql.Encoders+ import qualified Hasql.Implicits.Encoders+ import IHP.Hasql.Encoders ()+ import qualified Hasql.Mapping.IsScalar as Mapping+ import Hasql.PostgresqlTypes ()+ import Data.Bits ((.&.), (.|.))+ import Control.Monad (unless)+|]++++compileEnums :: CompilerOptions -> Schema -> Text+compileEnums options schema@(Schema statements) = Text.unlines+ [ prelude+ , let ?schema = schema+ in intercalate "\n\n" (mapMaybe compileStatement statements)+ ]+ where+ compileStatement enum@(CreateEnumType {}) = Just (compileEnumDataDefinitions enum)+ compileStatement _ = Nothing+ prelude = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ module Generated.Enums where+ import CorePrelude+ import IHP.ModelSupport+ import Database.PostgreSQL.Simple+ import Database.PostgreSQL.Simple.FromField hiding (Field, name)+ import Database.PostgreSQL.Simple.ToField hiding (Field)+ import qualified IHP.Controller.Param+ import Data.Default+ import qualified IHP.QueryBuilder as QueryBuilder+ import qualified Data.String.Conversions+ import qualified Data.Text.Encoding+ import qualified Control.DeepSeq as DeepSeq+ import qualified Hasql.Encoders+ import qualified Hasql.Decoders+ import qualified Hasql.Implicits.Encoders+ import qualified Hasql.Mapping.IsScalar as Mapping+ import qualified Data.HashMap.Strict as HashMap+ |]++compilePrimaryKeysModule :: (?compilerOptions :: CompilerOptions) => Schema -> Text+compilePrimaryKeysModule schema@(Schema statements) =+ let ?schema = schema+ in Text.unlines+ [ prelude+ , statements+ |> mapMaybe (\case+ StatementCreateTable table | tableHasPrimaryKey table ->+ Just (compilePrimaryKeyInstance table <> compileDefaultIdInstance table)+ _ -> Nothing)+ |> Text.intercalate "\n"+ ]+ where+ prelude = [trimming|+ -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"+ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving #-}+ {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-}+ module Generated.ActualTypes.PrimaryKeys where+ $defaultImports+ import Generated.Enums+ |]++compileStatementPreview :: [Statement] -> Statement -> Text+compileStatementPreview = compileStatementPreviewWith previewCompilerOptions++compileStatementPreviewWith :: CompilerOptions -> [Statement] -> Statement -> Text+compileStatementPreviewWith options statements statement =+ let ?schema = Schema statements+ ?compilerOptions = options+ in+ case statement of+ CreateEnumType {} -> compileEnumDataDefinitions statement+ StatementCreateTable table -> Text.unlines+ [ compileActualTypesForTablePreview table+ , tableModuleBody options table+ ]+ _ -> ""++-- | Skip generation of tables with no primary keys+tableHasPrimaryKey :: CreateTable -> Bool+tableHasPrimaryKey table = table.primaryKeyConstraint /= (PrimaryKeyConstraint [])++compileTypeAlias :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileTypeAlias table@(CreateTable { name, columns }) =+ "type "+ <> modelName+ <> " = "+ <> modelName+ <> "'"+ <> spacePrefix (unwords (map (haskellType table) (variableAttributes table)) <> hasManyDefaults)+ <> "\n"+ where+ modelName = tableNameToModelName name+ hasManyDefaults+ | ?compilerOptions.compileRelationSupport =+ columnsReferencingTable name+ |> map (\(tableName, columnName, _) -> "(QueryBuilder.QueryBuilder \"" <> tableName <> "\")")+ |> unwords+ | otherwise = ""++primaryKeyTypeName :: Text -> Text+primaryKeyTypeName name = "Id' " <> tshow name <> ""++compileData :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileData table@(CreateTable { name, columns }) =+ "data " <> modelName <> "'" <> spacePrefix typeArguments+ <> " = " <> modelName <> " {"+ <>+ table+ |> dataFields+ |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType)+ |> commaSep+ <> "} deriving (Eq, Show)\n"+ where+ modelName = tableNameToModelName name+ typeArguments :: Text+ typeArguments = dataTypeArguments table |> unwords++compileInputValueInstance :: CreateTable -> Text+compileInputValueInstance table =+ "instance InputValue " <> modelName <> " where inputValue = IHP.ModelSupport.recordToInputValue\n"+ where+ modelName = qualifiedConstructorNameFromTableName table.name++-- | Returns all the type arguments of the data structure for an entity+dataTypeArguments :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> [Text]+dataTypeArguments table+ | not ?compilerOptions.compileRelationSupport = []+ | otherwise = (map columnNameToFieldName belongsToVariables) <> hasManyVariables+ where+ belongsToVariables = variableAttributes table |> map (.name)+ hasManyVariables =+ columnsReferencingTable table.name+ |> compileQueryBuilderFields+ |> map snd++-- | Returns the field names and types for the @data MyRecord = MyRecord { .. }@ for a given table+dataFields :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> [(Text, Text)]+dataFields table@(CreateTable { name }) = columnFields <> queryBuilderFields <> [("meta", "MetaBag")]+ where+ columns = allColumnsIncludingInherited table+ columnFields = columns |> map columnField++ columnField column =+ let fieldName = columnNameToFieldName column.name+ in+ ( fieldName+ , if isVariableAttribute table column+ then fieldName+ else haskellType table column+ )++ queryBuilderFields+ | ?compilerOptions.compileRelationSupport = columnsReferencingTable name |> compileQueryBuilderFields+ | otherwise = []++fieldBitPositions :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> [(Text, Integer)]+fieldBitPositions table =+ let columns = allColumnsIncludingInherited table+ in zip (map (columnNameToFieldName . (.name)) columns) (map bit [0..])++columnsWithBitIndices :: [Column] -> [Column] -> [(Column, Int)]+columnsWithBitIndices allColumns subset =+ let subsetNames = setFromList (map (.name) subset) :: Set Text+ in [(col, idx) | (col, idx) <- zip allColumns [0..], col.name `member` subsetNames]++compileQueryBuilderFields :: [(Text, Text, Maybe Text)] -> [(Text, Text)]+compileQueryBuilderFields columns = map compileQueryBuilderField columns+ where+ compileQueryBuilderField (refTableName, refColumnName, _refColumn) =+ let+ -- Given a relationship like the following:+ --+ -- CREATE TABLE referrals (+ -- user_id UUID NOT NULL,+ -- referred_user_id UUID DEFAULT uuid_generate_v4() NOT NULL+ -- );+ --+ -- We would have two fields on the @User@ record called @referrals@ which are+ -- going to be used with fetchRelated (user >>= fetchRelated #referrals).+ --+ -- Of course having two fields in the same record does not work, so we have to+ -- detect these duplicate query builder fields and use a more qualified name.+ --+ -- In the example this will lead to two fileds called @referralsUsers@ and @referralsReferredUsers@+ -- being added to the data structure.+ hasDuplicateQueryBuilder =+ columns+ |> map (\(t, _, _) -> t)+ |> map columnNameToFieldName+ |> filter (columnNameToFieldName refTableName ==)+ |> length+ |> (\count -> count > 1)++ stripIdSuffix :: Text -> Text+ stripIdSuffix name = fromMaybe name (Text.stripSuffix "_id" name)++ fieldName = if hasDuplicateQueryBuilder+ then+ (refTableName <> "_" <> (refColumnName |> stripIdSuffix))+ |> columnNameToFieldName+ |> pluralize+ else columnNameToFieldName refTableName+ in+ (fieldName, fieldName)+++-- | Finds all the columns referencing a specific table via a foreign key constraint+--+-- __Example:__+--+-- Given the schema:+--+-- > CREATE TABLE users (id SERIAL, company_id INT);+-- > CREATE TABLE companies (id SERIAL);+--+-- you can do the following:+--+-- >>> columnsReferencingTable "companies"+-- [ ("users", "company_id") ]+columnsReferencingTable :: (?schema :: Schema) => Text -> [(Text, Text, Maybe Text)]+columnsReferencingTable theTableName =+ let+ (Schema statements) = ?schema+ in+ statements+ |> mapMaybe \case+ AddConstraint { tableName, constraint = fk@ForeignKeyConstraint { columnName, referenceTable, referenceColumn } } | referenceTable == theTableName && isForeignKeyReferencingPK fk -> Just (tableName, columnName, referenceColumn)+ _ -> Nothing++variableAttributes :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> [Column]+variableAttributes table = filter (isVariableAttribute table) (allColumnsIncludingInherited table)++isVariableAttribute :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Column -> Bool+isVariableAttribute table column+ | not ?compilerOptions.compileRelationSupport = False+ | otherwise = isRefCol table column+++-- | Returns @True@ when the column references another table's primary key via foreign key constraint.+-- FK constraints that reference a non-PK column (e.g., REFERENCES users(email)) return @False@,+-- because the relation machinery (Include, fetchRelated, QueryBuilder) only works for PK-based FKs.+isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool+isRefCol table column = case findForeignKeyConstraint table column of+ Just fk -> isForeignKeyReferencingPK fk+ Nothing -> False++-- | Returns the foreign key constraint bound on the given column.+-- For inherited columns, recursively checks ancestor table constraints.+findForeignKeyConstraint :: (?schema :: Schema) => CreateTable -> Column -> Maybe Constraint+findForeignKeyConstraint table@CreateTable { name, inherits } column =+ case find (isFkConstraint name) statements of+ Just (AddConstraint { constraint }) -> Just constraint+ _ -> case inherits >>= findTableByName of+ Just parentTable -> findForeignKeyConstraint parentTable column+ Nothing -> Nothing+ where+ isFkConstraint tableName (AddConstraint { tableName = tName, constraint = ForeignKeyConstraint { columnName }}) = tName == tableName && columnName == column.name+ isFkConstraint _ _ = False++ (Schema statements) = ?schema++-- | Finds a table by name in the schema+findTableByName :: (?schema :: Schema) => Text -> Maybe CreateTable+findTableByName tableName =+ let (Schema statements) = ?schema+ in statements+ |> mapMaybe (\case+ StatementCreateTable table@CreateTable { name } | name == tableName -> Just table+ _ -> Nothing)+ |> headMay++-- | Returns @True@ when a FK constraint references the primary key of the target table.+-- FK constraints pointing at non-PK columns (e.g., REFERENCES users(email)) return @False@.+isForeignKeyReferencingPK :: (?schema :: Schema) => Constraint -> Bool+isForeignKeyReferencingPK ForeignKeyConstraint { referenceTable, referenceColumn } =+ case referenceColumn of+ Just refCol -> refCol `elem` referencedPKColumns+ Nothing -> True+ where+ referencedPKColumns = case findTableByName referenceTable of+ Just t -> primaryKeyColumnNames t.primaryKeyConstraint+ Nothing -> []+isForeignKeyReferencingPK _ = False++-- | Returns all columns including inherited columns from parent tables.+-- Inherited columns that are not overridden in the child table are appended.+allColumnsIncludingInherited :: (?schema :: Schema) => CreateTable -> [Column]+allColumnsIncludingInherited CreateTable { columns, inherits = Nothing } = columns+allColumnsIncludingInherited CreateTable { columns, inherits = Just parentName } =+ case findTableByName parentName of+ Nothing -> columns+ Just parentTable ->+ let parentCols = allColumnsIncludingInherited parentTable+ childNames = map (.name) columns+ inherited = filter (\pc -> pc.name `notElem` childNames) parentCols+ in columns <> inherited++compileEnumDataDefinitions :: (?schema :: Schema) => Statement -> Text+compileEnumDataDefinitions CreateEnumType { values = [] } = "" -- Ignore enums without any values+compileEnumDataDefinitions enum@(CreateEnumType { name, values }) =+ "data " <> modelName <> " = " <> (intercalate " | " valueConstructors) <> " deriving (Eq, Show, Read, Enum, Bounded, Ord)\n"+ <> "instance FromField " <> modelName <> " where\n"+ <> indent (unlines (map compileFromFieldInstanceForValue values))+ <> " fromField field (Just value) = returnError ConversionFailed field (\"Unexpected value for enum value. Got: \" <> Data.String.Conversions.cs value)\n"+ <> " fromField field Nothing = returnError UnexpectedNull field \"Unexpected null for enum value\"\n"+ <> "instance Default " <> modelName <> " where def = " <> enumValueToConstructorName (unsafeHead values) <> "\n"+ <> "instance ToField " <> modelName <> " where\n" <> indent (unlines (map compileToFieldInstanceForValue values))+ <> "instance InputValue " <> modelName <> " where\n" <> indent (unlines (map compileInputValue values))+ <> "instance DeepSeq.NFData " <> modelName <> " where" <> " rnf a = seq a ()" <> "\n"+ <> "instance IHP.Controller.Param.ParamReader " <> modelName <> " where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON\n"+ -- textToEnum function for hasql decoder using HashMap for O(1) lookup+ <> "textToEnum" <> modelName <> "Map :: HashMap.HashMap Text " <> modelName <> "\n"+ <> "textToEnum" <> modelName <> "Map = HashMap.fromList [" <> intercalate ", " (map compileTextToEnumMapEntry values) <> "]\n"+ <> "textToEnum" <> modelName <> " :: Text -> Maybe " <> modelName <> "\n"+ <> "textToEnum" <> modelName <> " t = HashMap.lookup t textToEnum" <> modelName <> "Map\n"+ -- DefaultParamEncoder for hasql queries+ <> "instance Hasql.Implicits.Encoders.DefaultParamEncoder " <> modelName <> " where\n"+ <> " defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just \"public\") " <> tshow (Text.toLower name) <> " inputValue)\n"+ <> "instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe " <> modelName <> ") where\n"+ <> " defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just \"public\") " <> tshow (Text.toLower name) <> " inputValue)\n"+ <> "instance Hasql.Implicits.Encoders.DefaultParamEncoder [" <> modelName <> "] where\n"+ <> " defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just \"public\") " <> tshow (Text.toLower name) <> " inputValue)\n"+ -- IsScalar instance for hasql-mapping (used by generated statement modules)+ <> "instance Mapping.IsScalar " <> modelName <> " where\n"+ <> " encoder = Hasql.Encoders.enum (Just \"public\") " <> tshow (Text.toLower name) <> " inputValue\n"+ <> " decoder = Hasql.Decoders.enum (Just \"public\") " <> tshow (Text.toLower name) <> " textToEnum" <> modelName <> "\n"+ where+ modelName = tableNameToModelName name+ valueConstructors = map enumValueToConstructorName values++ enumValueToConstructorName :: Text -> Text+ enumValueToConstructorName enumValue = if isEnumValueUniqueInSchema enumValue+ then enumValueToControllerName enumValue+ else modelName <> (enumValueToControllerName enumValue)++ compileFromFieldInstanceForValue value = "fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 " <> tshow value <> ") = pure " <> enumValueToConstructorName value+ compileToFieldInstanceForValue value = "toField " <> enumValueToConstructorName value <> " = toField (" <> tshow value <> " :: Text)"+ compileInputValue value = "inputValue " <> enumValueToConstructorName value <> " = " <> tshow value <> " :: Text"+ compileTextToEnumMapEntry value = "(" <> tshow value <> ", " <> enumValueToConstructorName value <> ")"++ -- Let's say we have a schema like this:+ --+ -- > CREATE TYPE property_type AS ENUM ('APARTMENT', 'HOUSE');+ -- > CREATE TYPE apartment_type AS ENUM ('LOFT', 'APARTMENT');+ --+ -- A naive enum implementation will generate these data constructors:+ --+ -- > data PropertyType = Apartment | House+ -- > data ApartmentType = Loft | Apartment+ --+ -- Now we have two data constructors with the name 'Apartment'. This fails to compile.+ --+ -- To avoid this we detect if a name is unique across the schema. When it's not unique+ -- we use the following naming schema:+ --+ -- > data PropertyType = PropertyTypeApartment | House+ -- > data ApartmentType = Loft | ApartmentTypeApartment+ --+ -- This function returns True if the given enumValue (like 'APARTMENT') is unique across the schema.+ isEnumValueUniqueInSchema :: Text -> Bool+ isEnumValueUniqueInSchema enumValue =+ ?schema+ |> \case Schema statements -> statements+ |> filter (\case+ CreateEnumType { name, values } | enumValue `elem` values -> True+ _ -> False+ )+ |> length+ |> \count -> count == 1+compileEnumDataDefinitions _ = ""++qualifiedConstructorNameFromTableName :: Text -> Text+qualifiedConstructorNameFromTableName unqualifiedName = "Generated.ActualTypes." <> (tableNameToModelName unqualifiedName)++--+-- Trigger types don't have encoders as they're not real data columns.+hasqlSupportsColumnType :: PostgresType -> Bool+hasqlSupportsColumnType = \case+ PTrigger -> False+ PEventTrigger -> False+ (PArray inner) -> hasqlSupportsColumnType inner+ _ -> True++compileCreate :: (?schema :: Schema) => CreateTable -> Text+compileCreate table@(CreateTable { name }) =+ let+ columns = allColumnsIncludingInherited table+ writableColumns = onlyWritableColumns columns+ modelName = qualifiedConstructorNameFromTableName name+ funcName = tableNameToModelName name++ -- Hasql bodies+ isDynamic = hasAnyDefaults writableColumns+ hasqlCreateBody = if isDynamic+ then "let pool = ?modelContext.hasqlPool\n"+ <> "let touched = model.meta.touchedFields\n"+ <> "sqlStatementHasql pool model (Generated.Statements.Create" <> funcName <> ".statement touched)"+ else "let pool = ?modelContext.hasqlPool\n"+ <> "sqlStatementHasql pool model Generated.Statements.Create" <> funcName <> ".statement"+ hasqlCreateManyBody = "let pool = ?modelContext.hasqlPool\n"+ <> "sqlStatementHasql pool models (Generated.Statements.CreateMany" <> funcName <> ".statement (List.length models))"+ hasqlCreateDiscardBody = if isDynamic+ then "let pool = ?modelContext.hasqlPool\n"+ <> "let touched = model.meta.touchedFields\n"+ <> "sqlStatementHasql pool model (Generated.Statements.Create" <> funcName <> ".discardResultStatement touched)"+ else "let pool = ?modelContext.hasqlPool\n"+ <> "sqlStatementHasql pool model Generated.Statements.Create" <> funcName <> ".discardResultStatement"+ in+ -- Instance block: delegate to top-level functions+ "instance CanCreate " <> modelName <> " where\n"+ <> indent ("create = create" <> funcName <> "\n")+ <> indent ("createMany = createMany" <> funcName <> "\n")+ <> indent ("createRecordDiscardResult = createRecordDiscardResult" <> funcName <> "\n")+ -- create<Model>+ <> "\n"+ <> "create" <> funcName <> " :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n"+ <> "create" <> funcName <> " model = do\n"+ <> indent (hasqlCreateBody <> "\n")+ -- createMany<Model>+ <> "\n"+ <> "createMany" <> funcName <> " :: (?modelContext :: ModelContext) => [" <> modelName <> "] -> IO [" <> modelName <> "]\n"+ <> "createMany" <> funcName <> " [] = pure []\n"+ <> "createMany" <> funcName <> " models = do\n"+ <> indent (hasqlCreateManyBody <> "\n")+ -- createRecordDiscardResult<Model>+ <> "\n"+ <> "createRecordDiscardResult" <> funcName <> " :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO ()\n"+ <> "createRecordDiscardResult" <> funcName <> " model = do\n"+ <> indent (hasqlCreateDiscardBody <> "\n")++commaSep :: [Text] -> Text+commaSep = intercalate ", "++-- Avoids trailing spaces when type arguments are empty.+spacePrefix :: Text -> Text+spacePrefix "" = ""+spacePrefix t = " " <> t++toBinding :: Text -> Column -> Text+toBinding modelName Column { name } = "let " <> modelName <> "{" <> columnNameToFieldName name <> "} = model in " <> columnNameToFieldName name++onlyWritableColumns columns = columns |> filter (\Column { generator } -> isNothing generator)++compileUpdate :: (?schema :: Schema) => CreateTable -> Text+compileUpdate table@(CreateTable { name }) =+ let+ columns = allColumnsIncludingInherited table+ modelName = qualifiedConstructorNameFromTableName name+ funcName = tableNameToModelName name++ stmtModule = "Generated.Statements.Update" <> funcName+ in+ -- Instance block: delegate to top-level functions+ "instance CanUpdate " <> modelName <> " where\n"+ <> indent ("updateRecord = updateRecord" <> funcName <> "\n")+ <> indent ("updateRecordDiscardResult = updateRecordDiscardResult" <> funcName <> "\n")+ -- updateRecord<Model>+ <> "\n"+ <> "updateRecord" <> funcName <> " :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n"+ <> "updateRecord" <> funcName <> " model = do\n"+ <> " let touched = model.meta.touchedFields\n"+ <> " if touched == 0 then pure model else do\n"+ <> " let pool = ?modelContext.hasqlPool\n"+ <> " sqlStatementHasql pool model (" <> stmtModule <> ".statement touched)\n"+ -- updateRecordDiscardResult<Model>+ <> "\n"+ <> "updateRecordDiscardResult" <> funcName <> " :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO ()\n"+ <> "updateRecordDiscardResult" <> funcName <> " model = do\n"+ <> " let touched = model.meta.touchedFields\n"+ <> " unless (touched == 0) $ do\n"+ <> " let pool = ?modelContext.hasqlPool\n"+ <> " sqlStatementHasql pool model (" <> stmtModule <> ".discardResultStatement touched)\n"++compileFromRowInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileFromRowInstance table@(CreateTable { name }) = cs [i|instance FromRow #{modelName} where+ fromRow = do+#{unsafeInit . indent . indent . unlines $ map columnBinding columnNames}+ let theRecord = #{modelName} #{intercalate " " (map compileField (dataFields table))}+ pure theRecord+|]+ where+ modelName = qualifiedConstructorNameFromTableName name+ columns = allColumnsIncludingInherited table+ columnNames = map (columnNameToFieldName . (.name)) columns+ columnBinding columnName = columnName <> " <- field"++ referencing = columnsReferencingTable table.name+ referencingWithFieldNames = zip (map fst (compileQueryBuilderFields referencing)) referencing++ compileField (fieldName, _)+ | isColumn fieldName = fieldName+ | isOneToManyField fieldName = let (Just (_, ref)) = find (\(n, _) -> n == fieldName) referencingWithFieldNames in compileFromRowQueryBuilder table ref+ | fieldName == "meta" = "def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }"+ | otherwise = "def"++ isColumn colName = colName `elem` columnNames+ isOneToManyField fieldName = fieldName `elem` (map fst referencingWithFieldNames)++-- | Generates a 'FromRowHasql' instance that delegates to the RowDecoder statement module.+compileFromRowHasqlInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileFromRowHasqlInstance table@(CreateTable { name, columns }) =+ let modelName = qualifiedConstructorNameFromTableName name+ rowDecoderModule = "Generated.Statements.RowDecoder" <> tableNameToModelName name+ in cs [i|instance FromRowHasql #{modelName} where+ hasqlRowDecoder = #{rowDecoderModule}.rowDecoder+|]++compileFromRowQueryBuilder :: (?schema :: Schema) => CreateTable -> (Text, Text, Maybe Text) -> Text+compileFromRowQueryBuilder table (refTableName, refFieldName, maybeRefColumn) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))"+ where+ primaryKeyField :: Text+ primaryKeyField = if refColumn.notNull then actualPrimaryKeyField else "Just " <> actualPrimaryKeyField+ actualPrimaryKeyField :: Text+ actualPrimaryKeyField = case maybeRefColumn of+ -- When the FK constraint specifies the referenced column, use it directly.+ -- This handles composite PK tables where a FK references a specific column+ -- (which must have a standalone UNIQUE constraint).+ Just refCol -> columnNameToFieldName refCol+ -- Otherwise fall back to the single primary key column+ Nothing -> case primaryKeyColumns table of+ [] -> error $ "Impossible happened in compileFromRowHasqlInstance. No primary keys found for table " <> cs table.name <> ". At least one primary key is required."+ [pk] -> columnNameToFieldName pk.name+ pks -> error $ "No support yet for composite foreign keys. Tables cannot have foreign keys to table '" <> cs table.name <> "' which has more than one column as its primary key."++ (Just refTable) = let (Schema statements) = ?schema in+ statements+ |> find \case+ StatementCreateTable CreateTable { name } -> name == refTableName+ otherwise -> False++ refColumn :: Column+ refColumn = refTable+ |> \case StatementCreateTable CreateTable { columns } -> columns+ _ -> error "refColumn: expected StatementCreateTable"+ |> find (\col -> col.name == refFieldName)+ |> \case+ Just refColumn -> refColumn+ Nothing -> error (cs $ "Could not find " <> refTable.name <> "." <> refFieldName <> " referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint")++-- Note: Generated columns are treated as nullable in the Haskell type (even if notNull=True)+-- because they're not included in INSERT statements and are computed by the database.+-- Primary key and foreign key columns are wrapped with Id.+hasqlColumnDecoder :: (?schema :: Schema) => CreateTable -> Column -> Text+hasqlColumnDecoder table column@Column { name, columnType, notNull, generator } =+ "Decoders.column (" <> nullability <> " " <> decoder <> ")"+ where+ -- Id columns (primary keys and foreign keys) use Mapping.decoder which+ -- goes through the IsScalar instance for Id'+ isPrimaryKey = [name] == primaryKeyColumnNames table.primaryKeyConstraint++ -- Match the logic in haskellType: primary keys are always nonNullable (even without+ -- explicit NOT NULL), otherwise nullable if not notNull or has a generator+ isNullable = not isPrimaryKey && (not notNull || isJust generator)+ nullability = if isNullable then "Decoders.nullable" else "Decoders.nonNullable"+ isForeignKey = isJust (findForeignKeyConstraint table column)+ needsIdWrapper = isPrimaryKey || isForeignKey++ baseDecoder = hasqlValueDecoder columnType+ decoder = if needsIdWrapper then "Mapping.decoder" else baseDecoder++hasqlValueDecoder :: PostgresType -> Text+hasqlValueDecoder = \case+ PUUID -> "Decoders.uuid"+ PText -> "Decoders.text"+ PSmallInt -> "(fromIntegral <$> Decoders.int2)"+ PInt -> "(fromIntegral <$> Decoders.int4)"+ PBigInt -> "(fromIntegral <$> Decoders.int8)"+ PSerial -> "(fromIntegral <$> Decoders.int4)"+ PBigserial -> "(fromIntegral <$> Decoders.int8)"+ PBoolean -> "Decoders.bool"+ PReal -> "Decoders.float4"+ PDouble -> "Decoders.float8"+ PTimestampWithTimezone -> "Decoders.timestamptz"+ PTimestamp -> "Decoders.timestamp"+ PDate -> "Decoders.date"+ PTime -> "Decoders.time"+ (PNumeric _ _) -> "Decoders.numeric"+ PJSONB -> "Decoders.jsonb"+ PBinary -> "(Database.PostgreSQL.Simple.Types.Binary <$> Decoders.bytea)"+ (PVaryingN _) -> "Decoders.text"+ (PCharacterN _) -> "Decoders.text"+ (PInterval _) -> "Mapping.decoder"+ PPoint -> "Mapping.decoder"+ PPolygon -> "Mapping.decoder"+ PInet -> "Mapping.decoder"+ PTSVector -> "Mapping.decoder"+ PArray innerType -> "(Decoders.listArray (" <> hasqlArrayElementDecoder innerType <> "))"+ PCustomType _ -> "Mapping.decoder"+ PSingleChar -> "Decoders.char"+ PTrigger -> "Decoders.text" -- Trigger types shouldn't appear in table columns+ PEventTrigger -> "Decoders.text" -- Event trigger types shouldn't appear in table columns++hasqlArrayElementDecoder :: PostgresType -> Text+hasqlArrayElementDecoder innerType = "Decoders.nonNullable " <> hasqlValueDecoder innerType++compileBuild :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileBuild table@(CreateTable { name }) =+ let+ columns = allColumnsIncludingInherited table+ constructor = qualifiedConstructorNameFromTableName name+ qbDefaults = if ?compilerOptions.compileRelationSupport+ then columnsReferencingTable name |> map (const "def") |> unwords+ else ""+ in+ "instance Record " <> constructor <> " where\n"+ <> " {-# INLINE newRecord #-}\n"+ <> " newRecord = " <> constructor <> " " <> unwords (map toDefaultValueExpr columns) <> " " <> qbDefaults <> " def\n"+++compileDefaultIdInstance :: CreateTable -> Text+compileDefaultIdInstance table = "instance Default (Id' \"" <> table.name <> "\") where def = Id def"+++toDefaultValueExpr :: Column -> Text+toDefaultValueExpr Column { columnType, notNull, defaultValue = Just theDefaultValue } =+ let+ wrapNull False value = "(Just " <> value <> ")"+ wrapNull True value = value++ isNullExpr (VarExpression varName) = toUpper varName == "NULL"+ isNullExpr _ = False++ -- We remove type casts here, as we need the actual value literal for setting our default value+ theNormalizedDefaultValue = theDefaultValue |> PostgresParser.removeTypeCasts+ in+ if isNullExpr theDefaultValue+ then "Nothing"+ else+ case columnType of+ PText -> case theNormalizedDefaultValue of+ TextExpression value -> wrapNull notNull (tshow value)+ otherwise -> error ("toDefaultValueExpr: TEXT column needs to have a TextExpression as default value. Got: " <> show otherwise)+ PBoolean -> case theNormalizedDefaultValue of+ VarExpression value -> wrapNull notNull (tshow (toLower value == "true"))+ otherwise -> error ("toDefaultValueExpr: BOOL column needs to have a VarExpression as default value. Got: " <> show otherwise)+ PDouble -> case theNormalizedDefaultValue of+ DoubleExpression value -> wrapNull notNull (tshow value)+ IntExpression value -> wrapNull notNull (tshow value)+ otherwise -> error ("toDefaultValueExpr: DOUBLE column needs to have a DoubleExpression as default value. Got: " <> show otherwise)+ _ -> "def"+toDefaultValueExpr _ = "def"++compileHasTableNameInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileHasTableNameInstance table@(CreateTable { name }) =+ "type instance GetTableName (" <> tableNameToModelName name <> "'" <> spacePrefix (unwords (map (const "_") (dataTypeArguments table))) <> ") = " <> tshow name <> "\n"+ <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n"++compilePrimaryKeyInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [trimming|type instance PrimaryKey $symbol = $idType|] <> "\n"+ where+ symbol = tshow name+ idType :: Text+ idType = case primaryKeyColumns table of+ [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."+ [column] -> atomicType column.columnType -- PrimaryKey User = UUID+ cs -> "(" <> intercalate ", " (map colType cs) <> ")" -- PrimaryKey PostsTag = (Id' "posts", Id' "tags")+ where+ colType column = haskellType table column++compileFilterPrimaryKeyInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileFilterPrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = cs [i|+instance QueryBuilder.FilterPrimaryKey "#{name}" where+ filterWhereId #{primaryKeyPattern} builder =+ builder |> #{intercalate " |> " primaryKeyFilters}+ {-# INLINE filterWhereId #-}+|]+ where+ primaryKeyPattern = case primaryKeyColumns table of+ [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."+ [c] -> columnNameToFieldName c.name+ cs -> "(Id (" <> intercalate ", " (map (columnNameToFieldName . (.name)) cs) <> "))"++ primaryKeyFilters :: [Text]+ primaryKeyFilters = map primaryKeyFilter $ primaryKeyColumns table++ primaryKeyFilter :: Column -> Text+ primaryKeyFilter Column {name} = "QueryBuilder.filterWhere (#" <> columnNameToFieldName name <> ", " <> columnNameToFieldName name <> ")"++compileTableInstance :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileTableInstance table@(CreateTable { name, constraints }) = cs [i|+instance #{instanceHead} where+ tableName = \"#{name}\"+ columnNames = #{columnNames}+ primaryKeyColumnNames = #{primaryKeyColumnNames}+|]+ where+ instanceHead :: Text+ instanceHead = "IHP.ModelSupport.Table (" <> compileTypePattern table <> ")"++ primaryKeyColumnNames :: [Text]+ primaryKeyColumnNames = primaryKeyColumns table |> map (.name)++ columnNames = allColumnsIncludingInherited table+ |> map (.name)+ |> tshow++compileGetModelName :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "'" <> spacePrefix (unwords (map (const "_") (dataTypeArguments table))) <> ") = " <> tshow (tableNameToModelName name) <> "\n"++compileDataTypePattern :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileDataTypePattern table@(CreateTable { name }) = tableNameToModelName name <> " " <> unwords (table |> dataFields |> map fst)++compileTypePattern :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileTypePattern table@(CreateTable { name }) = tableNameToModelName name <> "'" <> spacePrefix (unwords (dataTypeArguments table))++compileInclude :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileInclude table@(CreateTable { name }) = (belongsToIncludes <> hasManyIncludes) |> unlines+ where+ columns = allColumnsIncludingInherited table+ belongsToIncludes = map compileBelongsTo (filter (isRefCol table) columns)+ hasManyIncludes = columnsReferencingTable name+ |> (\refs -> zip (map (\(t, _, _) -> t) refs) (map fst (compileQueryBuilderFields refs)))+ |> map compileHasMany+ typeArgs = dataTypeArguments table+ modelName = tableNameToModelName name+ modelConstructor = modelName <> "'"++ includeType :: Text -> Text -> Text+ includeType fieldName includedType = "type instance Include " <> tshow fieldName <> " (" <> leftModelType <> ") = " <> rightModelType+ where+ leftModelType = unwords (modelConstructor:typeArgs)+ rightModelType = unwords (modelConstructor:(map compileTypeVariable' typeArgs))+ compileTypeVariable' name | name == fieldName = includedType+ compileTypeVariable' name = name++ compileBelongsTo :: Column -> Text+ compileBelongsTo column = includeType (columnNameToFieldName column.name) ("(GetModelById " <> columnNameToFieldName column.name <> ")")++ compileHasMany :: (Text, Text) -> Text+ compileHasMany (refTableName, refColumnName) = includeType refColumnName ("[" <> tableNameToModelName refTableName <> "]")+++compileSetFieldInstances :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map compileSetField (dataFields table))+ where+ fieldBitMap = fieldBitPositions table+ compileSetField (fieldName, fieldType) =+ "instance SetField " <> tshow fieldName <> " (" <> compileTypePattern table <> ") " <> fieldType <> " where\n" <>+ " {-# INLINE setField #-}\n" <>+ " setField newValue record = record" <> recordUpdate+ where+ recordUpdate = case lookup fieldName fieldBitMap of+ Just bitVal ->+ " { " <> fieldName <> " = newValue" <>+ ", meta = record.meta { touchedFields = record.meta.touchedFields .|. " <> tshow bitVal <> " }" <>+ " }"+ Nothing ->+ " { " <> fieldName <> " = newValue }"++compileUpdateFieldInstances :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map compileField (dataFields table))+ where+ modelName = tableNameToModelName name+ typeArgs = dataTypeArguments table+ fieldBitMap = fieldBitPositions table++ compileField (fieldName, fieldType)+ | fieldName `elem` typeArgs = compilePolymorphic fieldName fieldType+ | otherwise = compileSimple fieldName fieldType++ -- Non-polymorphic: model type doesn't change, use record update+ compileSimple fieldName fieldType =+ "instance UpdateField " <> tshow fieldName <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern table <> ") " <> fieldType <> " " <> fieldType <> " where\n" <>+ " {-# INLINE updateField #-}\n" <>+ " updateField newValue record = record" <> recordUpdate+ where+ recordUpdate = case lookup fieldName fieldBitMap of+ Just bitVal ->+ " { " <> fieldName <> " = newValue" <>+ ", meta = record.meta { touchedFields = record.meta.touchedFields .|. " <> tshow bitVal <> " }" <>+ " }"+ Nothing ->+ " { " <> fieldName <> " = newValue }"++ -- Polymorphic: type changes, must use full pattern match+ compilePolymorphic fieldName fieldType =+ "instance UpdateField " <> tshow fieldName <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' fieldName <> ") " <> fieldName <> " " <> fieldName <> "'" <> " where\n" <>+ " {-# INLINE updateField #-}\n" <>+ " updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst)))+ where+ compileAttribute name'+ | name' == fieldName = "newValue"+ | name' == "meta" = case lookup fieldName fieldBitMap of+ Just bitVal -> "(meta { touchedFields = touchedFields meta .|. " <> tshow bitVal <> " })"+ Nothing -> "meta"+ | otherwise = name'++ compileTypePattern' :: Text -> Text+ compileTypePattern' name = tableNameToModelName table.name <> "'" <> spacePrefix (unwords (map (\f -> if f == name then name <> "'" else f) typeArgs))++compileFieldBitInstances :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileFieldBitInstances table@(CreateTable { name }) = unlines (map compileInstance (fieldBitPositions table))+ where+ typePattern = compileTypePattern table+ compileInstance (fieldName, bitVal) =+ "instance FieldBit " <> tshow fieldName <> " (" <> typePattern <> ") where fieldBit = " <> tshow bitVal++compileHasFieldId :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i|+instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where+ getField (#{compileDataTypePattern table}) = #{compilePrimaryKeyValue}+ {-# INLINE getField #-}+|]+ where+ compilePrimaryKeyValue = case primaryKeyColumnNames primaryKeyConstraint of+ [id] -> columnNameToFieldName id+ ids -> "Id (" <> commaSep (map columnNameToFieldName ids) <> ")"++needsHasFieldId :: CreateTable -> Bool+needsHasFieldId CreateTable { columns, primaryKeyConstraint } =+ case primaryKeyColumnNames primaryKeyConstraint of+ [] -> False+ ["id"] -> False+ pkCols+ | any (\col -> col.name == "id") columns -> False+ | otherwise -> True++primaryKeyColumns :: CreateTable -> [Column]+primaryKeyColumns CreateTable { name, columns, primaryKeyConstraint } =+ map getColumn (primaryKeyColumnNames primaryKeyConstraint)+ where+ getColumn columnName = case find ((==) columnName . (.name)) columns of+ Just c -> c+ Nothing -> error ("Missing column " <> cs columnName <> " used in primary key for " <> cs name)++--+-- Empty lines are not indented.+indent :: Text -> Text+indent code = code+ |> Text.lines+ |> map indentLine+ |> Text.unlines+ where+ indentLine "" = ""+ indentLine line = " " <> line++hasExplicitOrImplicitDefault :: Column -> Bool+hasExplicitOrImplicitDefault column = case column of+ Column { defaultValue = Just _ } -> True+ Column { columnType = PSerial } -> True+ Column { columnType = PBigserial } -> True+ _ -> False++-- Statement Module Generation+-- ===========================++statementModules :: (?compilerOptions :: CompilerOptions) => Schema -> [(OsPath, Text)]+statementModules schema =+ let ?schema = schema+ in schema.statements+ |> concatMap \case+ StatementCreateTable table | tableHasPrimaryKey table ->+ statementModulesForTable table+ _ -> []++statementModulesForTable :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> [(OsPath, Text)]+statementModulesForTable table =+ let modelName = tableNameToModelName table.name+ mkPath suffix = (OsPath.</>) "build/Generated/Statements" (either (error . show) id (encodeUtf (cs (suffix <> modelName) <> ".hs")))+ in [ (mkPath "RowDecoder", compileRowDecoderModule table)+ , (mkPath "Create", compileCreateStatement table)+ , (mkPath "Update", compileUpdateStatement table)+ , (mkPath "Fetch", compileFetchByIdStatement table)+ , (mkPath "CreateMany", compileCreateManyStatement table)+ ]++compileStatementsIndex :: (?compilerOptions :: CompilerOptions) => Schema -> Text+compileStatementsIndex schema@(Schema statements) =+ let tableNames = statements+ |> mapMaybe \case+ StatementCreateTable table | tableHasPrimaryKey table -> Just (tableNameToModelName table.name)+ _ -> Nothing+ imports = tableNames >>= \modelName ->+ [ "import qualified Generated.Statements.RowDecoder" <> modelName+ , "import qualified Generated.Statements.Create" <> modelName+ , "import qualified Generated.Statements.Update" <> modelName+ , "import qualified Generated.Statements.Fetch" <> modelName+ , "import qualified Generated.Statements.CreateMany" <> modelName+ ]+ in Text.unlines+ [ "-- This file is auto generated and will be overriden regulary."+ , "module Generated.Statements ("+ , Text.intercalate ",\n" (map (\imp -> " module " <> Text.drop (length ("import qualified " :: Text)) imp) imports)+ , ") where"+ , Text.unlines imports+ ]++statementModuleBaseImports :: Text+statementModuleBaseImports =+ Text.unlines+ [ "import Prelude (($), (.), (<$>), (<*>), (<>), (+), (*), (-), show, fromIntegral, length, null, zip, mconcat, (++), Maybe(..), (!!), map, Bool(..), Int, Integer, pure)"+ , "import Generated.ActualTypes"+ , "import Generated.Enums"+ , "import IHP.ModelSupport.Types (Id'(..), MetaBag(..))"+ , "import qualified Hasql.Statement as Statement"+ , "import qualified Hasql.Decoders as Decoders"+ , "import qualified Hasql.Encoders as Encoders"+ , "import qualified Hasql.Mapping.IsScalar as Mapping"+ , "import Hasql.PostgresqlTypes ()"+ , "import IHP.Job.Queue ()"+ , "import Data.Functor.Contravariant (contramap, (>$<))"+ , "import Data.Default (def)"+ , "import qualified Data.Dynamic"+ , "import Data.UUID (UUID)"+ , "import Data.Text (Text)"+ , "import Data.Int (Int16, Int32, Int64)"+ , "import Data.Time.Clock (UTCTime)"+ , "import Data.Time.LocalTime (LocalTime, TimeOfDay)"+ , "import qualified Data.Time.Calendar"+ , "import Data.Scientific (Scientific)"+ , "import qualified Data.Aeson"+ , "import qualified Database.PostgreSQL.Simple.Types"+ , "import PostgresqlTypes.Point (Point)"+ , "import PostgresqlTypes.Polygon (Polygon)"+ , "import PostgresqlTypes.Inet (Inet)"+ , "import PostgresqlTypes.Tsvector (Tsvector)"+ , "import PostgresqlTypes.Interval (Interval)"+ ]++statementModuleDynamicImports :: Text+statementModuleDynamicImports =+ Text.unlines+ [ "import Data.Bits (testBit)"+ , "import Data.Maybe (catMaybes)"+ , "import qualified Data.Text as Text"+ ]++hasqlValueEncoder :: PostgresType -> Text+hasqlValueEncoder = \case+ PUUID -> "Encoders.uuid"+ PText -> "Encoders.text"+ PSmallInt -> "(fromIntegral >$< Encoders.int2)"+ PInt -> "(fromIntegral >$< Encoders.int4)"+ PBigInt -> "(fromIntegral >$< Encoders.int8)"+ PSerial -> "(fromIntegral >$< Encoders.int4)"+ PBigserial -> "(fromIntegral >$< Encoders.int8)"+ PBoolean -> "Encoders.bool"+ PReal -> "Encoders.float4"+ PDouble -> "Encoders.float8"+ PTimestampWithTimezone -> "Encoders.timestamptz"+ PTimestamp -> "Encoders.timestamp"+ PDate -> "Encoders.date"+ PTime -> "Encoders.time"+ (PNumeric _ _) -> "Encoders.numeric"+ PJSONB -> "Encoders.jsonb"+ PBinary -> "((\\ (Database.PostgreSQL.Simple.Types.Binary bs) -> bs) >$< Encoders.bytea)"+ (PVaryingN _) -> "Encoders.text"+ (PCharacterN _) -> "Encoders.text"+ (PInterval _) -> "Mapping.encoder"+ PPoint -> "Mapping.encoder"+ PPolygon -> "Mapping.encoder"+ PInet -> "Mapping.encoder"+ PTSVector -> "Mapping.encoder"+ PArray innerType -> "(Encoders.foldableArray (Encoders.nonNullable " <> hasqlValueEncoder innerType <> "))"+ PCustomType _ -> "Mapping.encoder"+ PSingleChar -> "Encoders.char"+ PTrigger -> error "hasqlValueEncoder: PTrigger not supported"+ PEventTrigger -> error "hasqlValueEncoder: PEventTrigger not supported"++formatEncoderBlock :: [Text] -> Text+formatEncoderBlock [] = " mconcat []"+formatEncoderBlock encoderLines =+ " mconcat\n [ " <> intercalate "\n , " encoderLines <> "\n ]"++hasqlColumnEncoder :: (?schema :: Schema) => CreateTable -> Column -> Text+hasqlColumnEncoder table column@Column { name, columnType, notNull, generator }+ | isJust generator = error $ "hasqlColumnEncoder: cannot encode generated column " <> cs name+ | otherwise = "(." <> fieldName <> ") >$< Encoders.param (" <> nullability <> " " <> encoder <> ")"+ where+ fieldName = columnNameToFieldName name+ -- For encoders, columns that are nullable in Haskell (not notNull) use nullable encoder+ isNullable = not notNull+ nullability = if isNullable then "Encoders.nullable" else "Encoders.nonNullable"+ isPrimaryKey = [name] == primaryKeyColumnNames table.primaryKeyConstraint+ isForeignKey = isJust (findForeignKeyConstraint table column)+ needsIdWrapper = isPrimaryKey || isForeignKey+ baseEncoder = hasqlValueEncoder columnType+ encoder = if needsIdWrapper then "Mapping.encoder" else baseEncoder++compileSqlEntry :: Bool -> Int -> Column -> Text+compileSqlEntry alwaysConditional bitIndex col+ | alwaysConditional || hasExplicitOrImplicitDefault col =+ "if testBit touchedFields " <> tshow bitIndex <> " then Just " <> tshow col.name <> " else Nothing"+ | otherwise = "Just " <> tshow col.name++compileEncoderEntry :: (?schema :: Schema) => Bool -> Int -> CreateTable -> Column -> Text+compileEncoderEntry alwaysConditional bitIndex table col+ | alwaysConditional || hasExplicitOrImplicitDefault col =+ "if testBit touchedFields " <> tshow bitIndex <> " then Just (" <> hasqlColumnEncoder table col <> ") else Nothing"+ | otherwise = "Just (" <> hasqlColumnEncoder table col <> ")"++hasAnyDefaults :: [Column] -> Bool+hasAnyDefaults = any hasExplicitOrImplicitDefault++compileRowDecoderModule :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileRowDecoderModule table@(CreateTable { name }) =+ let columns = allColumnsIncludingInherited table+ modelName = tableNameToModelName name+ moduleName = "Generated.Statements.RowDecoder" <> modelName+ qualifiedModelName = qualifiedConstructorNameFromTableName name+ extraImports = Text.unlines+ [ "import qualified IHP.QueryBuilder as QueryBuilder"+ , "import GHC.Records"+ ]++ columnNames = map (columnNameToFieldName . (.name)) columns+ referencing = columnsReferencingTable table.name+ referencingWithFieldNames = zip (map fst (compileQueryBuilderFields referencing)) referencing++ compileField (fieldName, _)+ | isColumn fieldName = fieldName+ | isOneToManyField fieldName = let (Just (_, ref)) = find (\(n, _) -> n == fieldName) referencingWithFieldNames in compileFromRowQueryBuilder table ref+ | fieldName == "meta" = "def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }"+ | otherwise = "def"++ isColumn colName = colName `elem` columnNames+ isOneToManyField fieldName = fieldName `elem` (map fst referencingWithFieldNames)++ columnBindings = map (\col -> " " <> columnNameToFieldName col.name <> " <- " <> hasqlColumnDecoder table col) columns+ constructorArgs = intercalate " " (map compileField (dataFields table))+ -- The recursive let (theRecord references itself via toDyn) must be inside+ -- the pure expression, not as a do-block let statement, because GHC's+ -- ApplicativeDo cannot desugar recursive do-block lets and Decoders.Row+ -- has no Monad instance. A let-in inside pure(...) is just a pure Haskell+ -- expression that ApplicativeDo doesn't need to analyze.+ pureExpr = " pure (let theRecord = " <> qualifiedConstructorNameFromTableName name <> " " <> constructorArgs <> " in theRecord)"+ in "{-# LANGUAGE ApplicativeDo, OverloadedLabels, TypeApplications, ScopedTypeVariables #-}\n"+ <> statementModuleHeader moduleName ["rowDecoder"] extraImports+ <> Text.unlines+ ([ "rowDecoder :: Decoders.Row " <> qualifiedModelName+ , "rowDecoder = do"+ ] <> columnBindings <>+ [ pureExpr+ ])++compileCreateStatement :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileCreateStatement table@(CreateTable { name }) =+ let columns = allColumnsIncludingInherited table+ modelName = tableNameToModelName name+ moduleName = "Generated.Statements.Create" <> modelName+ qualifiedModelName = qualifiedConstructorNameFromTableName name+ writableColumns = onlyWritableColumns columns+ allColumnNames = commaSep (map (.name) columns)+ isDynamic = hasAnyDefaults writableColumns+ rowDecoderImport = "import qualified Generated.Statements.RowDecoder" <> modelName <> " as RowDecoder\n"+ in if isDynamic+ then compileDynamicCreateStatement moduleName qualifiedModelName name writableColumns allColumnNames table columns rowDecoderImport+ else compileStaticCreateStatement moduleName qualifiedModelName name writableColumns allColumnNames table columns rowDecoderImport++compileStaticCreateStatement :: (?schema :: Schema) => Text -> Text -> Text -> [Column] -> Text -> CreateTable -> [Column] -> Text -> Text+compileStaticCreateStatement moduleName qualifiedModelName tableName writableColumns allColumnNames table columns rowDecoderImport =+ let writableColumnNames = commaSep (map (.name) writableColumns)+ placeholders = commaSep ["$" <> tshow i | i <- [1 .. length writableColumns]]+ encoderLines = map (hasqlColumnEncoder table) writableColumns+ in statementModuleHeader moduleName ["statement", "discardResultStatement"] rowDecoderImport+ <> Text.unlines+ [ "statement :: Statement.Statement " <> qualifiedModelName <> " " <> qualifiedModelName+ , "statement = Statement.preparable sqlReturningResult encoder decoder"+ , ""+ , "discardResultStatement :: Statement.Statement " <> qualifiedModelName <> " ()"+ , "discardResultStatement = Statement.preparable sqlDiscardResult encoder Decoders.noResult"+ , ""+ , "sql :: Bool -> Text"+ , "sql returning = \"INSERT INTO " <> tableName <> " (" <> writableColumnNames <> ") VALUES (" <> placeholders <> ")\""+ , " <> if returning then \" RETURNING " <> allColumnNames <> "\" else \"\""+ , ""+ , "sqlReturningResult :: Text"+ , "sqlReturningResult = sql True"+ , ""+ , "sqlDiscardResult :: Text"+ , "sqlDiscardResult = sql False"+ , ""+ , "encoder :: Encoders.Params " <> qualifiedModelName+ , "encoder ="+ , formatEncoderBlock encoderLines+ , ""+ , "decoder :: Decoders.Result " <> qualifiedModelName+ , "decoder = Decoders.singleRow RowDecoder.rowDecoder"+ ]++compileDynamicCreateStatement :: (?schema :: Schema) => Text -> Text -> Text -> [Column] -> Text -> CreateTable -> [Column] -> Text -> Text+compileDynamicCreateStatement moduleName qualifiedModelName tableName writableColumns allColumnNames table columns rowDecoderImport =+ let columnBitIndices = columnsWithBitIndices columns writableColumns+ sqlEntries = map (\(col, bitIdx) -> compileSqlEntry False bitIdx col) columnBitIndices+ sqlBody = Text.unlines+ [ "sql :: Integer -> Bool -> Text"+ , "sql touchedFields returning ="+ , " let entries = catMaybes"+ , " [ " <> Text.intercalate "\n , " sqlEntries+ , " ]"+ , " columns = Text.intercalate \", \" entries"+ , " placeholders = Text.intercalate \", \" [\"$\" <> Text.pack (show i) | i <- [1 .. length entries]]"+ , " returningClause = if returning then \" RETURNING " <> allColumnNames <> "\" else \"\""+ , " in if null entries"+ , " then \"INSERT INTO " <> tableName <> " DEFAULT VALUES\" <> returningClause"+ , " else \"INSERT INTO " <> tableName <> " (\" <> columns <> \") VALUES (\" <> placeholders <> \")\" <> returningClause"+ ]++ encoderEntries = map (\(col, bitIdx) -> compileEncoderEntry False bitIdx table col) columnBitIndices+ encoderBody = Text.unlines+ [ "encoder :: Integer -> Encoders.Params " <> qualifiedModelName+ , "encoder touchedFields = mconcat $ catMaybes"+ , " [ " <> Text.intercalate "\n , " encoderEntries+ , " ]"+ ]+ in dynamicStatementModule moduleName qualifiedModelName sqlBody encoderBody rowDecoderImport++compileUpdateStatement :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileUpdateStatement table@(CreateTable { name }) =+ let columns = allColumnsIncludingInherited table+ modelName = tableNameToModelName name+ qualifiedModelName = qualifiedConstructorNameFromTableName name+ allWritableColumns = onlyWritableColumns columns+ pkColumns = primaryKeyColumns table+ pkColumnNames = map (.name) pkColumns+ writableColumns = filter (\col -> col.name `notElem` pkColumnNames) allWritableColumns+ allColumnNames = commaSep (map (.name) columns)++ columnBitIndices = columnsWithBitIndices columns writableColumns+ sqlEntries = map (\(col, bitIdx) -> compileSqlEntry True bitIdx col) columnBitIndices++ sqlBody = Text.unlines+ [ "sql :: Integer -> Bool -> Text"+ , "sql touchedFields returning ="+ , " let setEntries = catMaybes"+ , " [ " <> Text.intercalate "\n , " sqlEntries+ , " ]"+ , " setClauses = [col <> \" = $\" <> Text.pack (show i) | (i, col) <- zip [1..] setEntries]"+ , " pkIdx = length setEntries + 1"+ , " whereClause = " <> compileUpdateWhereClause pkColumns+ , " returningClause = if returning then \" RETURNING " <> allColumnNames <> "\" else \"\""+ , " in \"UPDATE " <> name <> " SET \" <> Text.intercalate \", \" setClauses <> \" WHERE \" <> whereClause pkIdx <> returningClause"+ ]++ encoderEntries = map (\(col, bitIdx) -> compileEncoderEntry True bitIdx table col) columnBitIndices+ pkEncoders = map (hasqlColumnEncoder table) pkColumns+ encoderBody = Text.unlines+ [ "encoder :: Integer -> Encoders.Params " <> qualifiedModelName+ , "encoder touchedFields = mconcat (catMaybes"+ , " [ " <> Text.intercalate "\n , " encoderEntries+ , " ])"+ , " <> " <> case pkEncoders of+ [e] -> "(" <> e <> ")"+ es -> "mconcat [" <> Text.intercalate ", " es <> "]"+ ]++ moduleName = "Generated.Statements.Update" <> modelName+ rowDecoderImport = "import qualified Generated.Statements.RowDecoder" <> modelName <> " as RowDecoder\n"+ in dynamicStatementModule moduleName qualifiedModelName sqlBody encoderBody rowDecoderImport+ where+ compileUpdateWhereClause :: [Column] -> Text+ compileUpdateWhereClause [col] = "\\startIdx -> " <> tshow col.name <> " <> \" = $\" <> Text.pack (show startIdx)"+ compileUpdateWhereClause cols =+ let parts = zipWith (\col i ->+ tshow col.name <> " <> \" = $\" <> Text.pack (show (startIdx + " <> tshow i <> "))"+ ) cols [(0 :: Int)..]+ in "\\startIdx -> Text.intercalate \" AND \" [" <> Text.intercalate ", " parts <> "]"++dynamicStatementModule :: Text -> Text -> Text -> Text -> Text -> Text+dynamicStatementModule moduleName qualifiedModelName sqlBody encoderBody rowDecoderImport =+ statementModuleHeader moduleName ["statement", "discardResultStatement"] (rowDecoderImport <> statementModuleDynamicImports)+ <> Text.unlines+ [ "statement :: Integer -> Statement.Statement " <> qualifiedModelName <> " " <> qualifiedModelName+ , "statement touchedFields = Statement.preparable (sql touchedFields True) (encoder touchedFields) decoder"+ , ""+ , "discardResultStatement :: Integer -> Statement.Statement " <> qualifiedModelName <> " ()"+ , "discardResultStatement touchedFields = Statement.preparable (sql touchedFields False) (encoder touchedFields) Decoders.noResult"+ , ""+ , sqlBody+ , ""+ , encoderBody+ , ""+ , "decoder :: Decoders.Result " <> qualifiedModelName+ , "decoder = Decoders.singleRow RowDecoder.rowDecoder"+ ]++statementModuleHeader :: Text -> [Text] -> Text -> Text+statementModuleHeader moduleName exports extraImports =+ Text.unlines+ [ "-- This file is auto generated and will be overriden regulary."+ , "{-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-}"+ , "module " <> moduleName <> " (" <> intercalate ", " exports <> ") where"+ , ""+ , statementModuleBaseImports+ ]+ <> extraImports++compileFetchByIdStatement :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileFetchByIdStatement table@(CreateTable { name }) =+ let columns = allColumnsIncludingInherited table+ modelName = tableNameToModelName name+ moduleName = "Generated.Statements.Fetch" <> modelName+ qualifiedModelName = qualifiedConstructorNameFromTableName name+ pkColumns = primaryKeyColumns table+ allColumnNames = commaSep (map (.name) columns)++ -- WHERE clause+ (whereClauses, _) = foldl' (\(acc, idx) col -> (col.name <> " = $" <> tshow idx : acc, idx + 1)) ([], 1 :: Int) pkColumns+ whereClauseSql = intercalate " AND " (reverse whereClauses)++ sql = "SELECT " <> allColumnNames <> " FROM " <> name <> " WHERE " <> whereClauseSql <> " LIMIT 1"++ rowDecoderImport = "import qualified Generated.Statements.RowDecoder" <> modelName <> " as RowDecoder\n"++ in statementModuleHeader moduleName ["statement"] rowDecoderImport+ <> Text.unlines+ [ "statement :: Statement.Statement (Id' " <> tshow name <> ") (Maybe " <> qualifiedModelName <> ")"+ , "statement = Statement.preparable sql encoder decoder"+ , ""+ , "sql :: Text"+ , "sql = " <> tshow sql+ , ""+ , "encoder :: Encoders.Params (Id' " <> tshow name <> ")"+ , "encoder = " <> fetchByIdEncoder table+ , ""+ , "decoder :: Decoders.Result (Maybe " <> qualifiedModelName <> ")"+ , "decoder = Decoders.rowMaybe RowDecoder.rowDecoder"+ ]++fetchByIdEncoder :: (?schema :: Schema) => CreateTable -> Text+fetchByIdEncoder table = case primaryKeyColumns table of+ [col] ->+ "Encoders.param (Encoders.nonNullable Mapping.encoder)"+ cols ->+ let encoders = zipWith (\col idx ->+ let baseEncoder = hasqlValueEncoder col.columnType+ accessor = "(\\(Id (" <> commaSep (map (\i -> if i == idx then "v" else "_") [0..length cols - 1]) <> ")) -> v)"+ in accessor <> " >$< Encoders.param (Encoders.nonNullable " <> baseEncoder <> ")"+ ) cols [0..]+ in "mconcat [" <> intercalate ", " encoders <> "]"++compileCreateManyStatement :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text+compileCreateManyStatement table@(CreateTable { name }) =+ let columns = allColumnsIncludingInherited table+ modelName = tableNameToModelName name+ moduleName = "Generated.Statements.CreateMany" <> modelName+ qualifiedModelName = qualifiedConstructorNameFromTableName name+ writableColumns = onlyWritableColumns columns+ writableColumnNames = commaSep (map (.name) writableColumns)+ allColumnNames = commaSep (map (.name) columns)+ numCols = length writableColumns++ encoderLines = map (hasqlColumnEncoder table) writableColumns+ singleEncoderBlock = formatEncoderBlock encoderLines++ rowDecoderImport = "import qualified Generated.Statements.RowDecoder" <> modelName <> " as RowDecoder\n"++ in statementModuleHeader moduleName ["statement"] (rowDecoderImport <> "import qualified Data.Text as Text\n")+ <> Text.unlines+ [ "statement :: Int -> Statement.Statement [" <> qualifiedModelName <> "] [" <> qualifiedModelName <> "]"+ , "statement count = Statement.unpreparable (sql count) (encoder count) decoder"+ , ""+ , "sql :: Int -> Text"+ , "sql count = \"INSERT INTO " <> name <> " (" <> writableColumnNames <> ") VALUES \""+ , " <> Text.intercalate \", \" [valueGroup (i * " <> tshow numCols <> ") | i <- [0..count - 1]]"+ , " <> \" RETURNING " <> allColumnNames <> "\""+ , " where"+ , " valueGroup offset = \"(\" <> Text.intercalate \", \" [\"$\" <> Text.pack (show (offset + j)) | j <- [1.." <> tshow numCols <> "]] <> \")\""+ , ""+ , "encoder :: Int -> Encoders.Params [" <> qualifiedModelName <> "]"+ , "encoder count = mconcat [contramap (!! i) singleEncoder | i <- [0..count - 1]]"+ , ""+ , "singleEncoder :: Encoders.Params " <> qualifiedModelName+ , "singleEncoder ="+ , singleEncoderBlock+ , ""+ , "decoder :: Decoders.Result [" <> qualifiedModelName <> "]"+ , "decoder = Decoders.rowList RowDecoder.rowDecoder"+ ]++
+ IHP/SchemaCompiler/Parser.hs view
@@ -0,0 +1,21 @@+{-|+Module: IHP.SchemaCompiler.Parser+Description: IHP-specific schema file utilities+Copyright: (c) digitally induced GmbH, 2020+-}+module IHP.SchemaCompiler.Parser+( parseSchemaSql+, schemaFilePath+) where++import IHP.Prelude+import IHP.Postgres.Parser (parseSqlFile)+import IHP.Postgres.Types (Statement)++-- | Path to the IHP schema file+schemaFilePath :: OsPath+schemaFilePath = "Application/Schema.sql"++-- | Parse the IHP schema file at 'Application/Schema.sql'+parseSchemaSql :: IO (Either ByteString [Statement])+parseSchemaSql = parseSqlFile schemaFilePath
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++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.
+ changelog.md view
@@ -0,0 +1,16 @@+# Changelog for `ihp-schema-compiler`++## v1.5.0++- Add PostgreSQL table inheritance (`INHERITS`) support+- Generate hasql statement modules instead of snippet-based codegen+- Generate `DefaultParamEncoder` instances for enum array columns and `Maybe` enum types+- Use `record update syntax` for `SetField`/`UpdateField` codegen+- Suppress `-Wambiguous-fields` warnings in generated types+- Use `postgresql-types` (`Point`, `Polygon`, `Interval`, `Inet`, `Tsvector`) instead of custom IHP types+- Split `Generated.ActualTypes` into per-table modules for parallel compilation+- Use `OsPath` instead of `FilePath`++## v1.4.0++- Initial release as a standalone package, extracted from ihp-ide
+ data/IHPSchema.sql view
@@ -0,0 +1,10 @@+-- Provides all the default settings for a IHP database in development mode+CREATE EXTENSION IF NOT EXISTS "uuid-ossp";++-- Used by IHP.Job+CREATE TYPE JOB_STATUS AS ENUM ('job_status_not_started', 'job_status_running', 'job_status_failed', 'job_status_timed_out', 'job_status_succeeded', 'job_status_retry');++-- Used by IHP.DataSync+CREATE FUNCTION ihp_user_id() RETURNS UUID AS $$+ SELECT NULLIF(current_setting('rls.ihp_user_id'), '')::uuid;+$$ LANGUAGE SQL;
+ exe/IHP/CLI/BuildGeneratedCode.hs view
@@ -0,0 +1,14 @@+{-|+Module: IHP.CLI.BuildGeneratedCode+Description: Provides the @build-generated-code@ command which generates the Generated.Types module+Copyright: (c) digitally induced GmbH, 2020+-}+module Main where++import IHP.Prelude+import IHP.SchemaCompiler+import Main.Utf8 (withUtf8)++main :: IO ()+main = withUtf8 do+ compile
+ ihp-schema-compiler.cabal view
@@ -0,0 +1,94 @@+cabal-version: 2.2+name: ihp-schema-compiler+version: 1.5.0+synopsis: Lightweight schema compiler for IHP+description: Compiles Schema.sql to Generated Types.hs for IHP applications. This is a minimal package with few dependencies, suitable for production builds that don't need the full ihp-ide.+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: hello@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Web, IHP+stability: Stable+tested-with: GHC == 9.8.4+build-type: Simple+extra-source-files: changelog.md+data-dir: data+data-files: IHPSchema.sql++Flag FastBuild+ Default: False+ Description: Disables all optimisations, leads to faster build time++common shared-properties+ default-language: GHC2021+ build-depends:+ base >= 4.17.0 && < 4.22+ , classy-prelude+ , text+ , bytestring+ , directory >= 1.3.8.0+ , filepath >= 1.5+ , string-conversions+ , interpolate+ , split+ , neat-interpolation+ , countable-inflections+ , with-utf8+ , ihp+ , ihp-postgres-parser+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , ImplicitParams+ , DisambiguateRecordFields+ , DuplicateRecordFields+ , OverloadedLabels+ , DataKinds+ , QuasiQuotes+ , TypeFamilies+ , PackageImports+ , RecordWildCards+ , BlockArguments+ , LambdaCase+ , OverloadedRecordDot+ if flag(FastBuild)+ ghc-options:+ -Wunused-imports+ -Wunused-foralls+ -Werror=missing-fields+ -Winaccessible-code+ -Wno-ambiguous-fields+ -Werror=incomplete-patterns+ else+ ghc-options:+ -fstatic-argument-transformation+ -funbox-strict-fields+ -haddock++ -Wunused-imports+ -Wunused-foralls+ -Werror=missing-fields+ -Winaccessible-code+ -fspecialise-aggressively+ -Wno-ambiguous-fields+ -Werror=incomplete-patterns++library+ import: shared-properties+ hs-source-dirs: .+ exposed-modules:+ IHP.SchemaCompiler+ , IHP.SchemaCompiler.Parser++executable build-generated-code+ import: shared-properties+ build-depends: ihp-schema-compiler+ hs-source-dirs: exe+ main-is: IHP/CLI/BuildGeneratedCode.hs++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp