Clean warnings in persistent

.github/workflows/haskell.yml

@@ -58,7 +58,7 @@ jobs:
     env:
       CONFIG: "--enable-tests --enable-benchmarks"
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
       - uses: haskell/actions/setup@v2
         id: setup-haskell-cabal
         with:

persistent/Database/Persist/Class/PersistEntity.hs

@@ -23,7 +23,7 @@ module Database.Persist.Class.PersistEntity
     , Filter (..)
     , FilterValue (..)
     , BackendSpecificFilter
-    , Entity (.., Entity, entityKey, entityVal)
+    , Entity (..)
 
     , recordName
     , entityValues
@@ -39,8 +39,6 @@ module Database.Persist.Class.PersistEntity
     , SafeToInsertErrorMessage
     ) where
 
-import Data.Functor.Constant
-
 import Data.Aeson
        ( FromJSON(..)
        , ToJSON(..)
@@ -63,7 +61,6 @@ import qualified Data.Aeson.KeyMap as AM
 import qualified Data.HashMap.Strict as AM
 #endif
 
-import GHC.Records
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (isJust)
 import Data.Text (Text)
@@ -553,9 +550,9 @@ instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where
 class SafeToInsert a where
 
 type SafeToInsertErrorMessage a
-    = 'Text "The PersistEntity " ':<>: ShowType a ':<>: 'Text " does not have a default primary key."
+    = 'Text "The PersistEntity " ':<>: 'ShowType a ':<>: 'Text " does not have a default primary key."
     ':$$: 'Text "This means that 'insert' will fail with a database error."
-    ':$$: 'Text "Please  provide a default= clause inthe entity definition,"
+    ':$$: 'Text "Please  provide a default= clause in the entity definition,"
     ':$$: 'Text "or use 'insertKey' instead to provide one."
 
 instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b)

persistent/Database/Persist/Class/PersistField.hs

@@ -29,7 +29,7 @@ import qualified Data.Text.Encoding.Error as TERR
 import qualified Data.Text.Lazy as TL
 import qualified Data.Vector as V
 import Data.Word (Word, Word8, Word16, Word32, Word64)
-import Numeric.Natural (Natural)
+import Numeric.Natural
 import Text.Blaze.Html
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 import GHC.TypeLits
@@ -44,6 +44,7 @@ import Data.Time (defaultTimeLocale)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 #endif
 
+import Prelude
 
 -- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database.
 --

persistent/Database/Persist/Sql/Run.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+
 module Database.Persist.Sql.Run where
 
 import Control.Monad.IO.Unlift

persistent/Database/Persist/SqlBackend/SqlPoolHooks.hs

@@ -11,6 +11,8 @@ module Database.Persist.SqlBackend.SqlPoolHooks
   , modifyRunAfter
   , setRunAfter
   , getRunOnException
+  , modifyRunOnException
+  , setRunOnException
   )
   where
 
@@ -83,9 +85,15 @@ setRunAfter hooks f = hooks { runAfter = f }
 getRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ())
 getRunOnException = runOnException
 
+-- |
+--
+-- @since 2.14.5.0
 modifyRunOnException :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> SomeException -> m ()) -> (backend -> Maybe IsolationLevel -> SomeException -> m ())) -> SqlPoolHooks m backend
 modifyRunOnException hooks f = hooks { runOnException = f $ runOnException hooks }
 
+-- |
+--
+-- @since 2.14.5.0
 setRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) -> SqlPoolHooks m backend
 setRunOnException hooks f = hooks { runOnException = f }
 

persistent/persistent.cabal

@@ -156,7 +156,7 @@ test-suite test
     hs-source-dirs:
         test/
 
-    ghc-options: -Wall
+    ghc-options: -Wall -Wno-incomplete-uni-patterns
 
     default-extensions: FlexibleContexts
                       , MultiParamTypeClasses

persistent/test/Database/Persist/PersistValueSpec.hs

@@ -2,15 +2,12 @@ module Database.Persist.PersistValueSpec where
 
 import Test.Hspec
 import Database.Persist.PersistValue
-import Data.List.NonEmpty (NonEmpty(..), (<|))
 import qualified Data.Text as T
-import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Data.Aeson
 import qualified Data.ByteString.Char8 as BS8
 
-
 spec :: Spec
 spec = describe "PersistValueSpec" $ do
     describe "PersistValue" $ do

persistent/test/Database/Persist/QuasiSpec.hs

@@ -507,9 +507,9 @@ User
 
     UniqueEmail emailFirst emailSecond
 |]
-                let [user] = parse lowerCaseSettings definitions
+                let user = head $ parse lowerCaseSettings definitions
                     uniques = entityUniques (unboundEntityDef user)
-                    [dbNames] = fmap snd . uniqueFields <$> uniques
+                    dbNames = head $ fmap snd . uniqueFields <$> uniques
                     errMsg = unwords
                         [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\""
                         , "possible fields: [\"name\",\"emailFirst\"]"
@@ -523,7 +523,7 @@ User
     age Text
     Unique some
 |]
-                let [user] = parse lowerCaseSettings definitions
+                let user = head $ parse lowerCaseSettings definitions
                 evaluate (unboundPrimarySpec user) `shouldErrorWithMessage`
                     "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]"
 
@@ -548,10 +548,10 @@ Notification
                 let
                     flippedFK (EntityNameHS entName) (ConstraintNameHS conName) =
                         conName <> entName
