module IHP.SchemaCompiler
( compile
, compileStatementPreview
) where

import ClassyPrelude
import Data.String.Conversions (cs)
import Data.String.Interpolate (i)
import IHP.NameSupport (tableNameToModelName, columnNameToFieldName, enumValueToControllerName, pluralize)
import qualified Data.Text as Text
import qualified System.Directory as Directory
import Data.List.Split
import IHP.HaskellSupport
import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner
import IHP.IDE.SchemaDesigner.Types
import qualified IHP.IDE.SchemaDesigner.Compiler as SqlCompiler
import qualified Control.Exception as Exception
import NeatInterpolation

data CompileException = CompileException ByteString deriving (Int -> CompileException -> ShowS
[CompileException] -> ShowS
CompileException -> [Char]
(Int -> CompileException -> ShowS)
-> (CompileException -> [Char])
-> ([CompileException] -> ShowS)
-> Show CompileException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompileException -> ShowS
showsPrec :: Int -> CompileException -> ShowS
$cshow :: CompileException -> [Char]
show :: CompileException -> [Char]
$cshowList :: [CompileException] -> ShowS
showList :: [CompileException] -> ShowS
Show)
instance Exception CompileException where
    displayException :: CompileException -> [Char]
displayException (CompileException ByteString
message) = ByteString -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
message

compile :: IO ()
compile :: IO ()
compile = do
    let options :: CompilerOptions
options = CompilerOptions
fullCompileOptions
    IO (Either ByteString [Statement])
