Merge pull request #1943 from digitallyinduced/ghc-warnings

Ghc warnings

IHP/Controller/FileUpload.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, TypeInType, BlockArguments, DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-}
 
 {-|
 Module: IHP.Controller.FileUpload

IHP/Controller/Param.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, TypeInType, BlockArguments, DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-}
 
 {-|
 Module: IHP.Controller.Param

IHP/ErrorController.hs

@@ -16,22 +16,20 @@ import qualified Network.HTTP.Types.Method as Router
 import qualified Control.Exception as Exception
 import qualified Data.Text as Text
 import IHP.Controller.RequestContext
-import Network.HTTP.Types (status500, status404, status400, status403)
+import Network.HTTP.Types (status500, status400)
 import Network.Wai
 import Network.HTTP.Types.Header
 
 import qualified Text.Blaze.Html5            as H
 import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Data.ByteString.Char8 as ByteString
-import qualified Data.ByteString.Lazy as LBS
 
 import IHP.HSX.QQ (hsx)
 import qualified IHP.ModelSupport as ModelSupport
 import IHP.FrameworkConfig
 import qualified IHP.Environment as Environment
 import IHP.Controller.Context
-import qualified System.Directory as Directory
 import IHP.ApplicationContext
 import IHP.Controller.NotFound (handleNotFound)
 

IHP/Fetch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-}
+{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-}
 {-|
 Module: IHP.Fetch
 Description: fetch, fetchOne, fetchOneOrNothing and friends

IHP/FetchRelated.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes #-}
 {-|
 Module: IHP.FetchRelated
 Description:  Provides fetchRelated, collectionFetchRelated, etc.

IHP/HaskellSupport.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-}
+{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-}
 
 {-|
 Module: IHP.HaskellSupport

IHP/IDE/Data/Controller.hs

@@ -1,7 +1,6 @@
 module IHP.IDE.Data.Controller where
 
 import IHP.ControllerPrelude
-import IHP.Controller.NotFound
 import IHP.IDE.ToolServer.Types
 import IHP.IDE.Data.View.ShowDatabase
 import IHP.IDE.Data.View.ShowTableRows

IHP/Job/Dashboard.hs

@@ -109,7 +109,7 @@ class ( job ~ GetModelByTableName (GetTableName job)
 --
 -- Later functions and typeclasses introduce constraints on the types in this list,
 -- so you'll get a compile error if you try and include a type that is not a job.
-class JobsDashboard (jobs :: [*]) where
+class JobsDashboard (jobs :: [Type]) where
     -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type.
     makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView
 

IHP/Job/Dashboard/Types.hs

@@ -72,7 +72,7 @@ newtype IncludeWrapper (id :: Symbol) job = IncludeWrapper (Include id job)
 -- | Defines controller actions for acting on a dashboard made of some list of types.
 -- Later functions and typeclasses introduce constraints on the types in this list,
 -- so you'll get a compile error if you try and include a type that is not a job.
-data JobsDashboardController authType (jobs :: [*])
+data JobsDashboardController authType (jobs :: [Type])
     = ListJobsAction
     | ListJobAction { jobTableName :: Text, page :: Int }
     -- These actions are used for 'pathTo'. Need  to pass the parameters explicity to know how to build the path

IHP/ModelSupport.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-}
 
 module IHP.ModelSupport
 ( module IHP.ModelSupport
@@ -85,10 +85,8 @@ notConnectedModelContext logger = ModelContext
 
 createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
 createModelContext idleTime maxConnections databaseUrl logger = do
-    numStripes <- GHC.Conc.getNumCapabilities
-    let create = PG.connectPostgreSQL databaseUrl
-    let destroy = PG.close
-    connectionPool <- Pool.createPool create destroy numStripes idleTime maxConnections
+    let poolConfig = Pool.defaultPoolConfig (PG.connectPostgreSQL databaseUrl) PG.close (realToFrac idleTime) maxConnections
+    connectionPool <- Pool.newPool poolConfig
 
     let trackTableReadCallback = Nothing
     let transactionConnection = Nothing
@@ -364,6 +362,8 @@ measureTimeIfLogging queryAction theQuery theParameters = do
 --
 -- *AutoRefresh:* When using 'sqlQuery' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query.
 --
+-- Use 'sqlQuerySingleRow' if you expect only a single row to be returned.
+--
 sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r) => Query -> q -> IO [r]
 sqlQuery theQuery theParameters = do
     measureTimeIfLogging
@@ -374,6 +374,28 @@ sqlQuery theQuery theParameters = do
         theParameters
 {-# INLINABLE sqlQuery #-}
 
+
+-- | Runs a raw sql query, that is expected to return a single result row
+--
+-- Like 'sqlQuery', but useful when you expect only a single row as the result
+--
+-- __Example:__
+--
+-- > user <- sqlQuerySingleRow "SELECT id, firstname, lastname FROM users WHERE id = ?" (Only user.id)
+--
+-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
+--
+-- *AutoRefresh:* When using 'sqlQuerySingleRow' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query.
+--
+sqlQuerySingleRow :: (?modelContext :: ModelContext, PG.ToRow query, PG.FromRow record) => Query -> query -> IO record
+sqlQuerySingleRow theQuery theParameters = do
+    result <- sqlQuery theQuery theParameters
+    case result of
+        [] -> error ("sqlQuerySingleRow: Expected a single row to be returned. Query: " <> show theQuery)
+        [record] -> pure record
+        otherwise -> error ("sqlQuerySingleRow: Expected a single row to be returned. But got " <> show (length otherwise) <> " rows")
+{-# INLINABLE sqlQuerySingleRow #-}
+
 -- | Runs a sql statement (like a CREATE statement)
 --
 -- __Example:__

IHP/Prelude.hs

@@ -41,6 +41,7 @@ module IHP.Prelude
 , module Control.Concurrent.Async
 , module NeatInterpolation
 , module GHC.Stack
+, module Data.Kind
 )
 where
 
@@ -56,7 +57,6 @@ import qualified Data.Text as Text
 import Data.Proxy (Proxy (Proxy))
 import Control.Monad (when, unless, mapM, mapM_, forM, forM_, sequence, sequence_, join, forever)
 import Data.List hiding (head, last, unwords, unlines, words, lines, isPrefixOf, isSuffixOf, isInfixOf, intercalate, intersperse, (++), splitAt, null, tail, init)
-import qualified Data.List as List
 import Data.String.Conversions (ConvertibleStrings (convertString), cs)
 import Data.Time.Clock
 import Data.Time.Calendar
@@ -77,6 +77,7 @@ import Control.Monad.Fail (fail)
 import Control.Concurrent.Async
 import NeatInterpolation (trimming)
 import GHC.Stack (HasCallStack, CallStack)
+import Data.Kind (Type)
 
 -- Alias for haskell newcomers :)
 a ++ b = a <> b
@@ -92,28 +93,28 @@ error message = Prelude.error (Text.unpack message)
 
 head :: [a] -> Maybe a
 head [] = Nothing
-head list = Just (List.head list)
+head (firstItem:rest) = Just firstItem
 
 headMay :: [a] -> Maybe a
 headMay = head
 
 last :: [a] -> Maybe a
 last [] = Nothing
-last list = Just (List.last list)
+last [item] = Just item
+last (_:rest) = last rest
 
 lastMay :: [a] -> Maybe a
 lastMay = last
 
 tail :: [a] -> Maybe [a]
+tail (_:rest) = Just rest
 tail [] = Nothing
-tail list = Just (List.tail list)
 
 tailMay :: [a] -> Maybe [a]
 tailMay = tail
 
 init :: [a] -> Maybe [a]
-init [] = Nothing
-init list = Just (List.init list)
+init list = fst <$> (unsnoc list)
 
 initMay :: [a] -> Maybe [a]
 initMay = init

IHP/QueryBuilder.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-}
+{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-}
 {-|
 Module: IHP.QueryBuilder
 Description:  Tool to build simple sql queries
@@ -539,7 +539,7 @@ filterWhereNotJoinedTable (name, value) queryBuilderProvider = injectQueryBuilde
 --
 -- For negation use 'filterWhereNotIn'
 --
-filterWhereIn :: forall name table model value queryBuilderProvider (joinRegister :: *). (KnownSymbol table, KnownSymbol name, ToField value, HasField name model value, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, EqOrIsOperator value, Table model) => (Proxy name, [value]) -> queryBuilderProvider table -> queryBuilderProvider table
+filterWhereIn :: forall name table model value queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, KnownSymbol name, ToField value, HasField name model value, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, EqOrIsOperator value, Table model) => (Proxy name, [value]) -> queryBuilderProvider table -> queryBuilderProvider table
 filterWhereIn (name, value) queryBuilderProvider =
         case head nullValues of
             Nothing -> injectQueryBuilder whereInQuery -- All values non null
@@ -831,7 +831,7 @@ filterWhereCaseInsensitive (name, value) queryBuilderProvider = injectQueryBuild
 {-# INLINE filterWhereCaseInsensitive #-}
 
 
-filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: *). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table
+filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table
 filterWhereIdIn values queryBuilderProvider =
     -- We don't need to treat null values differently here, because primary keys imply not-null
     let

IHP/SchemaCompiler.hs

@@ -545,7 +545,7 @@ compileCreate table@(CreateTable { name, columns }) =
         <> indent (
             "create :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n"
                 <> "create model = do\n"
-                <> indent ("List.head <$> sqlQuery \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING " <> columnNames <> "\" (" <> compileToRowValues bindings <> ")\n")
+                <> indent ("sqlQuerySingleRow \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING " <> columnNames <> "\" (" <> compileToRowValues bindings <> ")\n")
                 <> "createMany [] = pure []\n"
                 <> "createMany models = do\n"
                 <> indent ("sqlQuery (Query $ \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" <> values <> ")\") models)) <> \" RETURNING " <> columnNames <> "\") " <> createManyFieldValues <> "\n"
@@ -595,7 +595,7 @@ compileUpdate table@(CreateTable { name, columns }) =
         "instance CanUpdate " <> modelName <> " where\n"
         <> indent ("updateRecord model = do\n"
                 <> indent (
-                    "List.head <$> sqlQuery \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n"
+                    "sqlQuerySingleRow \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n"
                 )
             )
 

IHP/Test/Database.hs

@@ -6,12 +6,10 @@ import qualified Database.PostgreSQL.Simple.Types as PG
 import qualified Data.UUID.V4 as UUID
 import qualified Data.UUID as UUID
 import qualified Data.Text as Text
-import qualified Data.ByteString as ByteString
 import qualified IHP.LibDir as LibDir
 import qualified Control.Exception as Exception
 
 import qualified System.Process as Process
-import qualified System.Directory as Directory
 
 data TestDatabase = TestDatabase
     { name :: Text