-                    [_user, notification] =
-                        parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions
-                    [notificationForeignDef] =
-                        unboundForeignDef <$> unboundForeignDefs notification
+                    (_user, notification) =
+                        listToTwoTuple $ parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions
+                    notificationForeignDef =
+                        head $ unboundForeignDef <$> unboundForeignDefs notification
                 foreignConstraintNameDBName notificationForeignDef
                     `shouldBe`
                         ConstraintNameDB "fk_noti_user_notification"
@@ -571,7 +571,8 @@ Notification
     sentToSecond    Text
     Foreign User
 |]
-                let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                let (_user, notification) =
+                        listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions
                 mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
                     `shouldErrorWithMessage`
                         "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]"
@@ -591,7 +592,8 @@ Notification
     sentToSecond    Text
     Foreign User fk_noti_user
 |]
-                let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                let (_user, notification) =
+                        listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions
                 mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
                     `shouldErrorWithMessage`
                         "No fields on foreign reference."
@@ -611,7 +613,8 @@ Notification
     sentToSecond    Text
     Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst
 |]
-                let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                let (_user, notification) =
+                        listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions
                 mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
                     `shouldErrorWithMessage`
                         "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields"
@@ -631,7 +634,7 @@ Notification
     sentToSecond    Text
     Foreign User OnDeleteCascade OnDeleteCascade
 |]
-                let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                let (_user, notification) = listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions
                 mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
                     `shouldErrorWithMessage`
                         "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions"
@@ -651,16 +654,16 @@ Notification
     sentToSecond    Text
     Foreign User OnUpdateCascade OnUpdateCascade
 |]
-                let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                let (_user, notification) = listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions
                 mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
                     `shouldErrorWithMessage`
                         "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions"
 
             it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do
-                let [_user, notification] =
-                        parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) validDefinitions
-                    [notificationForeignDef] =
-                        unboundForeignDef <$> unboundForeignDefs notification
+                let (_user, notification) =
+                        listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) validDefinitions
+                    notificationForeignDef =
+                        head $ unboundForeignDef <$> unboundForeignDefs notification
                 foreignConstraintNameDBName notificationForeignDef
                     `shouldBe`
                         ConstraintNameDB "notification_fk_noti_user"
@@ -676,7 +679,7 @@ CustomerTransfer
     currencyCode CurrencyCode
     uuid TransferUuid
 |]
-                let [customerTransfer] = parse lowerCaseSettings tickedDefinition
+                let customerTransfer = head $ parse lowerCaseSettings tickedDefinition
                 let expectedType =
                         FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit"
 
@@ -696,7 +699,7 @@ WithFinite
     one    (Finite 1)
     twenty (Labelled "twenty")
 |]
-                let [withFinite] = parse lowerCaseSettings tickedDefinition
+                let withFinite = head $ parse lowerCaseSettings tickedDefinition
 
                 (simplifyField <$> unboundEntityFields withFinite) `shouldBe`
                     [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)))
@@ -1131,7 +1134,7 @@ Baz
                     , "  Extra2"
                     , "    something"
                     ]
-        let [subject] = parse lowerCaseSettings lines
+        let subject = head $ parse lowerCaseSettings lines
         it "produces the right name" $ do
             getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo"
         describe "unboundEntityFields" $ do
@@ -1155,7 +1158,7 @@ Baz
                 , ("Extra2", [["something"]])
                 ]
         describe "works with extra blocks" $ do
-            let [_, lowerCaseTable, idTable] =
+            let (_, lowerCaseTable, idTable) =
                     case parse lowerCaseSettings $ T.unlines
                         [ ""
                         , "IdTable"
@@ -1178,7 +1181,7 @@ Baz
                         , ""
                         ] of
                             [a, b, c] ->
-                                [a, b, c] :: [UnboundEntityDef]
+                                ( a, b, c )
                             xs ->
                                 error
                                 $ "Expected 3 elements in list, got: "
@@ -1227,3 +1230,7 @@ shouldErrorWithMessage action expectedMsg = do
             msg `shouldBe` expectedMsg
         _ ->
             expectationFailure "Expected `error` to have been called"
+
+listToTwoTuple :: HasCallStack => [a] -> (a, a)
+listToTwoTuple [a, b] = (a, b)
+listToTwoTuple xs = error $ "Expected two items in list exactly, got: " <> show (length xs)

persistent/test/Database/Persist/THSpec.hs

@@ -32,7 +32,7 @@ import Data.Functor.Identity (Identity(..))
 import Data.Int
 import qualified Data.List as List
 import Data.Proxy
-import Data.Text (Text, pack)
+import Data.Text (pack)
 import Data.Time
 import GHC.Generics (Generic)
 import System.Environment
@@ -205,9 +205,9 @@ spec = describe "THSpec" $ do
     JsonEncodingSpec.spec
     CommentSpec.spec
     CompositeKeyStyleSpec.spec
+    RequireOnlyPersistImportSpec.spec
+
     describe "TestDefaultKeyCol" $ do
-        let EntityIdField FieldDef{..} =
-                entityId (entityDef (Proxy @TestDefaultKeyCol))
         it "should be a BackendKey SqlBackend" $ do
             -- the purpose of this test is to verify that a custom Id column of
             -- the form: