Try to generate shrinkers without generics

Implement:

* `shrinkNewtype` to shrink `SpecNewType`;
* `shrinkUnion`   to shrink `SpecUnion`;
* `SpecEnum` does not shrink;
* `shrinkRecord`  (partially implemented) to shrink `SpecRecord`;

Author: adinapoli

api-tools.cabal

@@ -125,7 +125,7 @@ Library
         -Wall
         -fwarn-tabs
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Executable migration-tool
@@ -144,7 +144,7 @@ Executable migration-tool
         -Wall
         -fwarn-tabs
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Executable perf-test
@@ -165,7 +165,7 @@ Executable perf-test
         -fwarn-tabs
         -rtsopts
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 
 Test-Suite test-api-tools
@@ -206,7 +206,7 @@ Test-Suite test-api-tools
   GHC-Options:
         -Wall
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021
 
 Benchmark bench-time
   Hs-Source-Dirs:   bench
@@ -225,4 +225,4 @@ Benchmark bench-time
   GHC-Options:
         -Wall
 
-  Default-Language: Haskell2010
+  Default-Language: GHC2021

src/Data/API/API/Gen.hs

@@ -4,6 +4,9 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | This module contains datatypes generated from the DSL description
 -- of the api-tools API; they thus correspond to the types in
@@ -12,13 +15,20 @@ module Data.API.API.Gen where
 
 import           Data.API.API.DSL
 import           Data.API.Tools
-import           GHC.Generics (Generic)
 
 import           Language.Haskell.TH
+import qualified Test.QuickCheck as QC
+import qualified Test.QuickCheck.Arbitrary as QC
+import GHC.Generics
 
 $(generate         apiAPI)
 
-deriving instance Generic TypeRef
+prop_genIsEqual :: (Eq a, Show a, QC.GSubterms (Rep a) a, QC.RecursivelyShrink (Rep a), Generic a, Shrinkable a)
+                => a
+                -> QC.Property
+prop_genIsEqual a = QC.genericShrink a QC.=== shrinkable a
+
+deriving instance Generic TypeRef -- no shrink
 deriving instance Generic Field
 deriving instance Generic Conversion
 deriving instance Generic UTCRange
@@ -32,6 +42,65 @@ deriving instance Generic Filter
 deriving instance Generic DefaultValue
 deriving instance Generic BasicType
 