SchemaDesigner.parseSchemaSql IO (Either ByteString [Statement])
-> (Either ByteString [Statement] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left ByteString
parserError -> CompileException -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO (ByteString -> CompileException
CompileException ByteString
parserError)
        Right [Statement]
statements -> do
            -- let validationErrors = validate database
            -- unless (null validationErrors) (error $ "Schema.hs contains errors: " <> cs (unsafeHead validationErrors))
            Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True [Char]
"build/Generated"

            [([Char], Text)] -> (Element [([Char], Text)] -> IO ()) -> IO ()
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forEach (CompilerOptions -> Schema -> [([Char], Text)]
compileModules CompilerOptions
options ([Statement] -> Schema
Schema [Statement]
statements)) \([Char]
path, Text
body) -> do
                    [Char] -> Text -> IO ()
writeIfDifferent [Char]
path Text
body

compileModules :: CompilerOptions -> Schema -> [(FilePath, Text)]
compileModules :: CompilerOptions -> Schema -> [([Char], Text)]
compileModules CompilerOptions
options Schema
schema =
    [ ([Char]
"build/Generated/Enums.hs", CompilerOptions -> Schema -> Text
compileEnums CompilerOptions
options Schema
schema)
    , ([Char]
"build/Generated/ActualTypes.hs", CompilerOptions -> Schema -> Text
compileTypes CompilerOptions
options Schema
schema)
    ] [([Char], Text)] -> [([Char], Text)] -> [([Char], Text)]
forall a. Semigroup a => a -> a -> a
<> CompilerOptions -> Schema -> [([Char], Text)]
tableModules CompilerOptions
options Schema
schema [([Char], Text)] -> [([Char], Text)] -> [([Char], Text)]
forall a. Semigroup a => a -> a -> a
<>
    [ ([Char]
"build/Generated/Types.hs", Schema -> Text
compileIndex Schema
schema)
    ]

tableModules :: CompilerOptions -> Schema -> [(FilePath, Text)]
tableModules :: CompilerOptions -> Schema -> [([Char], Text)]
tableModules CompilerOptions
options Schema
schema =
    let ?schema = ?schema::Schema
Schema
schema
    in
        Schema
schema.statements
        [Statement]
-> ([Statement] -> [([Char], Text)]) -> [([Char], Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Statement -> Maybe ([Char], Text))
-> [Statement] -> [([Char], Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
                StatementCreateTable CreateTable
t | CreateTable -> Bool
tableHasPrimaryKey CreateTable
t -> ([Char], Text) -> Maybe ([Char], Text)
forall a. a -> Maybe a
Just ((?schema::Schema) =>
CompilerOptions -> CreateTable -> ([Char], Text)
CompilerOptions -> CreateTable -> ([Char], Text)
tableModule CompilerOptions
options CreateTable
t)
                Statement
otherwise -> Maybe ([Char], Text)
forall a. Maybe a
Nothing
            )

tableModule :: (?schema :: Schema) => CompilerOptions -> CreateTable -> (FilePath, Text)
tableModule :: (?schema::Schema) =>
CompilerOptions -> CreateTable -> ([Char], Text)
tableModule CompilerOptions
options CreateTable
table =
        ([Char]
"build/Generated/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text
tableNameToModelName CreateTable
table.name) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".hs", Text
body)
    where
        body :: Text
body = [Text] -> Text
Text.unlines
            [ Text
prelude
            , (?schema::Schema) => CompilerOptions -> CreateTable -> Text
CompilerOptions -> CreateTable -> Text
tableModuleBody CompilerOptions
options CreateTable
table
            ]
        moduleName :: Text
moduleName = Text
"Generated." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName CreateTable
table.name
        prelude :: Text
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 $moduleName where
            $defaultImports
            import Generated.ActualTypes
        |]

tableModuleBody :: (?schema :: Schema) => CompilerOptions -> CreateTable -> Text
tableModuleBody :: (?schema::Schema) => CompilerOptions -> CreateTable -> Text
tableModuleBody CompilerOptions
options CreateTable
table = [Text] -> Text
Text.unlines
    [ CreateTable -> Text
compileInputValueInstance CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileFromRowInstance CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileGetModelName CreateTable
table
    , CreateTable -> Text
compileCreate CreateTable
table
    , CreateTable -> Text
compileUpdate CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileBuild CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileFilterPrimaryKeyInstance CreateTable
table
    , if CreateTable -> Bool
needsHasFieldId CreateTable
table
            then (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileHasFieldId CreateTable
table
            else Text
""
    , if CompilerOptions
options.compileGetAndSetFieldInstances
            then (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileSetFieldInstances CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileUpdateFieldInstances CreateTable
table
            else Text
""
    ]

newtype Schema = Schema { Schema -> [Statement]
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
        CompilerOptions -> Bool
compileGetAndSetFieldInstances :: Bool
    }

fullCompileOptions :: CompilerOptions
fullCompileOptions :: CompilerOptions
fullCompileOptions = CompilerOptions { $sel:compileGetAndSetFieldInstances:CompilerOptions :: Bool
compileGetAndSetFieldInstances = Bool
True }

previewCompilerOptions :: CompilerOptions
previewCompilerOptions :: CompilerOptions
previewCompilerOptions = CompilerOptions { $sel:compileGetAndSetFieldInstances:CompilerOptions :: Bool
compileGetAndSetFieldInstances = Bool
False }

atomicType :: PostgresType -> Text
atomicType :: PostgresType -> Text
atomicType = \case
    PostgresType
PSmallInt -> Text
"Int"
    PostgresType
PInt -> Text
"Int"
    PostgresType
PBigInt -> Text
"Integer"
    PostgresType
PJSONB -> Text
"Data.Aeson.Value"
    PostgresType
PText -> Text
"Text"
    PostgresType
PBoolean   -> Text
"Bool"
    PostgresType
PTimestampWithTimezone -> Text
"UTCTime"
    PostgresType
PUUID -> Text
"UUID"
    PostgresType
PSerial -> Text
"Int"
    PostgresType
PBigserial -> Text
"Integer"
    PostgresType
PReal -> Text
"Float"
    PostgresType
PDouble -> Text
"Double"
    PostgresType
PDate -> Text
"Data.Time.Calendar.Day"
    PostgresType
PBinary -> Text
"(Binary ByteString)"
    PostgresType
PTime -> Text
"TimeOfDay"
    (PInterval Maybe Text
_) -> Text
"PGInterval"
    PCustomType Text
theType -> Text -> Text
tableNameToModelName Text
theType
    PostgresType
PTimestamp -> Text
"LocalTime"
    (PNumeric Maybe Int
_ Maybe Int
_) -> Text
"Scientific"
    (PVaryingN Maybe Int
_) -> Text
"Text"
    (PCharacterN Int
_) -> Text
"Text"
    PArray PostgresType
type_ -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PostgresType -> Text
atomicType PostgresType
type_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    PostgresType
PPoint -> Text
"Point"
    PostgresType
PPolygon -> Text
"Polygon"
    PostgresType
PInet -> Text
"Net.IP.IP"
    PostgresType
PTSVector -> Text
"TSVector"

haskellType :: (?schema :: Schema) => CreateTable -> Column -> Text
haskellType :: (?schema::Schema) => CreateTable -> Column -> Text
haskellType table :: CreateTable
table@CreateTable { $sel:name:CreateTable :: CreateTable -> Text
name = Text
tableName, PrimaryKeyConstraint
primaryKeyConstraint :: PrimaryKeyConstraint
$sel:primaryKeyConstraint:CreateTable :: CreateTable -> PrimaryKeyConstraint
primaryKeyConstraint } column :: Column
column@Column { Text
name :: Text
$sel:name:Column :: Column -> Text
name, PostgresType
columnType :: PostgresType
$sel:columnType:Column :: Column -> PostgresType
columnType, Bool
notNull :: Bool
$sel:notNull:Column :: Column -> Bool
notNull, Maybe ColumnGenerator
generator :: Maybe ColumnGenerator
$sel:generator:Column :: Column -> Maybe ColumnGenerator
generator }
    | [Text
name] [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== PrimaryKeyConstraint -> [Text]
primaryKeyColumnNames PrimaryKeyConstraint
primaryKeyConstraint = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
primaryKeyTypeName Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    | Bool
otherwise =
        let
            actualType :: Text
actualType =
                case (?schema::Schema) => CreateTable -> Column -> Maybe Constraint
CreateTable -> Column -> Maybe Constraint
findForeignKeyConstraint CreateTable
table Column
column of
                    Just (ForeignKeyConstraint { Text
referenceTable :: Text
$sel:referenceTable:ForeignKeyConstraint :: Constraint -> Text
referenceTable }) -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
primaryKeyTypeName Text
referenceTable Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                    Maybe Constraint
_ -> PostgresType -> Text
atomicType PostgresType
columnType
        in
            if Bool -> Bool
not Bool
notNull Bool -> Bool -> Bool
|| Maybe ColumnGenerator -> Bool
forall a. Maybe a -> Bool
isJust Maybe ColumnGenerator
generator
                then Text
"(Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actualType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                else Text
actualType
-- haskellType table (HasMany {name}) = "(QueryBuilder.QueryBuilder " <> tableNameToModelName name <> ")"


writeIfDifferent :: FilePath -> Text -> IO ()
writeIfDifferent :: [Char] -> Text -> IO ()
writeIfDifferent [Char]
path Text
content = do
    Bool
alreadyExists <- [Char] -> IO Bool
Directory.doesFileExist [Char]
path
    ByteString
existingContent <- if Bool
alreadyExists then [Char] -> IO ByteString
forall (m :: * -> *). MonadIO m => [Char] -> m ByteString
readFile [Char]
path else ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
existingContent ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
content) do
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Updating " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
path
        [Char] -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> ByteString -> m ()
writeFile (ShowS
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
path) (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
content)

compileTypes :: CompilerOptions -> Schema -> Text
compileTypes :: CompilerOptions -> Schema -> Text
compileTypes CompilerOptions
options schema :: Schema
schema@(Schema [Statement]
statements) = [Text] -> Text
Text.unlines
        [ Text
prelude
        , let ?schema = ?schema::Schema
Schema
schema in Text
(?schema::Schema) => Text
body
        ]
    where
        body :: (?schema :: Schema) => Text
        body :: (?schema::Schema) => Text
body =
            [Statement]
statements
                [Statement] -> ([Statement] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Statement -> Maybe Text) -> [Statement] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
                    StatementCreateTable CreateTable
table | CreateTable -> Bool
tableHasPrimaryKey CreateTable
table -> Text -> Maybe Text
forall a. a -> Maybe a
Just ((?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileActualTypesForTable CreateTable
table)
                    Statement
otherwise -> Maybe Text
forall a. Maybe a
Nothing
                )
                [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text] -> Text
Text.intercalate Text
"\n\n"
        prelude :: Text
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 (module Generated.ActualTypes, module Generated.Enums) where
            $defaultImports
            import Generated.Enums
        |]

compileActualTypesForTable :: (?schema :: Schema) => CreateTable -> Text
compileActualTypesForTable :: (?schema::Schema) => CreateTable -> Text
compileActualTypesForTable CreateTable
table = [Text] -> Text
Text.unlines
    [ (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileData CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compilePrimaryKeyInstance CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileInclude CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTypeAlias CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileHasTableNameInstance CreateTable
table
    , CreateTable -> Text
compileDefaultIdInstance CreateTable
table
    , (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTableInstance CreateTable
table
    ]

compileIndex :: Schema -> Text
compileIndex :: Schema -> Text
compileIndex Schema
schema = [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.Types ($rexports) where
        import Generated.ActualTypes
        $tableModuleImports
    |]
        where
            tableModuleNames :: [Text]
tableModuleNames =
                Schema
schema.statements
                [Statement] -> ([Statement] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Statement -> Maybe Text) -> [Statement] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
                        StatementCreateTable CreateTable
table -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"Generated." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName CreateTable
table.name)
                        Statement
otherwise -> Maybe Text
forall a. Maybe a
Nothing
                    )
            tableModuleImports :: Text
tableModuleImports = [Text]
tableModuleNames
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
name -> Text
"import " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
                    [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
Text.unlines

            rexportedModules :: [Text]
rexportedModules = [Text
"Generated.ActualTypes"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
tableModuleNames

            rexports :: Text
rexports = [Text]
rexportedModules
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
moduleName -> Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName)
                    [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text] -> Text
Text.intercalate Text
", "


defaultImports :: Text
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 qualified Net.IP
    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 ()
    import qualified Control.DeepSeq as DeepSeq
    import qualified Data.Dynamic
    import Data.Scientific
|]



compileEnums :: CompilerOptions -> Schema -> Text
compileEnums :: CompilerOptions -> Schema -> Text
compileEnums CompilerOptions
options schema :: Schema
schema@(Schema [Statement]
statements) = [Text] -> Text
Text.unlines
        [ Text
prelude
        , let ?schema = ?schema::Schema
Schema
schema
          in Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
"\n\n" ((Statement -> Maybe Text) -> [Statement] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (?schema::Schema) => Statement -> Maybe Text
Statement -> Maybe Text
compileStatement [Statement]
statements)
        ]
    where
        compileStatement :: Statement -> Maybe Text
compileStatement enum :: Statement
enum@(CreateEnumType {}) = Text -> Maybe Text
forall a. a -> Maybe a
Just ((?schema::Schema) => Statement -> Text
Statement -> Text
compileEnumDataDefinitions Statement
enum)
        compileStatement Statement
_ = Maybe Text
forall a. Maybe a
Nothing
        prelude :: Text
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
        |]

compileStatementPreview :: [Statement] -> Statement -> Text
compileStatementPreview :: [Statement] -> Statement -> Text
compileStatementPreview [Statement]
statements Statement
statement =
    let ?schema = [Statement] -> Schema
Schema [Statement]
statements
    in
        case Statement
statement of
            CreateEnumType {} -> (?schema::Schema) => Statement -> Text
Statement -> Text
compileEnumDataDefinitions Statement
statement
            StatementCreateTable CreateTable
table -> [Text] -> Text
Text.unlines
                [ (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileActualTypesForTable CreateTable
table
                , (?schema::Schema) => CompilerOptions -> CreateTable -> Text
CompilerOptions -> CreateTable -> Text
tableModuleBody CompilerOptions
previewCompilerOptions CreateTable
table
                ]

-- | Skip generation of tables with no primary keys
tableHasPrimaryKey :: CreateTable -> Bool
tableHasPrimaryKey :: CreateTable -> Bool
tableHasPrimaryKey CreateTable
table = CreateTable
table.primaryKeyConstraint PrimaryKeyConstraint -> PrimaryKeyConstraint -> Bool
forall a. Eq a => a -> a -> Bool
/= ([Text] -> PrimaryKeyConstraint
PrimaryKeyConstraint [])

compileTypeAlias :: (?schema :: Schema) => CreateTable -> Text
compileTypeAlias :: (?schema::Schema) => CreateTable -> Text
compileTypeAlias table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
columns :: [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns }) =
        Text
"type "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((?schema::Schema) => CreateTable -> Column -> Text
CreateTable -> Column -> Text
haskellType CreateTable
table) ((?schema::Schema) => CreateTable -> [Column]
CreateTable -> [Column]
variableAttributes CreateTable
table))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hasManyDefaults
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    where
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        hasManyDefaults :: Text
hasManyDefaults = (?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable Text
name
                [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
tableName, Text
columnName) -> Text
"(QueryBuilder.QueryBuilder \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")")
                [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords

primaryKeyTypeName :: Text -> Text
primaryKeyTypeName :: Text -> Text
primaryKeyTypeName Text
name = Text
"Id' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
""

compileData :: (?schema :: Schema) => CreateTable -> Text
compileData :: (?schema::Schema) => CreateTable -> Text
compileData table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) =
        Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeArguments
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" {"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            CreateTable
table
            CreateTable -> (CreateTable -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields
            [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
fieldName, Text
fieldType) -> Text
fieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldType)
            [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
commaSep
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"} deriving (Eq, Show)\n"
    where
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        typeArguments :: Text
        typeArguments :: Text
typeArguments = (?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords

compileInputValueInstance :: CreateTable -> Text
compileInputValueInstance :: CreateTable -> Text
compileInputValueInstance CreateTable
table =
        Text
"instance InputValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where inputValue = IHP.ModelSupport.recordToInputValue\n"
    where
        modelName :: Text
modelName = Text -> Text
tableNameToModelName CreateTable
table.name

-- | Returns all the type arguments of the data structure for an entity
dataTypeArguments :: (?schema :: Schema) => CreateTable -> [Text]
dataTypeArguments :: (?schema::Schema) => CreateTable -> [Text]
dataTypeArguments CreateTable
table = ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
columnNameToFieldName [Text]
belongsToVariables) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
hasManyVariables
    where
        belongsToVariables :: [Text]
belongsToVariables = (?schema::Schema) => CreateTable -> [Column]
CreateTable -> [Column]
variableAttributes CreateTable
table [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name)
        hasManyVariables :: [Text]
hasManyVariables =
            (?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable CreateTable
table.name
            [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [(Text, Text)] -> [(Text, Text)]
compileQueryBuilderFields
            [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd

-- | Returns the field names and types for the @data MyRecord = MyRecord { .. }@ for a given table
dataFields :: (?schema :: Schema) => CreateTable -> [(Text, Text)]
dataFields :: (?schema::Schema) => CreateTable -> [(Text, Text)]
dataFields table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = [(Text, Text)]
columnFields [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)]
queryBuilderFields [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"meta", Text
"MetaBag")]
    where
        columnFields :: [(Text, Text)]
columnFields = [Column]
columns [Column] -> ([Column] -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> (Text, Text)) -> [Column] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> (Text, Text)
columnField

        columnField :: Column -> (Text, Text)
columnField Column
column =
            let fieldName :: Text
fieldName = Text -> Text
columnNameToFieldName Column
column.name
            in
                ( Text
fieldName
                , if (?schema::Schema) => CreateTable -> Column -> Bool
CreateTable -> Column -> Bool
isVariableAttribute CreateTable
table Column
column
                        then Text
fieldName
                        else (?schema::Schema) => CreateTable -> Column -> Text
CreateTable -> Column -> Text
haskellType CreateTable
table Column
column
                )

        queryBuilderFields :: [(Text, Text)]
queryBuilderFields = (?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable Text
name [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [(Text, Text)] -> [(Text, Text)]
compileQueryBuilderFields

compileQueryBuilderFields :: [(Text, Text)] -> [(Text, Text)]
compileQueryBuilderFields :: [(Text, Text)] -> [(Text, Text)]
compileQueryBuilderFields [(Text, Text)]
columns = ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> (Text, Text)
compileQueryBuilderField [(Text, Text)]
columns
    where
        compileQueryBuilderField :: (Text, Text) -> (Text, Text)
compileQueryBuilderField (Text
refTableName, Text
refColumnName) =
            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 :: Bool
hasDuplicateQueryBuilder =
                    [(Text, Text)]
columns
                    [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
columnNameToFieldName
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element [Text] -> Bool) -> [Text] -> [Text]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (Text -> Text
columnNameToFieldName Text
refTableName ==)
                    [Text] -> ([Text] -> Int) -> Int
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Int
forall mono. MonoFoldable mono => mono -> Int
length
                    Int -> (Int -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (\Int
count -> Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)

                stripIdSuffix :: Text -> Text
                stripIdSuffix :: Text -> Text
stripIdSuffix Text
name = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name (Text -> Text -> Maybe Text
Text.stripSuffix Text
"_id" Text
name)

                fieldName :: Text
fieldName = if Bool
hasDuplicateQueryBuilder
                    then
                        (Text
refTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text
refColumnName Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
stripIdSuffix))
                        Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
columnNameToFieldName
                        Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
pluralize
                    else Text -> Text
columnNameToFieldName Text
refTableName
            in
                (Text
fieldName, Text
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)]
columnsReferencingTable :: (?schema::Schema) => Text -> [(Text, Text)]
columnsReferencingTable Text
theTableName =
    let
        (Schema [Statement]
statements) = ?schema::Schema
Schema
?schema
    in
        [Statement]
statements
        [Statement] -> ([Statement] -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Statement -> Maybe (Text, Text)) -> [Statement] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe \case
            AddConstraint { Text
tableName :: Text
$sel:tableName:StatementCreateTable :: Statement -> Text
tableName, $sel:constraint:StatementCreateTable :: Statement -> Constraint
constraint = ForeignKeyConstraint { Text
columnName :: Text
$sel:columnName:ForeignKeyConstraint :: Constraint -> Text
columnName, Text
$sel:referenceTable:ForeignKeyConstraint :: Constraint -> Text
referenceTable :: Text
referenceTable, Maybe Text
referenceColumn :: Maybe Text
$sel:referenceColumn:ForeignKeyConstraint :: Constraint -> Maybe Text
referenceColumn } } | Text
referenceTable Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
theTableName -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
tableName, Text
columnName)
            Statement
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing

variableAttributes :: (?schema :: Schema) => CreateTable -> [Column]
variableAttributes :: (?schema::Schema) => CreateTable -> [Column]
variableAttributes table :: CreateTable
table@(CreateTable { [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = (Element [Column] -> Bool) -> [Column] -> [Column]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter ((?schema::Schema) => CreateTable -> Column -> Bool
CreateTable -> Column -> Bool
isVariableAttribute CreateTable
table) [Column]
columns

isVariableAttribute :: (?schema :: Schema) => CreateTable -> Column -> Bool
isVariableAttribute :: (?schema::Schema) => CreateTable -> Column -> Bool
isVariableAttribute = (?schema::Schema) => CreateTable -> Column -> Bool
CreateTable -> Column -> Bool
isRefCol


-- | Returns @True@ when the coluns is referencing another column via foreign key constraint
isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool
isRefCol :: (?schema::Schema) => CreateTable -> Column -> Bool
isRefCol CreateTable
table Column
column = Maybe Constraint -> Bool
forall a. Maybe a -> Bool
isJust ((?schema::Schema) => CreateTable -> Column -> Maybe Constraint
CreateTable -> Column -> Maybe Constraint
findForeignKeyConstraint CreateTable
table Column
column)

-- | Returns the foreign key constraint bound on the given column
findForeignKeyConstraint :: (?schema :: Schema) => CreateTable -> Column -> Maybe Constraint
findForeignKeyConstraint :: (?schema::Schema) => CreateTable -> Column -> Maybe Constraint
findForeignKeyConstraint CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name } Column
column =
        case (Element [Statement] -> Bool)
-> [Statement] -> Maybe (Element [Statement])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find Element [Statement] -> Bool
Statement -> Bool
isFkConstraint [Statement]
statements of
            Just (AddConstraint { Constraint
$sel:constraint:StatementCreateTable :: Statement -> Constraint
constraint :: Constraint
constraint }) -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just Constraint
constraint
            Maybe (Element [Statement])
Nothing -> Maybe Constraint
forall a. Maybe a
Nothing
    where
        isFkConstraint :: Statement -> Bool
isFkConstraint (AddConstraint { Text
$sel:tableName:StatementCreateTable :: Statement -> Text
tableName :: Text
tableName, $sel:constraint:StatementCreateTable :: Statement -> Constraint
constraint = ForeignKeyConstraint { Text
$sel:columnName:ForeignKeyConstraint :: Constraint -> Text
columnName :: Text
columnName }}) = Text
tableName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name Bool -> Bool -> Bool
&& Text
columnName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Column
column.name
        isFkConstraint Statement
_ = Bool
False

        (Schema [Statement]
statements) = ?schema::Schema
Schema
?schema

compileEnumDataDefinitions :: (?schema :: Schema) => Statement -> Text
compileEnumDataDefinitions :: (?schema::Schema) => Statement -> Text
compileEnumDataDefinitions CreateEnumType { $sel:values:StatementCreateTable :: Statement -> [Text]
values = [] } = Text
"" -- Ignore enums without any values
compileEnumDataDefinitions enum :: Statement
enum@(CreateEnumType { Text
name :: Text
$sel:name:StatementCreateTable :: Statement -> Text
name, [Text]
$sel:values:StatementCreateTable :: Statement -> [Text]
values :: [Text]
values }) =
        Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
" | " [Text]
valueConstructors) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" deriving (Eq, Show, Read, Enum, Bounded)\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance FromField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileFromFieldInstanceForValue [Text]
values))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    fromField field (Just value) = returnError ConversionFailed field (\"Unexpected value for enum value. Got: \" <> Data.String.Conversions.cs value)\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    fromField field Nothing = returnError UnexpectedNull field \"Unexpected null for enum value\"\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance Default " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where def = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
enumValueToConstructorName ([Text] -> Element [Text]
forall mono. MonoFoldable mono => mono -> Element mono
unsafeHead [Text]
values) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance ToField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileToFieldInstanceForValue [Text]
values))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance InputValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileInputValue [Text]
values))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance DeepSeq.NFData " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" rnf a = seq a ()" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance IHP.Controller.Param.ParamReader " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON\n"
    where
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        valueConstructors :: [Text]
valueConstructors = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
enumValueToConstructorName [Text]
values

        enumValueToConstructorName :: Text -> Text
        enumValueToConstructorName :: Text -> Text
