diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs new file mode 100644 --- /dev/null +++ b/IHP/SchemaCompiler.hs @@ -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 + <> "\n" + <> "create" <> funcName <> " :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n" + <> "create" <> funcName <> " model = do\n" + <> indent (hasqlCreateBody <> "\n") + -- createMany + <> "\n" + <> "createMany" <> funcName <> " :: (?modelContext :: ModelContext) => [" <> modelName <> "] -> IO [" <> modelName <> "]\n" + <> "createMany" <> funcName <> " [] = pure []\n" + <> "createMany" <> funcName <> " models = do\n" + <> indent (hasqlCreateManyBody <> "\n") + -- createRecordDiscardResult + <> "\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 + <> "\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 + <> "\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" + ] + + diff --git a/IHP/SchemaCompiler/Parser.hs b/IHP/SchemaCompiler/Parser.hs new file mode 100644 --- /dev/null +++ b/IHP/SchemaCompiler/Parser.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 diff --git a/data/IHPSchema.sql b/data/IHPSchema.sql new file mode 100644 --- /dev/null +++ b/data/IHPSchema.sql @@ -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; diff --git a/exe/IHP/CLI/BuildGeneratedCode.hs b/exe/IHP/CLI/BuildGeneratedCode.hs new file mode 100644 --- /dev/null +++ b/exe/IHP/CLI/BuildGeneratedCode.hs @@ -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 diff --git a/ihp-schema-compiler.cabal b/ihp-schema-compiler.cabal new file mode 100644 --- /dev/null +++ b/ihp-schema-compiler.cabal @@ -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