+instance Shrinkable a => Shrinkable (Maybe a) where
+  shrinkable (Just x) = Nothing : [ Just x' | x' <- shrinkable x ]
+  shrinkable Nothing  = []
+instance Shrinkable TypeRef -- no shrink
+instance Shrinkable Field where
+  shrinkable Field{..} =
+    (Field <$> pure _fd_name <*> shrinkable _fd_type <*> pure _fd_readonly <*> pure _fd_default <*> pure _fd_comment) ++
+    (Field <$> pure _fd_name <*> pure _fd_type <*> QC.shrink _fd_readonly <*> pure _fd_default <*> pure _fd_comment) ++
+    (Field <$> pure _fd_name <*> pure _fd_type <*> pure _fd_readonly <*> shrinkable _fd_default <*> pure _fd_comment) ++
+    (Field <$> pure _fd_name <*> pure _fd_type <*> pure _fd_readonly <*> pure _fd_default <*> QC.shrink _fd_comment)
+instance Shrinkable Conversion -- no shrink
+instance Shrinkable UTCRange where
+  shrinkable (UTCRange x y)   = (UTCRange <$> QC.shrink x <*> pure y) ++
+                                (UTCRange <$> pure x <*> QC.shrink y)
+instance Shrinkable IntRange where
+  shrinkable (IntRange x y)   = (IntRange <$> QC.shrink x <*> pure y) ++
+                                (IntRange <$> pure x <*> QC.shrink y)
+instance Shrinkable RegularExpression where
+  shrinkable (RegularExpression e) = map RegularExpression (QC.shrink e)
+instance Shrinkable SpecNewtype where
+  shrinkable SpecNewtype{..} =
+    (SpecNewtype <$> shrinkable _sn_type <*> pure _sn_filter) ++
+    (SpecNewtype <$> pure _sn_type <*> shrinkable _sn_filter)
+instance Shrinkable APINode where
+  shrinkable APINode{..} =
+    (APINode <$> QC.shrink _an_name  <*> pure _an_comment <*> pure _an_prefix <*> pure _an_spec <*> pure _an_convert) ++
+    (APINode <$> pure _an_name <*> QC.shrink _an_comment <*> pure _an_prefix <*> pure _an_spec <*> pure _an_convert) ++
+    (APINode <$> pure _an_name <*> pure _an_comment <*> QC.shrink _an_prefix <*> pure _an_spec <*> pure _an_convert) ++
+    (APINode <$> pure _an_name <*> pure _an_comment <*> pure _an_prefix <*> shrinkable _an_spec <*> pure _an_convert) ++
+    (APINode <$> pure _an_name <*> pure _an_comment <*> pure _an_prefix <*> pure _an_spec <*> shrinkable _an_convert)
+instance Shrinkable APIType where -- OK
+  shrinkable = \case
+    TY_list  aty -> aty : (TY_list  <$> shrinkable aty)
+    TY_maybe aty -> aty : (TY_maybe <$> shrinkable aty)
+    TY_ref   tre -> TY_ref   <$> shrinkable tre
+    TY_basic bt  -> TY_basic <$> shrinkable bt
+    TY_json  i   -> TY_json <$> QC.shrink i
+instance Shrinkable Spec where -- ok
+  shrinkable = \case
+    SP_newtype  sn -> SP_newtype <$> shrinkable sn
+    SP_record   rc -> SP_record  <$> QC.shrinkList shrinkable rc
+    SP_union    un -> SP_union   <$> QC.shrinkList shrinkable un
+    SP_enum     en -> SP_enum    <$> QC.shrink en  -- rely on QC shrinking for Text
+    SP_synonym  sy -> SP_synonym <$> shrinkable sy
+instance Shrinkable Filter where
+  shrinkable = \case
+      FT_string  re -> FT_string  <$> shrinkable re
+      FT_integer ir -> FT_integer <$> shrinkable ir
+      FT_utc     ur -> FT_utc     <$> shrinkable ur
+instance Shrinkable DefaultValue where
+  shrinkable = \case
+    DV_list    x -> DV_list    <$> QC.shrink x
+    DV_maybe   x -> DV_maybe   <$> QC.shrink x
+    DV_string  x -> DV_string  <$> QC.shrink x
+    DV_boolean x -> DV_boolean <$> QC.shrink x
+    DV_integer x -> DV_integer <$> QC.shrink x
+    DV_utc     x -> DV_utc     <$> QC.shrink x
+instance Shrinkable BasicType -- no shrink
+
 $(generateAPITools apiAPI
                    [ enumTool
                    , jsonTool'

src/Data/API/Tools.hs

@@ -39,6 +39,7 @@ module Data.API.Tools
     , quickCheckTool
     , safeCopyTool
     , samplesTool
+    , Shrinkable(..)
     ) where
 
 import           Data.API.Tools.Combinators
@@ -58,7 +59,6 @@ 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

src/Data/API/Tools/Datatypes.hs

@@ -10,11 +10,13 @@ module Data.API.Tools.Datatypes
     , nodeConE
     , nodeConP
     , nodeNewtypeConE
+    , nodeNewtypeConP
     , nodeFieldE
     , nodeFieldP
     , nodeAltConE
     , nodeAltConP
     , newtypeProjectionE
+    , pref_field_nm
     ) where
 
 import           Data.API.TH
@@ -252,6 +254,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

src/Data/API/Tools/QuickCheck.hs

@@ -11,13 +11,13 @@ import           Data.API.Tools.Combinators
 import           Data.API.Tools.Datatypes
 import           Data.API.Types
 
-import           GHC.Generics
 import           Control.Applicative
+import           Control.Monad
 import           Data.Monoid
 import           Data.Time
 import           Language.Haskell.TH
-import           Test.QuickCheck                as QC
 import           Prelude
+import           Test.QuickCheck                as QC
 
 
 -- | Tool to generate 'Arbitrary' instances for generated types. This tool generates
@@ -26,22 +26,15 @@ import           Prelude
 quickCheckTool :: APITool
 quickCheckTool = apiNodeTool $ apiSpecTool gen_sn_ab gen_sr_ab gen_su_ab gen_se_ab mempty
 