enumValueToConstructorName Text
enumValue = if Text -> Bool
isEnumValueUniqueInSchema Text
enumValue
                then Text -> Text
enumValueToControllerName Text
enumValue
                else Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
enumValueToControllerName Text
enumValue)

        compileFromFieldInstanceForValue :: Text -> Text
compileFromFieldInstanceForValue Text
value = Text
"fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") = pure " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
enumValueToConstructorName Text
value
        compileToFieldInstanceForValue :: Text -> Text
compileToFieldInstanceForValue Text
value = Text
"toField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
enumValueToConstructorName Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = toField (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: Text)"
        compileInputValue :: Text -> Text
compileInputValue Text
value = Text
"inputValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
enumValueToConstructorName Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: Text"

        -- 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 :: Text -> Bool
isEnumValueUniqueInSchema Text
enumValue =
                ?schema::Schema
Schema
?schema
                Schema -> (Schema -> [Statement]) -> [Statement]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case Schema [Statement]
statements -> [Statement]
statements
                [Statement] -> ([Statement] -> [Statement]) -> [Statement]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element [Statement] -> Bool) -> [Statement] -> [Statement]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\case
                        CreateEnumType { Text
$sel:name:StatementCreateTable :: Statement -> Text
name :: Text
name, [Text]
$sel:values:StatementCreateTable :: Statement -> [Text]
values :: [Text]
values } | Element [Text]
Text
enumValue Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [Text]
values -> Bool
True
                        Element [Statement]
