Merge pull request #1969 from digitallyinduced/ihp-log

Some small improvements

IHP/Log/Types.hs

@@ -69,11 +69,11 @@ show = tshow
 -- logging operations. Users can also access this though the 'LoggingProvider'
 -- class in controller and model actions to perform logic based on the set log level.
 data Logger = Logger {
-    write     :: (FastLogger.FormattedTime -> LogStr) -> IO (),
-    level     :: LogLevel,
-    formatter :: LogFormatter,
-    timeCache :: IO FastLogger.FormattedTime,
-    cleanup   :: IO ()
+    write     :: !((FastLogger.FormattedTime -> LogStr) -> IO ()),
+    level     :: !LogLevel,
+    formatter :: !LogFormatter,
+    timeCache :: !(IO FastLogger.FormattedTime),
+    cleanup   :: !(IO ())
 }
 
 data LogLevel
@@ -145,7 +145,7 @@ data RotateSettings
     --      destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize
     --      }
     -- @
-    | SizeRotate Bytes Int
+    | SizeRotate !Bytes !Int
     -- | Log messages to a file rotated on a timed basis.
     -- Expects a time format string as well as a function which compares two formatted time strings
     -- which is used to determine if the file should be rotated.
@@ -168,19 +168,19 @@ data RotateSettings
     --          defaultBufSize
     --        }
     -- @
-    | TimedRotate TimeFormat (FastLogger.FormattedTime -> FastLogger.FormattedTime -> Bool) (FilePath -> IO ())
+    | TimedRotate !TimeFormat (FastLogger.FormattedTime -> FastLogger.FormattedTime -> Bool) (FilePath -> IO ())
 
 -- | Where logged messages will be delivered to.
 data LogDestination
     = None
     -- | Log messages to standard output.
-    | Stdout BufSize
+    | Stdout !BufSize
     -- | Log messages to standard error.
-    | Stderr BufSize
+    | Stderr !BufSize
     -- | Log message to a file. Rotate the log file with the behavior given by 'RotateSettings'.
-    | File FilePath RotateSettings BufSize
+    | File !FilePath !RotateSettings !BufSize
     -- | Send logged messages to a callback. Flush action called after every log.
-    | Callback (LogStr -> IO ()) (IO ())
+    | Callback !(LogStr -> IO ()) !(IO ())
 
 data LoggerSettings = LoggerSettings {
     level       :: LogLevel,

Test/SchemaCompilerSpec.hs

@@ -403,9 +403,7 @@ tests = do
                     data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (Id' "landing_pages"), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show)
 
                     type instance PrimaryKey "landing_pages" = UUID
-                    type instance Include "paragraphCtasLandingPages" (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) = LandingPage' [ParagraphCta] paragraphCtasToLandingPages
-                    type instance Include "paragraphCtasToLandingPages" (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) = LandingPage' paragraphCtasLandingPages [ParagraphCta]
-
+
                     type LandingPage = LandingPage' (QueryBuilder.QueryBuilder "paragraph_ctas") (QueryBuilder.QueryBuilder "paragraph_ctas")
 
                     type instance GetTableName (LandingPage' _ _) = "landing_pages"

ihp-ide/IHP/SchemaCompiler.hs

@@ -42,16 +42,23 @@ compileModules options schema =
     [ ("build/Generated/Types.hs", compileIndex schema)
     ]
 
-tableModules :: CompilerOptions -> Schema -> [(FilePath, Text)]
-tableModules options schema =
+applyTables :: (CreateTable -> (FilePath, Text)) -> Schema -> [(FilePath, Text)]
+applyTables applyFunction schema =
     let ?schema = schema
     in
         schema.statements
         |> mapMaybe (\case
-                StatementCreateTable t | tableHasPrimaryKey t -> Just (tableModule options t)
+                StatementCreateTable table | tableHasPrimaryKey table -> Just (applyFunction table)
                 otherwise -> Nothing
             )
 
+tableModules :: CompilerOptions -> Schema -> [(FilePath, Text)]
+tableModules options schema =
+    let ?schema = schema
+    in
+        applyTables (tableModule options) schema
+        <> applyTables tableIncludeModule schema
+
 tableModule :: (?schema :: Schema) => CompilerOptions -> CreateTable -> (FilePath, Text)
 tableModule options table =
         ("build/Generated/" <> cs (tableNameToModelName table.name) <> ".hs", body)
@@ -70,6 +77,19 @@ tableModule options table =
             import Generated.ActualTypes
         |]
 
+tableIncludeModule :: (?schema :: Schema) => CreateTable -> (FilePath, Text)
+tableIncludeModule table =
+        ("build/Generated/" <> cs (tableNameToModelName table.name) <> "Include.hs", prelude <> compileInclude table)
+    where
+        moduleName = "Generated." <> tableNameToModelName table.name <> "Include"
+        prelude = [trimming|
+            -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"
+            module $moduleName where
+            import Generated.ActualTypes
+            import IHP.ModelSupport (Include, GetModelById)
+        |]
+
+
 tableModuleBody :: (?schema :: Schema) => CompilerOptions -> CreateTable -> Text
 tableModuleBody options table = Text.unlines
     [ compileInputValueInstance table
@@ -183,7 +203,6 @@ compileActualTypesForTable :: (?schema :: Schema) => CreateTable -> Text
 compileActualTypesForTable table = Text.unlines
     [ compileData table
     , compilePrimaryKeyInstance table
-    , compileInclude table
     , compileTypeAlias table
     , compileHasTableNameInstance table
     , compileDefaultIdInstance table
@@ -193,19 +212,23 @@ compileActualTypesForTable table = Text.unlines
 compileIndex :: Schema -> Text
 compileIndex schema = [trimming|
         -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"
-        {-# 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 =
                 schema.statements
-                |> mapMaybe (\case
-                        StatementCreateTable table -> Just ("Generated." <> tableNameToModelName table.name)
-                        otherwise -> Nothing
+                |> map (\case
+                        StatementCreateTable table ->
+                            let modelName = tableNameToModelName table.name
+                            in
+                                [ "Generated." <> modelName
+                                , "Generated." <> modelName <> "Include"
+                                ]
+                        otherwise -> []
                     )
+                |> concat
             tableModuleImports = tableModuleNames
                     |> map (\name -> "import " <> name)
                     |> Text.unlines
@@ -737,9 +760,7 @@ compileHasTableNameInstance table@(CreateTable { name }) =
     <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n"
 
 compilePrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text
-compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [trimming|
-    type instance PrimaryKey $symbol = $idType
-|]
+compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [trimming|type instance PrimaryKey $symbol = $idType|] <> "\n"
     where
         symbol = tshow name
         idType :: Text