--- | Helper to create an 'Arbitrary' implementation. It will check if we have a 'Generic'
--- instance for the underlying type and, if we have, we will implement 'shrink' in terms of
--- 'genericShrink', otherwise we will just alias it to '[]' (i.e. a no-op). This avoids
--- imposing to the caller a mandatory 'Generic' instance on the type when using this tool,
--- but it will get them a \"shrinker for free\" if they define a 'Generic' instance.
+-- | Helper to create an 'Arbitrary' implementation.
 mkArbitraryInstance :: ToolSettings
                     -> TypeQ
                     -> ExpQ
                     -- ^ The body of the 'arbitrary' method.
+                    -> ExpQ
+                    -- ^ The body of the 'shrink' method.
                     -> Q [Dec]
-mkArbitraryInstance ts typeQ arbitraryBody = do
-  tq         <- sequence [typeQ]
-  hasGeneric <- isInstance ''Generic tq
-  let shrinkBody = case hasGeneric of
-        True  -> [e| genericShrink |]
-        False -> [e| pure [] |]
+mkArbitraryInstance ts typeQ arbitraryBody shrinkBody = do
   optionalInstanceD ts ''QC.Arbitrary [typeQ]
                                       [ simpleD 'arbitrary arbitraryBody
                                       , simpleD 'shrink    shrinkBody
@@ -55,24 +48,38 @@ mkArbitraryInstance ts typeQ arbitraryBody = do
 -- values).
 gen_sn_ab :: Tool (APINode, SpecNewtype)
 gen_sn_ab = mkTool $ \ ts (an, sn) -> case snFilter sn of
-    Nothing | snType sn == BTint    -> mk_instance ts an sn [e| QC.arbitraryBoundedIntegral |]
-            | otherwise             -> mk_instance ts an sn [e| arbitrary |]
-    Just (FtrIntg ir)               -> mk_instance ts an sn [e| arbitraryIntRange ir |]
-    Just (FtrUTC ur)                -> mk_instance ts an sn [e| arbitraryUTCRange ur |]
+    Nothing | snType sn == BTint    -> mk_instance ts an sn [e| QC.arbitraryBoundedIntegral |] (shrinkNewtype ts an sn)
+            | otherwise             -> mk_instance ts an sn [e| arbitrary |] (shrinkNewtype ts an sn)
+    Just (FtrIntg ir)               ->
+      mk_instance ts an sn [e| arbitraryIntRange ir |] (shrinkNewtype ts an sn)
+    Just (FtrUTC ur)                ->
+      mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkNewtype ts an sn)
     Just (FtrStrg _)                -> return []
   where
     mk_instance ts an sn arb =
       mkArbitraryInstance ts (nodeRepT an) [e| fmap $(nodeNewtypeConE ts an sn) $arb |]
 
+    -- shrinking a newtype means calling shrink and repack the newtype.
+    -- Example:
+    -- shrink = \x -> case x of { Foo y -> map Foo (shrink y) }
+    shrinkNewtype ts an sn = do
+      x <- newName "x"
+      y <- newName "y"
+      lamE [varP x] $
+        caseE (varE x) [
+          match (nodeNewtypeConP ts an sn [varP y])
+                (normalB [| map $(nodeNewtypeConE ts an sn) (QC.shrink $(varE y)) |])
+                []
+        ]
 
 -- | Generate an 'Arbitrary' instance for a record:
 --
 -- > instance Arbitrary Foo where
 -- >     arbitrary = sized $ \ x -> Foo <$> resize (x `div` 2) arbitrary <*> ... <*> resize (x `div` 2) arbitrary
--- >     shrink    = genericShrink
+-- >     shrink    = (TH-derived shrinker)
 
 gen_sr_ab :: Tool (APINode, SpecRecord)
-gen_sr_ab = mkTool $ \ ts (an, sr) -> mkArbitraryInstance ts (nodeRepT an) (bdy an sr)
+gen_sr_ab = mkTool $ \ ts (an, sr) -> mkArbitraryInstance ts (nodeRepT an) (bdy an sr) (shrinkRecord an sr)
   where
     -- Reduce size of fields to avoid generating massive test data
     -- by giving an arbitrary implementation like this:
@@ -83,35 +90,78 @@ gen_sr_ab = mkTool $ \ ts (an, sr) -> mkArbitraryInstance ts (nodeRepT an) (bdy
                      replicate (length $ srFields sr) $
                      [e| QC.resize ($(varE x) `div` 2) arbitrary |]
 
+    -- For records, using the same principle behind 'genericShrink', we need
+    -- to generate a list of lists, each sublist being the shrinking of a single
+    -- individual field, and finally mconcat everything together.
+    -- Example:
+    -- shrink = \(Foo a b c) ->
+    --  (Foo <$> shrink a <*> pure b   <*> pure c) ++
+    --  (Foo <$> pure   a <*> shrink b <*> pure c) ++
+    --  (Foo <$> pure   a <*> pure b   <*> shrink c)
+    shrinkRecord :: APINode -> SpecRecord -> ExpQ
+    shrinkRecord an sr = do
+      x <- newName "x"
+      -- Matches the fields of the record with fresh variables
+      -- [( "field1", "field1"), ("field2", "field2") ... ]
+      recordPatterns <-
+        forM (srFields sr) $ \(fn,_) -> do
+          let freshRecName = pref_field_nm an fn
+          freshPatName <- nodeFieldP an fn
+          pure (freshRecName,freshPatName)
+
+      lamE [varP x] $
+        caseE (varE x) [
+          -- temporary, not correct. it won't shrink properly.
+          match (recP nm (map pure recordPatterns))
+                (normalB $ applicativeE (nodeConE an) $
+                   flip map recordPatterns $ \(fld, _pat) ->
+                    [e| QC.shrink $(varE fld) |]
+                ) []
+        ]
+       where
+         nm = rep_type_nm an
 
 -- | Generate an 'Arbitrary' instance for a union:
 --
 -- > instance Arbitrary Foo where
 -- >     arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ]
 
 gen_su_ab :: Tool (APINode, SpecUnion)
-gen_su_ab = mkTool $ \ ts (an, su) -> mkArbitraryInstance ts (nodeRepT an) (bdy an su)
+gen_su_ab = mkTool $ \ ts (an, su) -> mkArbitraryInstance ts (nodeRepT an) (bdy an su) (shrinkUnion an su)
   where
     bdy an su | null (suFields su) = nodeConE an
               | otherwise          = [e| oneof $(listE alts) |]
       where
         alts = [ [e| fmap $(nodeAltConE an k) arbitrary |]
                | (k, _) <- suFields su ]
 
+    -- For a union, we shrink the individual wrappers.
+    shrinkUnion :: APINode -> SpecUnion -> ExpQ
+    shrinkUnion an su = do
+      x <- newName "x"
+      y <- newName "y"
+      lamE [varP x] $ caseE (varE x) (map (shrink_alt y) (suFields su))
+      where
+        shrink_alt y (fn,_) =
+          match (nodeAltConP an fn [varP y])
+                (normalB [| map $(nodeAltConE an fn) (QC.shrink $(varE y)) |])
+                []
 
 -- | Generate an 'Arbitrary' instance for an enumeration:
 --
 -- > instance Arbitrary Foo where
 -- >     arbitrary = elements [Bar, Baz]
 
 gen_se_ab :: Tool (APINode, SpecEnum)
-gen_se_ab = mkTool $ \ ts (an, se) -> mkArbitraryInstance ts (nodeRepT an) (bdy an se)
+gen_se_ab = mkTool $ \ ts (an, se) -> mkArbitraryInstance ts (nodeRepT an) (bdy an se) noShrink
   where
     bdy an se | null ks   = nodeConE an
               | otherwise = varE 'elements `appE` listE ks
       where
         ks = map (nodeAltConE an . fst) $ seAlts se
 
+    noShrink :: ExpQ
+    noShrink = [e| \_ -> [] |]
 
 -- | Generate an arbitrary 'Int' in a given range.
 arbitraryIntRange :: IntRange -> Gen Int

src/Data/API/Types.hs

@@ -30,6 +30,7 @@ module Data.API.Types
     , UTCRange(..)
     , RegEx(..)
     , Binary(..)
+    , Shrinkable(..)
     , defaultValueAsJsValue
     , mkRegEx
     , inIntRange
@@ -474,3 +475,7 @@ $(let deriveJSONs = fmap concat . mapM (deriveJSON defaultOptions)
                  , ''APINode
                  , ''Thing
                  ])
+
+class Shrinkable a where
+  shrinkable :: a -> [a]
+  shrinkable = const []