_                                                         -> Bool
False
                    )
                [Statement] -> ([Statement] -> Int) -> Int
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Statement] -> Int
forall mono. MonoFoldable mono => mono -> Int
length
                Int -> (Int -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \Int
count -> Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

compileToRowValues :: [Text] -> Text
compileToRowValues :: [Text] -> Text
compileToRowValues [Text]
bindingValues | [Text] -> Int
forall mono. MonoFoldable mono => mono -> Int
length [Text]
bindingValues Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Text
"Only (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Element [Text]
forall mono. MonoFoldable mono => mono -> Element mono
unsafeHead [Text]
bindingValues) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
compileToRowValues [Text]
bindingValues = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
") :. (" (([Text] -> Text) -> [[Text]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[Text]
list -> if [Text] -> Int
forall mono. MonoFoldable mono => mono -> Int
length [Text]
list Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"Only (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Element [Text]
forall mono. MonoFoldable mono => mono -> Element mono
unsafeHead [Text]
list) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" else Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", " [Text]
list) (Int -> [Text] -> [[Text]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
8 [Text]
bindingValues)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- When we do an INSERT or UPDATE query like @INSERT INTO values (uuids) VALUES (?)@ where the type of @uuids@ is @UUID[]@
-- we need to add a typecast to the placeholder @?@, otherwise this will throw an sql error
-- See https://github.com/digitallyinduced/ihp/issues/593
-- See https://github.com/digitallyinduced/ihp/issues/913
columnPlaceholder :: Column -> Text
columnPlaceholder :: Column -> Text
columnPlaceholder column :: Column
column@Column { PostgresType
$sel:columnType:Column :: Column -> PostgresType
columnType :: PostgresType
columnType } = if Column -> Bool
columnPlaceholderNeedsTypecast Column
column
        then Text
"? :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PostgresType -> Text
SqlCompiler.compilePostgresType PostgresType
columnType
        else Text
"?"
    where
        columnPlaceholderNeedsTypecast :: Column -> Bool
columnPlaceholderNeedsTypecast Column { $sel:columnType:Column :: Column -> PostgresType
columnType = PArray {} } = Bool
True
        columnPlaceholderNeedsTypecast Column
_ = Bool
False

compileCreate :: CreateTable -> Text
compileCreate :: CreateTable -> Text
compileCreate table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) =
    let
        writableColumns :: [Column]
