Merge pull request #87 from iconnect/adinapoli/issue-84

Generate `shrink` implementations in quickCheckTool

Author: adamgundry

api-tools.cabal

@@ -119,7 +119,7 @@ Library
         -Wall
         -fwarn-tabs
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Executable migration-tool
@@ -138,7 +138,7 @@ Executable migration-tool
         -Wall
         -fwarn-tabs
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Executable perf-test
@@ -159,7 +159,7 @@ Executable perf-test
         -fwarn-tabs
         -rtsopts
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Test-Suite test-api-tools
@@ -200,7 +200,7 @@ Test-Suite test-api-tools
   GHC-Options:
         -Wall
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 Benchmark bench-time
   Hs-Source-Dirs:   bench
@@ -219,4 +219,4 @@ Benchmark bench-time
   GHC-Options:
         -Wall
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021

src/Data/API/API/Gen.hs

@@ -1,7 +1,5 @@
-{-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE TemplateHaskell            #-}
 
 -- | This module contains datatypes generated from the DSL description
 -- of the api-tools API; they thus correspond to the types in

src/Data/API/TH.hs

@@ -6,6 +6,7 @@
 module Data.API.TH
     ( applicativeE
     , optionalInstanceD
+    , optionalStandaloneDerivD
     , funSigD
     , simpleD
     , simpleSigD
@@ -56,6 +57,17 @@ optionalInstanceD stgs c tqs dqs = do
   where
     msg ts = "instance " ++ pprint c ++ " " ++ pprint ts ++ " already exists, so it was not generated"
 
+-- | Adds a "deriving instance" standalone declaration for a class, if such an instance does
+-- not already exist.
+optionalStandaloneDerivD :: ToolSettings -> Name -> [TypeQ] -> Q [Dec]
+optionalStandaloneDerivD stgs c tqs = do
+    ts <- sequence tqs
+    exists <- isInstance c ts
+    if exists then do when (warnOnOmittedInstance stgs) $ reportWarning $ msg ts
+                      return []
+              else pure [StandaloneDerivD Nothing [] (foldl AppT (ConT c) ts)]
+  where
+    msg ts = "instance " ++ pprint c ++ " " ++ pprint ts ++ " already exists, so it was not generated"
 
 -- | Construct a TH function with a type signature
 funSigD :: Name -> TypeQ -> [ClauseQ] -> Q [Dec]

src/Data/API/Tools.hs

@@ -20,6 +20,7 @@ module Data.API.Tools
     , defaultToolSettings
     , warnOnOmittedInstance
     , newtypeSmartConstructors
+    , defaultDerivedClasses
 
       -- * Individual tools
     , enumTool
@@ -56,15 +57,14 @@ import           Data.API.Types
 import qualified Data.Monoid                    as Monoid
 import           Language.Haskell.TH
 
-
 -- | Generate the datatypes corresponding to an API.
 generate :: API -> Q [Dec]
 generate = generateWith defaultToolSettings
 
 -- | Generate the datatypes corresponding to an API, allowing the
 -- 'ToolSettings' to be overriden.
 generateWith :: ToolSettings -> API -> Q [Dec]
-generateWith ts api = generateAPIToolsWith ts api [datatypesTool]
+generateWith ts api = generateAPIToolsWith ts api [datatypesTool ts]
 
 -- | Apply a list of tools to an 'API', generating TH declarations.
 -- See the individual tool descriptions for details.  Note that

src/Data/API/Tools/Combinators.hs

@@ -22,13 +22,16 @@ module Data.API.Tools.Combinators
     , warnOnOmittedInstance
     , newtypeSmartConstructors
     , defaultToolSettings
+    , defaultDerivedClasses
     ) where
 
 import           Data.API.Types
 
 import           Control.Applicative
 import           Data.Monoid
 import           Data.Semigroup as Sem
+import           Data.String
+import           Data.Typeable
 import           Language.Haskell.TH
 import           Prelude
 
@@ -43,15 +46,41 @@ data ToolSettings = ToolSettings
     , newtypeSmartConstructors :: Bool
       -- ^ Rename the constructors of filtered newtypes and generate
       -- smart constructors that enforce the invariants
+    , defaultDerivedClasses :: APINode -> [Name]
+      -- ^ The classes which are derived automatically for datatypes created by 'datatypesTool'.
     }
 
 -- | Default settings designed to be overridden.
 defaultToolSettings :: ToolSettings
 defaultToolSettings = ToolSettings
     { warnOnOmittedInstance = False
     , newtypeSmartConstructors = False
+    , defaultDerivedClasses = default_derived_classes
     }
 
+-- | Default names of classes for which to derive instances, depending
+-- on the type of API node.
+default_derived_classes :: APINode -> [Name]
+default_derived_classes an = case anSpec an of
+    SpNewtype sn -> case snType sn of
+                      BTstring -> ''IsString : derive_leaf_nms
+                      BTbinary -> derive_leaf_nms
+                      BTbool   -> derive_leaf_nms
+                      BTint    -> derive_leaf_nms
+                      BTutc    -> derive_leaf_nms
+    SpRecord  _  -> derive_node_nms
+    SpUnion   _  -> derive_node_nms
+    SpEnum    _  -> derive_leaf_nms ++ [''Bounded, ''Enum]
+    SpSynonym _  -> []
+
+derive_leaf_nms :: [Name]
+derive_leaf_nms = [''Show,''Eq,''Ord,''Typeable]
+
+derive_node_nms :: [Name]
+derive_node_nms = [''Show,''Eq,''Typeable]
+
+
+
 -- | A @'Tool' a@ is something that can generate TH declarations from
 -- a value of type @a@.  Tools can be combined using the 'Monoid'
 -- instance.

src/Data/API/Tools/Datatypes.hs

@@ -2,19 +2,20 @@
 module Data.API.Tools.Datatypes
     ( datatypesTool
     , datatypesTool'
-    , defaultDerivedClasses
     , type_nm
     , rep_type_nm
     , nodeT
     , nodeRepT
     , nodeConE
     , nodeConP
     , nodeNewtypeConE
+    , nodeNewtypeConP
     , nodeFieldE
     , nodeFieldP
     , nodeAltConE
     , nodeAltConP
     , newtypeProjectionE
+    , pref_field_nm
     ) where
 
 import           Data.API.TH
@@ -30,15 +31,14 @@ import           Data.Maybe
 import           Data.String
 import qualified Data.Text                      as T
 import           Data.Time
-import           Data.Typeable
 import           Language.Haskell.TH
 import           Text.Regex
 import           Prelude
 
 
 -- | Tool to generate datatypes and type synonyms corresponding to an API
-datatypesTool :: APITool
-datatypesTool = datatypesTool' defaultDerivedClasses
+datatypesTool :: ToolSettings -> APITool
+datatypesTool = datatypesTool' . defaultDerivedClasses
 
 -- | Tool to generate datatypes and type synonyms corresponding to an
 -- API, where the function specifies the derived classes for each datatype.
@@ -163,28 +163,6 @@ basic_type bt =
       BTutc    -> ConT ''UTCTime
 
 
--- | Default names of classes for which to derive instances, depending
--- on the type of API node.
-defaultDerivedClasses :: APINode -> [Name]
-defaultDerivedClasses an = case anSpec an of
-    SpNewtype sn -> case snType sn of
-                      BTstring -> ''IsString : derive_leaf_nms
-                      BTbinary -> derive_leaf_nms
-                      BTbool   -> derive_leaf_nms
-                      BTint    -> derive_leaf_nms
-                      BTutc    -> derive_leaf_nms
-    SpRecord  _  -> derive_node_nms
-    SpUnion   _  -> derive_node_nms
-    SpEnum    _  -> derive_leaf_nms ++ [''Bounded, ''Enum]
-    SpSynonym _  -> []
-
-derive_leaf_nms :: [Name]
-derive_leaf_nms = [''Show,''Eq,''Ord,''Typeable]
-
-derive_node_nms :: [Name]
-derive_node_nms = [''Show,''Eq,''Typeable]
-
-
 -- | Name of the type corresponding to the API node, e.g. @JobId@
 type_nm :: APINode -> Name
 type_nm an = mkName $ T.unpack $ _TypeName $ anName an
@@ -252,6 +230,9 @@ nodeConP an = conP (rep_type_nm an)
 nodeNewtypeConE :: ToolSettings -> APINode -> SpecNewtype -> ExpQ
 nodeNewtypeConE ts an sn = conE $ newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an
 
+nodeNewtypeConP :: ToolSettings -> APINode -> SpecNewtype -> [Q Pat] -> PatQ
+nodeNewtypeConP ts an sn ps = conP (newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an) ps
+
 -- | A record field in an API node, as an expression
 nodeFieldE :: APINode -> FieldName -> ExpQ
 nodeFieldE an fnm = varE $ pref_field_nm an fnm