Allow the user to provide instances that will be derived for all types

yesodweb · Nov 26, 2019 · d054f34 · d054f34
1 parent d79385d
commit d054f34
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 7 deletions.
diff --git a/persistent-template/ChangeLog.md b/persistent-template/ChangeLog.md
@@ -1,5 +1,9 @@
 ## Unreleased changes
 
+## 2.7.4
+
+* Let the user pass instances that will be derived for record and for key types (https://github.com/yesodweb/persistent/pull/990
+
 ## 2.7.3
 
 * Update module documentation for `Database.Persist.TH` to better describe the purpose of the module [#968](https://github.com/yesodweb/persistent/pull/968)

diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
@@ -26,6 +26,7 @@ module Database.Persist.TH
     , mpsPrefixFields
     , mpsEntityJSON
     , mpsGenerateLenses
+    , mpsDeriveInstances
     , EntityJSON(..)
     , mkPersistSettings
     , sqlSettings
@@ -435,6 +436,12 @@ data MkPersistSettings = MkPersistSettings
     -- Default: False
     --
     -- @since 1.3.1
+    , mpsDeriveInstances :: ![Name]
+    -- ^ Automatically derive these typeclass instances for all record and key types.
+    --
+    -- Default: []
+    --
+    -- @since 2.7.4
     }
 
 data EntityJSON = EntityJSON
@@ -457,6 +464,7 @@ mkPersistSettings t = MkPersistSettings
         , entityFromJSON = 'entityIdFromJSON
         }
     , mpsGenerateLenses = False
+    , mpsDeriveInstances = []
     }
 
 -- | Use the 'SqlPersist' backend.
@@ -492,7 +500,9 @@ upperFirst t =
 
 dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec
 dataTypeDec mps t = do
-    let names = map (mkName . unpack) $ entityDerives t
+    let entityInstances     = map (mkName . unpack) $ entityDerives t
+        additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
+        names               = entityInstances <> additionalInstances
 #if MIN_VERSION_template_haskell(2,12,0)
     DataD [] nameFinal paramsFinal
                 Nothing
@@ -792,14 +802,14 @@ mkKeyTypeDec mps t = do
       if mpsGeneric mps
         then if not useNewtype
                then do pfDec <- pfInstD
-                       return (pfDec, [''Generic])
+                       return (pfDec, supplement [''Generic])
                else do gi <- genericNewtypeInstances
-                       return (gi, [])
+                       return (gi, supplement [])
         else if not useNewtype
                then do pfDec <- pfInstD
-                       return (pfDec, [''Show, ''Read, ''Eq, ''Ord, ''Generic])
+                       return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                 else do
-                    let allInstances = [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
+                    let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
                     if customKeyType
                       then return ([], allInstances)
                       else do
@@ -902,6 +912,8 @@ mkKeyTypeDec mps t = do
     useNewtype = pkNewtype mps t
     customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t)
 
+    supplement :: [Name] -> [Name]
+    supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)
 
 keyIdName :: EntityDef -> Name
 keyIdName = mkName . unpack . keyIdText

diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal
@@ -1,5 +1,5 @@
 name:            persistent-template
-version:         2.7.3
+version:         2.7.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -22,13 +23,14 @@ import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Gen (Gen)
+import GHC.Generics (Generic)
 
 import Database.Persist
 import Database.Persist.TH
 import TemplateTestImports
 
 
-share [mkPersist sqlSettings { mpsGeneric = False }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
+share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
 Person json
     name Text
     age Int Maybe