writableColumns = [Column] -> [Column]
forall {t2}. (Element t2 ~ Column, IsSequence t2) => t2 -> t2
onlyWritableColumns [Column]
columns
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        columnNames :: Text
columnNames = [Text] -> Text
commaSep ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name) [Column]
writableColumns)
        values :: Text
values = [Text] -> Text
commaSep ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
columnPlaceholder [Column]
writableColumns)

        toBinding :: Column -> Text
toBinding column :: Column
column@(Column { Text
$sel:name:Column :: Column -> Text
name :: Text
name }) =
            if Column -> Bool
hasExplicitOrImplicitDefault Column
column
                then Text
"fieldWithDefault #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" model"
                else Text
"model." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name


        bindings :: [Text]
        bindings :: [Text]
bindings = (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
toBinding [Column]
writableColumns

        createManyFieldValues :: Text
        createManyFieldValues :: Text
createManyFieldValues = if [Text] -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null [Text]
bindings
                then Text
"()"
                else Text
"(List.concat $ List.map (\\model -> [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", " ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
b -> Text
"toField (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") [Text]
bindings)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]) models)"
    in
        Text
"instance CanCreate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent (
            Text
"create :: (?modelContext :: ModelContext) => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> IO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"create model = do\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent (Text
"List.head <$> sqlQuery \"INSERT INTO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
columnNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") VALUES (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
values Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") RETURNING " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
columnNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
compileToRowValues [Text]
bindings Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n")
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"createMany [] = pure []\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"createMany models = do\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent (Text
"sqlQuery (Query $ \"INSERT INTO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
columnNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
values Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\") models)) <> \" RETURNING " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
columnNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\") " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
createManyFieldValues Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                    )
            )

commaSep :: [Text] -> Text
commaSep :: [Text] -> Text
commaSep = Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", "

toBinding :: Text -> Column -> Text
toBinding :: Text -> Column -> Text
toBinding Text
modelName Column { Text
$sel:name:Column :: Column -> Text
name :: Text
name } = Text
"let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"} = model in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name

onlyWritableColumns :: t2 -> t2
onlyWritableColumns t2
columns = t2
columns t2 -> (t2 -> t2) -> t2
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element t2 -> Bool) -> t2 -> t2
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\Column { Maybe ColumnGenerator
$sel:generator:Column :: Column -> Maybe ColumnGenerator
generator :: Maybe ColumnGenerator
generator } -> Maybe ColumnGenerator -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ColumnGenerator
generator)

compileUpdate :: CreateTable -> Text
compileUpdate :: CreateTable -> Text
compileUpdate table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) =
    let
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        writableColumns :: [Column]
writableColumns = [Column] -> [Column]
forall {t2}. (Element t2 ~ Column, IsSequence t2) => t2 -> t2
onlyWritableColumns [Column]
columns

        toUpdateBinding :: Column -> Text
toUpdateBinding Column { Text
$sel:name:Column :: Column -> Text
name :: Text
name } = Text
"fieldWithUpdate #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" model"
        toPrimaryKeyBinding :: Column -> Text
toPrimaryKeyBinding Column { Text
$sel:name:Column :: Column -> Text
name :: Text
name } = Text
"model." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name

        bindings :: Text
        bindings :: Text
bindings =
            let
                bindingValues :: [Text]
bindingValues = (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
toUpdateBinding [Column]
writableColumns [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
toPrimaryKeyBinding (CreateTable -> [Column]
primaryKeyColumns CreateTable
table)
            in
                [Text] -> Text
compileToRowValues [Text]
bindingValues

        updates :: Text
updates = [Text] -> Text
commaSep ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Column
column -> Column
column.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Column -> Text
columnPlaceholder Column
column ) [Column]
writableColumns)

        columnNames :: Text
columnNames = [Column]
writableColumns
                [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name)
                [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", "
    in
        Text
"instance CanUpdate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent (Text
"updateRecord model = do\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indent (
                    Text
"List.head <$> sqlQuery \"UPDATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
updates Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ? RETURNING " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
columnNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bindings Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n"
                )
            )

compileFromRowInstance :: (?schema :: Schema) => CreateTable -> Text
compileFromRowInstance :: (?schema::Schema) => CreateTable -> Text
compileFromRowInstance table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
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 :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        columnNames :: [Text]
columnNames = (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> Text
columnNameToFieldName (Text -> Text) -> (Column -> Text) -> Column -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (.name)) [Column]
columns
        columnBinding :: a -> a
columnBinding a
columnName = a
columnName a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" <- field"

        referencing :: [(Text, Text)]
referencing = (?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable CreateTable
table.name

        compileField :: (Text, Text) -> Text
compileField (Text
fieldName, Text
_)
            | Text -> Bool
isColumn Text
fieldName = Text
fieldName
            | Text -> Bool
isManyToManyField Text
fieldName = let (Just Element [(Text, Text)]
ref) = (Element [(Text, Text)] -> Bool)
-> [(Text, Text)] -> Maybe (Element [(Text, Text)])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find (\(Text
n, Text
_) -> Text -> Text
columnNameToFieldName Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fieldName) [(Text, Text)]
referencing in (?schema::Schema) => (Text, Text) -> Text
(Text, Text) -> Text
compileSetQueryBuilder (Text, Text)
Element [(Text, Text)]
ref
            | Text
fieldName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"meta" = Text
"def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }"
            | Bool
otherwise = Text
"def"

        isPrimaryKey :: Text -> Bool
isPrimaryKey Text
name = Element [Text]
Text
name Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` PrimaryKeyConstraint -> [Text]
primaryKeyColumnNames CreateTable
table.primaryKeyConstraint
        isColumn :: Text -> Bool
isColumn Text
name = Element [Text]
Text
name Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [Text]
columnNames
        isManyToManyField :: Text -> Bool
isManyToManyField Text
fieldName = Element [Text]
Text
fieldName Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` ([(Text, Text)]
referencing [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> Text
columnNameToFieldName (Text -> Text) -> ((Text, Text) -> Text) -> (Text, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst))

        compileSetQueryBuilder :: (Text, Text) -> Text
compileSetQueryBuilder (Text
refTableName, Text
refFieldName) = Text
"(QueryBuilder.filterWhere (#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
refFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
primaryKeyField Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") (QueryBuilder.query @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
refTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
            where
                -- | When the referenced column is nullable, we have to wrap the @Id@ in @Just@
                primaryKeyField :: Text
                primaryKeyField :: Text
primaryKeyField = if Column
refColumn.notNull then Text
"id" else Text
"Just id"

                (Just Statement
refTable) = let (Schema [Statement]
statements) = ?schema::Schema
Schema
?schema in
                        [Statement]
statements
                        [Statement] -> ([Statement] -> Maybe Statement) -> Maybe Statement
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element [Statement] -> Bool)
-> [Statement] -> Maybe (Element [Statement])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find \case
                                StatementCreateTable CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name } -> Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
refTableName
                                Element [Statement]
otherwise -> Bool
False

                refColumn :: Column
                refColumn :: Column
refColumn = Statement
refTable
                        Statement -> (Statement -> [Column]) -> [Column]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case StatementCreateTable CreateTable { [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns } -> [Column]
columns
                        [Column] -> ([Column] -> Maybe Column) -> Maybe Column
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element [Column] -> Bool) -> [Column] -> Maybe (Element [Column])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find (\Element [Column]
col -> Element [Column]
Column
col.name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
refFieldName)
                        Maybe Column -> (Maybe Column -> Column) -> Column
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                            Just Column
refColumn -> Column
refColumn
                            Maybe Column
Nothing -> [Char] -> Column
forall a. HasCallStack => [Char] -> a
error (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
"Could not find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Statement
refTable.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint")

        compileQuery :: Column -> Text
compileQuery column :: Column
column@(Column { Text
$sel:name:Column :: Column -> Text
name :: Text
name }) = Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Column -> Text
toBinding Text
modelName Column
column Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        -- compileQuery column@(Column { name }) | isReferenceColum column = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")"
        --compileQuery (HasMany hasManyName inverseOf) = columnNameToFieldName hasManyName <> " = (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow relatedFieldName <> ", " <> (fromJust $ toBinding' (tableNameToModelName name) relatedIdField)  <> ") (QueryBuilder.query @" <> tableNameToModelName hasManyName <>"))"
        --    where
        --        compileInverseOf Nothing = (columnNameToFieldName (singularize name)) <> "Id"
        --        compileInverseOf (Just name) = columnNameToFieldName (singularize name)
        --        relatedFieldName = compileInverseOf inverseOf
        --        relatedIdField = relatedField "id"
        --        relatedForeignKeyField = relatedField relatedFieldName
        --        relatedField :: Text -> Attribute
        --        relatedField relatedFieldName =
        --            let
        --                isFieldName name (Field fieldName _) = (columnNameToFieldName fieldName) == name
        --                (Table _ attributes) = relatedTable
        --            in case find (isFieldName relatedFieldName) (fieldsOnly attributes) of
        --                Just a -> a
        --                Nothing ->
        --                    let (Table tableName _) = relatedTable
        --                    in error (
        --                            "Could not find field "
        --                            <> show relatedFieldName
        --                            <> " in table"
        --                            <> cs tableName
        --                            <> " "
        --                            <> (show $ fieldsOnly attributes)
        --                            <> ".\n\nThis is caused by `+ hasMany " <> show hasManyName <> "`"
        --                        )
        --        relatedTable = case find (\(Table tableName _) -> tableName == hasManyName) database of
        --            Just t -> t
        --            Nothing -> error ("Could not find table " <> show hasManyName)
        --        toBinding' modelName attributes =
        --            case relatedForeignKeyField of
        --                Field _ fieldType | allowNull fieldType -> Just $ "Just (" <> fromJust (toBinding modelName attributes) <> ")"
        --                otherwise -> toBinding modelName attributes

compileBuild :: (?schema :: Schema) => CreateTable -> Text
compileBuild :: (?schema::Schema) => CreateTable -> Text
compileBuild table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) =
        Text
"instance Record " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    {-# INLINE newRecord #-}\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    newRecord = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
toDefaultValueExpr [Column]
columns) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ((?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable Text
name [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> (Text, Text) -> Text
forall a b. a -> b -> a
const Text
"def") [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" def\n"


compileDefaultIdInstance :: CreateTable -> Text
compileDefaultIdInstance :: CreateTable -> Text
compileDefaultIdInstance CreateTable
table = Text
"instance Default (Id' \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CreateTable
table.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\") where def = Id def"


toDefaultValueExpr :: Column -> Text
toDefaultValueExpr :: Column -> Text
toDefaultValueExpr Column { PostgresType
$sel:columnType:Column :: Column -> PostgresType
columnType :: PostgresType
columnType, Bool
$sel:notNull:Column :: Column -> Bool
notNull :: Bool
notNull, $sel:defaultValue:Column :: Column -> Maybe Expression
defaultValue = Just Expression
theDefaultValue } =
            let
                wrapNull :: Bool -> a -> a
wrapNull Bool
False a
value = a
"(Just " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
value a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"
                wrapNull Bool
True a
value = a
value

                isNullExpr :: Expression -> Bool
isNullExpr (VarExpression Text
varName) = Text -> Text
forall t. Textual t => t -> t
toUpper Text
varName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"NULL"
                isNullExpr Expression
_ = Bool
False

                -- We remove type casts here, as we need the actual value literal for setting our default value
                theNormalizedDefaultValue :: Expression
theNormalizedDefaultValue = Expression
theDefaultValue Expression -> (Expression -> Expression) -> Expression
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Expression -> Expression
SchemaDesigner.removeTypeCasts
            in
                if Expression -> Bool
isNullExpr Expression
theDefaultValue
                    then Text
"Nothing"
                    else
                        case PostgresType
columnType of
                            PostgresType
PText -> case Expression
theNormalizedDefaultValue of
                                TextExpression Text
value -> Bool -> Text -> Text
forall {a}. (Semigroup a, IsString a) => Bool -> a -> a
wrapNull Bool
notNull (Text -> Text
forall a. Show a => a -> Text
tshow Text
value)
                                Expression
otherwise            -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"toDefaultValueExpr: TEXT column needs to have a TextExpression as default value. Got: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expression -> [Char]
forall a. Show a => a -> [Char]
show Expression
otherwise)
                            PostgresType
PBoolean -> case Expression
theNormalizedDefaultValue of
                                VarExpression Text
value -> Bool -> Text -> Text
forall {a}. (Semigroup a, IsString a) => Bool -> a -> a
wrapNull Bool
notNull (Bool -> Text
forall a. Show a => a -> Text
tshow (Text -> Text
forall t. Textual t => t -> t
toLower Text
value Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true"))
                                Expression
otherwise           -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"toDefaultValueExpr: BOOL column needs to have a VarExpression as default value. Got: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expression -> [Char]
forall a. Show a => a -> [Char]
show Expression
otherwise)
                            PostgresType
PDouble -> case Expression
theNormalizedDefaultValue of
                                DoubleExpression Double
value -> Bool -> Text -> Text
forall {a}. (Semigroup a, IsString a) => Bool -> a -> a
wrapNull Bool
notNull (Double -> Text
forall a. Show a => a -> Text
tshow Double
value)
                                IntExpression Int
value -> Bool -> Text -> Text
forall {a}. (Semigroup a, IsString a) => Bool -> a -> a
wrapNull Bool
notNull (Int -> Text
forall a. Show a => a -> Text
tshow Int
value)
                                Expression
otherwise           -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"toDefaultValueExpr: DOUBLE column needs to have a DoubleExpression as default value. Got: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expression -> [Char]
forall a. Show a => a -> [Char]
show Expression
otherwise)
                            PostgresType
_ -> Text
"def"
toDefaultValueExpr Column
_ = Text
"def"

compileHasTableNameInstance :: (?schema :: Schema) => CreateTable -> Text
compileHasTableNameInstance :: (?schema::Schema) => CreateTable -> Text
compileHasTableNameInstance table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name }) =
    Text
"type instance GetTableName (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> Text -> Text
forall a b. a -> b -> a
const Text
"_") ((?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
") = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"type instance GetModelByTableName " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

compilePrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text
compilePrimaryKeyInstance :: (?schema::Schema) => CreateTable -> Text
compilePrimaryKeyInstance table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns, [Constraint]
constraints :: [Constraint]
$sel:constraints:CreateTable :: CreateTable -> [Constraint]
constraints }) = [trimming|
    type instance PrimaryKey $symbol = $idType
|]
    where
        symbol :: Text
symbol = Text -> Text
forall a. Show a => a -> Text
tshow Text
name
        idType :: Text
        idType :: Text
idType = case CreateTable -> [Column]
primaryKeyColumns CreateTable
table of
                [] -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". At least one primary key is required."
                [Column
column] -> PostgresType -> Text
atomicType Column
column.columnType -- PrimaryKey User = UUID
                [Column]
cs -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", " ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
colType [Column]
cs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" -- PrimaryKey PostsTag = (Id' "posts", Id' "tags")
            where
                colType :: Column -> Text
colType Column
column = (?schema::Schema) => CreateTable -> Column -> Text
CreateTable -> Column -> Text
haskellType CreateTable
table Column
column

compileFilterPrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text
compileFilterPrimaryKeyInstance :: (?schema::Schema) => CreateTable -> Text
compileFilterPrimaryKeyInstance table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns, [Constraint]
$sel:constraints:CreateTable :: CreateTable -> [Constraint]
constraints :: [Constraint]
constraints }) = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [i|
instance QueryBuilder.FilterPrimaryKey "#{name}" where
    filterWhereId #{primaryKeyPattern} builder =
        builder |> #{intercalate " |> " primaryKeyFilters}
    {-# INLINE filterWhereId #-}
|]
    where
        primaryKeyPattern :: Text
primaryKeyPattern = case CreateTable -> [Column]
primaryKeyColumns CreateTable
table of
            [] -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". At least one primary key is required."
            [Column
c] -> Column
c.name
            [Column]
cs -> Text
"(Id (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", " ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> Text
columnNameToFieldName (Text -> Text) -> (Column -> Text) -> Column -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (.name)) [Column]
cs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"

        primaryKeyFilters :: [Text]
        primaryKeyFilters :: [Text]
primaryKeyFilters = (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
primaryKeyFilter ([Column] -> [Text]) -> [Column] -> [Text]
forall a b. (a -> b) -> a -> b
$ CreateTable -> [Column]
primaryKeyColumns CreateTable
table

        primaryKeyFilter :: Column -> Text
        primaryKeyFilter :: Column -> Text
primaryKeyFilter Column {Text
$sel:name:Column :: Column -> Text
name :: Text
name} = Text
"QueryBuilder.filterWhere (#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

compileTableInstance :: (?schema :: Schema) => CreateTable -> Text
compileTableInstance :: (?schema::Schema) => CreateTable -> Text
compileTableInstance table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns, [Constraint]
$sel:constraints:CreateTable :: CreateTable -> [Constraint]
constraints :: [Constraint]
constraints }) = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [i|
instance #{instanceHead} where
    tableName = \"#{name}\"
    tableNameByteString = Data.Text.Encoding.encodeUtf8 \"#{name}\"
    columnNames = #{columnNames}
    primaryKeyCondition #{pattern} = #{condition}
    {-# INLINABLE primaryKeyCondition #-}
|]
    where
        instanceHead :: Text
        instanceHead :: Text
instanceHead = Text
instanceConstraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => Table (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            where
                instanceConstraints :: Text
instanceConstraints =
                    CreateTable
table
                    CreateTable -> (CreateTable -> [Column]) -> [Column]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> CreateTable -> [Column]
primaryKeyColumns
                    [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name)
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
columnNameToFieldName
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Element [Text] -> Bool) -> [Text] -> [Text]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\Element [Text]
field -> Element [Text]
field Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` ((?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table))
                    [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
field -> Text
"ToField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
field)
                    [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", "
                    Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \Text
inner -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

        primaryKeyColumnNames :: [Text]
        primaryKeyColumnNames :: [Text]
primaryKeyColumnNames = (CreateTable -> [Column]
primaryKeyColumns CreateTable
table) [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name)

        primaryKeyFieldNames :: [Text]
        primaryKeyFieldNames :: [Text]
primaryKeyFieldNames = [Text]
primaryKeyColumnNames [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
columnNameToFieldName

        pattern :: Text
        pattern :: Text
pattern = Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" { " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", " [Text]
primaryKeyFieldNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" }"

        condition :: Text
        condition :: Text
condition = CreateTable -> [Column]
primaryKeyColumns CreateTable
table
                [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
primaryKeyToCondition
                [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
Text
", "
                Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \Text
listInner -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
listInner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

        primaryKeyToCondition :: Column -> Text
        primaryKeyToCondition :: Column -> Text
primaryKeyToCondition Column
column = Text
"(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Column
column.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\", toField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Column
column.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

        columnNames :: Text
columnNames = [Column]
columns
                [Column] -> ([Column] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name)
                [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
forall a. Show a => a -> Text
tshow

compileGetModelName :: (?schema :: Schema) => CreateTable -> Text
compileGetModelName :: (?schema::Schema) => CreateTable -> Text
compileGetModelName table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name }) = Text
"type instance GetModelName (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> Text -> Text
forall a b. a -> b -> a
const Text
"_") ((?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
") = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow (Text -> Text
tableNameToModelName Text
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text
compileDataTypePattern :: (?schema::Schema) => CreateTable -> Text
compileDataTypePattern table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name }) = Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords (CreateTable
table CreateTable -> (CreateTable -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst)

compileTypePattern :: (?schema :: Schema) => CreateTable -> Text
compileTypePattern :: (?schema::Schema) => CreateTable -> Text
compileTypePattern table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name }) = Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table)

compileInclude :: (?schema :: Schema) => CreateTable -> Text
compileInclude :: (?schema::Schema) => CreateTable -> Text
compileInclude table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = ([Text]
belongsToIncludes [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
hasManyIncludes) [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines
    where
        belongsToIncludes :: [Text]
belongsToIncludes = (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Column -> Text
compileBelongsTo ((Element [Column] -> Bool) -> [Column] -> [Column]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter ((?schema::Schema) => CreateTable -> Column -> Bool
CreateTable -> Column -> Bool
isRefCol CreateTable
table) [Column]
columns)
        hasManyIncludes :: [Text]
hasManyIncludes = (?schema::Schema) => Text -> [(Text, Text)]
Text -> [(Text, Text)]
columnsReferencingTable Text
name
                [(Text, Text)]
-> ([(Text, Text)] -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (\[(Text, Text)]
refs -> [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
zip (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
refs) (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst ([(Text, Text)] -> [(Text, Text)]
compileQueryBuilderFields [(Text, Text)]
refs)))
                [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
compileHasMany
        typeArgs :: [Text]
typeArgs = (?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        modelConstructor :: Text
modelConstructor = Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

        includeType :: Text -> Text -> Text
        includeType :: Text -> Text -> Text
includeType Text
fieldName Text
includedType = Text
"type instance Include " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
fieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
leftModelType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rightModelType
            where
                leftModelType :: Text
leftModelType = [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords (Text
modelConstructorText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
typeArgs)
                rightModelType :: Text
rightModelType = [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords (Text
modelConstructorText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileTypeVariable' [Text]
typeArgs))
                compileTypeVariable' :: Text -> Text
compileTypeVariable' Text
name | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fieldName = Text
includedType
                compileTypeVariable' Text
name = Text
name

        compileBelongsTo :: Column -> Text
        compileBelongsTo :: Column -> Text
compileBelongsTo Column
column = Text -> Text -> Text
includeType (Text -> Text
columnNameToFieldName Column
column.name) (Text
"(GetModelById " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
columnNameToFieldName Column
column.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")

        compileHasMany :: (Text, Text) -> Text
        compileHasMany :: (Text, Text) -> Text
compileHasMany (Text
refTableName, Text
refColumnName) = Text -> Text -> Text
includeType Text
refColumnName (Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
refTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")


compileSetFieldInstances :: (?schema :: Schema) => CreateTable -> Text
compileSetFieldInstances :: (?schema::Schema) => CreateTable -> Text
compileSetFieldInstances table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
compileSetField ((?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields CreateTable
table))
    where
        setMetaField :: Text
setMetaField = Text
"instance SetField \"meta\" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
") MetaBag where\n    {-# INLINE setField #-}\n    setField newValue (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileDataTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tableNameToModelName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (.name) [Column]
columns)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" newValue"
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        typeArgs :: [Text]
typeArgs = (?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table
        compileSetField :: (Text, Text) -> Text
compileSetField (Text
name, Text
fieldType) =
            Text
"instance SetField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
") " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"    {-# INLINE setField #-}\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"    setField newValue (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileDataTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") =\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileAttribute (CreateTable
table CreateTable -> (CreateTable -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst)))
            where
                compileAttribute :: Text -> Text
compileAttribute Text
name'
                    | Text
name' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name = Text
"newValue"
                    | Text
name' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"meta" = Text
"(meta { touchedFields = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" : touchedFields meta })"
                    | Bool
otherwise = Text
name'

compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text
compileUpdateFieldInstances :: (?schema::Schema) => CreateTable -> Text
compileUpdateFieldInstances table :: CreateTable
table@(CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns }) = [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
compileSetField ((?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields CreateTable
table))
    where
        modelName :: Text
modelName = Text -> Text
tableNameToModelName Text
name
        typeArgs :: [Text]
typeArgs = (?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table
        compileSetField :: (Text, Text) -> Text
compileSetField (Text
name, Text
fieldType) = Text
"instance UpdateField " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
") (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
compileTypePattern' Text
name  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valueTypeA Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valueTypeB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n    {-# INLINE updateField #-}\n    updateField newValue (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?schema::Schema) => CreateTable -> Text
CreateTable -> Text
compileDataTypePattern CreateTable
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
compileAttribute (CreateTable
table CreateTable -> (CreateTable -> [(Text, Text)]) -> [(Text, Text)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (?schema::Schema) => CreateTable -> [(Text, Text)]
CreateTable -> [(Text, Text)]
dataFields [(Text, Text)] -> ([(Text, Text)] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst)))
            where
                (Text
valueTypeA, Text
valueTypeB) =
                    if Element [Text]
Text
name Element [Text] -> [Text] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [Text]
typeArgs
                        then (Text
name, Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")
                        else (Text
fieldType, Text
fieldType)

                compileAttribute :: Text -> Text
compileAttribute Text
name'
                    | Text
name' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name = Text
"newValue"
                    | Text
name' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"meta" = Text
"(meta { touchedFields = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" : touchedFields meta })"
                    | Bool
otherwise = Text
name'

                compileTypePattern' ::  Text -> Text
                compileTypePattern' :: Text -> Text
compileTypePattern' Text
name = Text -> Text
tableNameToModelName CreateTable
table.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
f -> if Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name then Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" else Text
f) ((?schema::Schema) => CreateTable -> [Text]
CreateTable -> [Text]
dataTypeArguments CreateTable
table))

compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text
compileHasFieldId :: (?schema::Schema) => CreateTable -> Text
compileHasFieldId table :: CreateTable
table@CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, PrimaryKeyConstraint
$sel:primaryKeyConstraint:CreateTable :: CreateTable -> PrimaryKeyConstraint
primaryKeyConstraint :: PrimaryKeyConstraint
primaryKeyConstraint } = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [i|
instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where
    getField (#{compileDataTypePattern table}) = #{compilePrimaryKeyValue}
    {-# INLINE getField #-}
|]
    where
        compilePrimaryKeyValue :: Text
compilePrimaryKeyValue = case PrimaryKeyConstraint -> [Text]
primaryKeyColumnNames PrimaryKeyConstraint
primaryKeyConstraint of
            [Text
id] -> Text -> Text
columnNameToFieldName Text
id
            [Text]
ids -> Text
"Id (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
commaSep ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
columnNameToFieldName [Text]
ids) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

needsHasFieldId :: CreateTable -> Bool
needsHasFieldId :: CreateTable -> Bool
needsHasFieldId CreateTable { PrimaryKeyConstraint
$sel:primaryKeyConstraint:CreateTable :: CreateTable -> PrimaryKeyConstraint
primaryKeyConstraint :: PrimaryKeyConstraint
primaryKeyConstraint } =
  case PrimaryKeyConstraint -> [Text]
primaryKeyColumnNames PrimaryKeyConstraint
primaryKeyConstraint of
    [] -> Bool
False
    [Text
"id"] -> Bool
False
    [Text]
_ -> Bool
True

primaryKeyColumns :: CreateTable -> [Column]
primaryKeyColumns :: CreateTable -> [Column]
primaryKeyColumns CreateTable { Text
$sel:name:CreateTable :: CreateTable -> Text
name :: Text
name, [Column]
$sel:columns:CreateTable :: CreateTable -> [Column]
columns :: [Column]
columns, PrimaryKeyConstraint
$sel:primaryKeyConstraint:CreateTable :: CreateTable -> PrimaryKeyConstraint
primaryKeyConstraint :: PrimaryKeyConstraint
primaryKeyConstraint } =
    (Text -> Column) -> [Text] -> [Column]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Element [Column]
Text -> Column
getColumn (PrimaryKeyConstraint -> [Text]
primaryKeyColumnNames PrimaryKeyConstraint
primaryKeyConstraint)
  where
    getColumn :: Text -> Element [Column]
getColumn Text
columnName = case (Element [Column] -> Bool) -> [Column] -> Maybe (Element [Column])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
columnName (Text -> Bool) -> (Column -> Text) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (.name)) [Column]
columns of
      Just Element [Column]
c -> Element [Column]
c
      Maybe (Element [Column])
Nothing -> [Char] -> Column
forall a. HasCallStack => [Char] -> a
error ([Char]
"Missing column " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
columnName [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" used in primary key for " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
name)

-- | Indents a block of code with 4 spaces.
--
-- Empty lines are not indented.
indent :: Text -> Text
indent :: Text -> Text
indent Text
code = Text
code
        Text -> (Text -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text]
Text.lines
        [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
forall {a}. (Eq a, IsString a, Semigroup a) => a -> a
indentLine
        [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Text
Text.unlines
    where
        indentLine :: a -> a
indentLine a
""   = a
""
        indentLine a
line = a
"    " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
line

-- | Returns 'True' when the column has an explicit default value or when it's a SERIAL or BIGSERIAL
hasExplicitOrImplicitDefault :: Column -> Bool
hasExplicitOrImplicitDefault :: Column -> Bool
hasExplicitOrImplicitDefault Column
column = case Column
column of
        Column { $sel:defaultValue:Column :: Column -> Maybe Expression
defaultValue = Just Expression
_ } -> Bool
True
        Column { $sel:columnType:Column :: Column -> PostgresType
columnType = PostgresType
PSerial } -> Bool
True
        Column { $sel:columnType:Column :: Column -> PostgresType
columnType = PostgresType
PBigserial } -> Bool
True
        Column
_ -> Bool
False