From e5f1a3b3677da2955208f680bfa1b39885bef420 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Tue, 28 Oct 2025 14:05:32 +0100 Subject: [PATCH 1/6] Experiment with shrinking for the quickCheckTool Implement: * `shrinkNewtype` to shrink `SpecNewType`; * `shrinkUnion` to shrink `SpecUnion`; * `SpecEnum` does not shrink; * `shrinkRecord` to shrink `SpecRecord`; --- api-tools.cabal | 11 +-- src/Data/API/API/Gen.hs | 11 ++- src/Data/API/TH.hs | 12 +++ src/Data/API/Tools.hs | 3 +- src/Data/API/Tools/DataTypeable.hs | 35 +++++++++ src/Data/API/Tools/Datatypes.hs | 5 ++ src/Data/API/Tools/QuickCheck.hs | 113 +++++++++++++++++++++++++---- src/Data/API/Types.hs | 4 +- 8 files changed, 168 insertions(+), 26 deletions(-) create mode 100644 src/Data/API/Tools/DataTypeable.hs diff --git a/api-tools.cabal b/api-tools.cabal index f59d7f1..b425489 100644 --- a/api-tools.cabal +++ b/api-tools.cabal @@ -53,6 +53,7 @@ Library Data.API.Tools.CBOR Data.API.Tools.Combinators Data.API.Tools.Datatypes + Data.API.Tools.DataTypeable Data.API.Tools.DeepSeq Data.API.Tools.Enum Data.API.Tools.Example @@ -119,7 +120,7 @@ Library -Wall -fwarn-tabs - Default-Language: Haskell2010 + Default-Language: GHC2021 Executable migration-tool @@ -138,7 +139,7 @@ Executable migration-tool -Wall -fwarn-tabs - Default-Language: Haskell2010 + Default-Language: GHC2021 Executable perf-test @@ -159,7 +160,7 @@ Executable perf-test -fwarn-tabs -rtsopts - Default-Language: Haskell2010 + Default-Language: GHC2021 Test-Suite test-api-tools @@ -200,7 +201,7 @@ Test-Suite test-api-tools GHC-Options: -Wall - Default-Language: Haskell2010 + Default-Language: GHC2021 Benchmark bench-time Hs-Source-Dirs: bench @@ -219,4 +220,4 @@ Benchmark bench-time GHC-Options: -Wall - Default-Language: Haskell2010 + Default-Language: GHC2021 diff --git a/src/Data/API/API/Gen.hs b/src/Data/API/API/Gen.hs index 33daa0f..5505437 100644 --- a/src/Data/API/API/Gen.hs +++ b/src/Data/API/API/Gen.hs @@ -1,7 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 diff --git a/src/Data/API/TH.hs b/src/Data/API/TH.hs index 1f1839b..e8c0ee1 100644 --- a/src/Data/API/TH.hs +++ b/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] diff --git a/src/Data/API/Tools.hs b/src/Data/API/Tools.hs index 2eea3eb..225ef78 100644 --- a/src/Data/API/Tools.hs +++ b/src/Data/API/Tools.hs @@ -24,6 +24,7 @@ module Data.API.Tools -- * Individual tools , enumTool , exampleTool + , dataTypeableTool , deepSeqTool , jsonTool , jsonTool' @@ -41,6 +42,7 @@ module Data.API.Tools ) where import Data.API.Tools.Combinators +import Data.API.Tools.DataTypeable import Data.API.Tools.Datatypes import Data.API.Tools.DeepSeq import Data.API.Tools.Enum @@ -56,7 +58,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 diff --git a/src/Data/API/Tools/DataTypeable.hs b/src/Data/API/Tools/DataTypeable.hs new file mode 100644 index 0000000..b1552f5 --- /dev/null +++ b/src/Data/API/Tools/DataTypeable.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.API.Tools.DataTypeable ( + dataTypeableTool + ) where + +import Prelude + +import Data.API.TH +import Data.API.Tools.Combinators +import Data.API.Tools.Datatypes +import Data.API.Types +import Data.Data + +dataTypeableTool :: APITool +dataTypeableTool = apiNodeTool $ + apiSpecTool gen_sn_to gen_sr_to gen_su_to gen_se_to mempty + <> gen_pr + +gen_sn_to :: Tool (APINode, SpecNewtype) +gen_sn_to = mkTool $ \ ts (an, _sn) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] + +gen_sr_to :: Tool (APINode, SpecRecord) +gen_sr_to = mkTool $ \ ts (an, _sr) -> + optionalStandaloneDerivD ts ''Data [nodeRepT an] + +gen_su_to :: Tool (APINode, SpecUnion) +gen_su_to = mkTool $ \ ts (an, _su) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] + +gen_se_to :: Tool (APINode, SpecEnum) +gen_se_to = mkTool $ \ ts (an, _se) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] + +gen_pr :: Tool APINode +gen_pr = mkTool $ \ ts an -> case anConvert an of + Nothing -> return [] + Just (_inj_fn, _prj_fn) -> optionalStandaloneDerivD ts ''Data [nodeT an] diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index 15a76f8..ed94f78 100644 --- a/src/Data/API/Tools/Datatypes.hs +++ b/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 diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index f922339..3bb22a2 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -12,17 +12,33 @@ import Data.API.Tools.Datatypes import Data.API.Types 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 +import qualified Data.List as L - --- | Tool to generate 'Arbitrary' instances for generated types. +-- | Tool to generate 'Arbitrary' instances for generated types. This tool generates +-- also a stock shrinker via the 'generic-arbitrary' package, which means we require +-- the wrapped type to be an instance of 'Generic'. quickCheckTool :: APITool quickCheckTool = apiNodeTool $ apiSpecTool gen_sn_ab gen_sr_ab gen_su_ab gen_se_ab mempty +-- | 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 shrinkBody = do + optionalInstanceD ts ''QC.Arbitrary [typeQ] + [ simpleD 'arbitrary arbitraryBody + , simpleD 'shrink shrinkBody + ] -- | Generate an 'Arbitrary' instance for a newtype that respects its -- filter. We don't try to generate arbitrary data matching a regular @@ -32,24 +48,38 @@ quickCheckTool = apiNodeTool $ apiSpecTool gen_sn_ab gen_sr_ab gen_su_ab gen_se_ -- 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 = optionalInstanceD ts ''Arbitrary [nodeRepT an] - [simpleD 'arbitrary [e| fmap $(nodeNewtypeConE ts an sn) $arb |]] - + 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 = (TH-derived shrinker) gen_sr_ab :: Tool (APINode, SpecRecord) -gen_sr_ab = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an] - [simpleD 'arbitrary (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: @@ -60,6 +90,46 @@ gen_sr_ab = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''QC.Arbitrary [nodeR 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) [ + -- mighty Universe, forgive me for this ghastly code. + match (recP nm (map pure recordPatterns)) + (normalB $ concatParts $ + flip map recordPatterns $ \(target, _) -> + let targetTxt = show target + in appE (varE 'L.singleton) $ + applicativeE (nodeConE an) $ + flip map recordPatterns $ \(fld, _) -> + let fldTxt = show fld + in if fldTxt == targetTxt + then [e| QC.shrink $(varE target) |] + else [e| pure $(varE fld) |] + ) [] + ] + where + nm = rep_type_nm an + +concatParts :: [Q Exp] -> Q Exp +concatParts parts = [| join $ join $ $(listE parts) |] -- | Generate an 'Arbitrary' instance for a union: -- @@ -67,8 +137,7 @@ gen_sr_ab = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''QC.Arbitrary [nodeR -- > arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ] gen_su_ab :: Tool (APINode, SpecUnion) -gen_su_ab = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an] - [simpleD 'arbitrary (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) |] @@ -76,6 +145,17 @@ gen_su_ab = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''QC.Arbitrary [nodeR 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: -- @@ -83,14 +163,15 @@ gen_su_ab = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''QC.Arbitrary [nodeR -- > arbitrary = elements [Bar, Baz] gen_se_ab :: Tool (APINode, SpecEnum) -gen_se_ab = mkTool $ \ ts (an, se) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an] - [simpleD 'arbitrary (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 diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs index 6bf41fb..f44e073 100644 --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -40,6 +41,7 @@ import Data.API.Time import Control.DeepSeq import qualified Data.CaseInsensitive as CI +import Data.Data import Data.String import Data.Time import Data.Aeson @@ -326,7 +328,7 @@ defaultValueAsJsValue (DefValUtc t) = String (printUTC t) -- | Binary data is represented in JSON format as a base64-encoded -- string newtype Binary = Binary { _Binary :: B.ByteString } - deriving (Show,Eq,Ord,NFData,CBOR.Serialise) + deriving (Show,Eq,Ord,NFData,CBOR.Serialise, Data) instance ToJSON Binary where toJSON = String . T.decodeLatin1 . B64.encode . _Binary From 322090045c9af07613fa78b16b5c1edf8f789665 Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Wed, 5 Nov 2025 09:30:18 +0000 Subject: [PATCH 2/6] Simpler shrinkRecord --- src/Data/API/Tools/QuickCheck.hs | 73 ++++++++++++++++++++------------ 1 file changed, 45 insertions(+), 28 deletions(-) diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index 3bb22a2..360ee7f 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -18,7 +18,6 @@ import Data.Time import Language.Haskell.TH import Prelude import Test.QuickCheck as QC -import qualified Data.List as L -- | Tool to generate 'Arbitrary' instances for generated types. This tool generates -- also a stock shrinker via the 'generic-arbitrary' package, which means we require @@ -94,42 +93,60 @@ gen_sr_ab = mkTool $ \ ts (an, sr) -> mkArbitraryInstance ts (nodeRepT an) (bdy -- 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) + -- + -- shrink = \ x -> + -- case x of + -- Foo a b c -> + -- concat [ 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) + -- List of field names in the record + let fields :: [Name] + fields = map (pref_field_nm an . fst) (srFields sr) + + -- Given a list of fields with a distinguished element, construct + -- Foo <$> pure x0 <*> ... <*> shrink xM <*> ... <*> pure xN + -- where the boolean indicates which field should use 'shrink'. + let shrinkMarkedField :: [(Bool, Name)] -> ExpQ + shrinkMarkedField flds = + applicativeE (nodeConE an) $ + flip map flds $ \(shrunk, fld) -> + if shrunk then [e| QC.shrink $(varE fld) |] + else [e| pure $(varE fld) |] + + -- Construct the list + -- [ Foo <$> shrink a <*> pure b <*> ... + -- , Foo <$> pure a <*> shrink b <*> ... + -- , ... + -- ] + let shrinkAllFields :: ExpQ + shrinkAllFields = listE (map shrinkMarkedField (distinguishedElements fields)) + x <- newName "x" lamE [varP x] $ caseE (varE x) [ - -- mighty Universe, forgive me for this ghastly code. - match (recP nm (map pure recordPatterns)) - (normalB $ concatParts $ - flip map recordPatterns $ \(target, _) -> - let targetTxt = show target - in appE (varE 'L.singleton) $ - applicativeE (nodeConE an) $ - flip map recordPatterns $ \(fld, _) -> - let fldTxt = show fld - in if fldTxt == targetTxt - then [e| QC.shrink $(varE target) |] - else [e| pure $(varE fld) |] - ) [] + -- Foo a b c -> concat [...] + match (recP nm (map (\n -> fieldPat n (varP n)) fields)) + (normalB [e| concat $shrinkAllFields |]) + [] ] where nm = rep_type_nm an -concatParts :: [Q Exp] -> Q Exp -concatParts parts = [| join $ join $ $(listE parts) |] +-- | Turn an N-element list into N lists of N pairs, each of which has a single +-- distinguished element marked True. +-- +-- >>> distinguishedElements "abc" +-- [[(True,'a'),(False,'b'),(False,'c')],[(False,'a'),(True,'b'),(False,'c')],[(False,'a'),(False,'b'),(True,'c')]] +-- +distinguishedElements :: [a] -> [[(Bool, a)]] +distinguishedElements [] = [] +distinguishedElements (x:xs) = ((True, x) : map ((,) False) xs) + : map ((False, x) :) (distinguishedElements xs) -- | Generate an 'Arbitrary' instance for a union: -- From 3696f9da6d0b21704e5d5a9597d33885d0f46341 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 5 Nov 2025 11:20:06 +0100 Subject: [PATCH 3/6] implement shrinkEnum via shrinkBoundedEnum --- src/Data/API/Tools/QuickCheck.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index 360ee7f..cd8e42f 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -180,15 +180,15 @@ gen_su_ab = mkTool $ \ ts (an, su) -> mkArbitraryInstance ts (nodeRepT an) (bdy -- > arbitrary = elements [Bar, Baz] gen_se_ab :: Tool (APINode, SpecEnum) -gen_se_ab = mkTool $ \ ts (an, se) -> mkArbitraryInstance ts (nodeRepT an) (bdy an se) noShrink +gen_se_ab = mkTool $ \ ts (an, se) -> mkArbitraryInstance ts (nodeRepT an) (bdy an se) shrinkEnum 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| \_ -> [] |] + shrinkEnum :: ExpQ + shrinkEnum = [e| QC.shrinkBoundedEnum |] -- | Generate an arbitrary 'Int' in a given range. arbitraryIntRange :: IntRange -> Gen Int From 3638d0af1f69e78548aba413b8b4eed19089660c Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 5 Nov 2025 14:53:50 +0100 Subject: [PATCH 4/6] Move defaultDerivedClasses as a ToolSetting --- api-tools.cabal | 1 - src/Data/API/Tools.hs | 5 ++--- src/Data/API/Tools/Combinators.hs | 29 +++++++++++++++++++++++++ src/Data/API/Tools/DataTypeable.hs | 35 ------------------------------ src/Data/API/Tools/Datatypes.hs | 28 ++---------------------- tests/Data/API/Test/Gen.hs | 2 +- 6 files changed, 34 insertions(+), 66 deletions(-) delete mode 100644 src/Data/API/Tools/DataTypeable.hs diff --git a/api-tools.cabal b/api-tools.cabal index b425489..5a89593 100644 --- a/api-tools.cabal +++ b/api-tools.cabal @@ -53,7 +53,6 @@ Library Data.API.Tools.CBOR Data.API.Tools.Combinators Data.API.Tools.Datatypes - Data.API.Tools.DataTypeable Data.API.Tools.DeepSeq Data.API.Tools.Enum Data.API.Tools.Example diff --git a/src/Data/API/Tools.hs b/src/Data/API/Tools.hs index 225ef78..2b6153e 100644 --- a/src/Data/API/Tools.hs +++ b/src/Data/API/Tools.hs @@ -20,11 +20,11 @@ module Data.API.Tools , defaultToolSettings , warnOnOmittedInstance , newtypeSmartConstructors + , defaultDerivedClasses -- * Individual tools , enumTool , exampleTool - , dataTypeableTool , deepSeqTool , jsonTool , jsonTool' @@ -42,7 +42,6 @@ module Data.API.Tools ) where import Data.API.Tools.Combinators -import Data.API.Tools.DataTypeable import Data.API.Tools.Datatypes import Data.API.Tools.DeepSeq import Data.API.Tools.Enum @@ -65,7 +64,7 @@ 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 diff --git a/src/Data/API/Tools/Combinators.hs b/src/Data/API/Tools/Combinators.hs index 4ad269b..9c9bb77 100644 --- a/src/Data/API/Tools/Combinators.hs +++ b/src/Data/API/Tools/Combinators.hs @@ -22,6 +22,7 @@ module Data.API.Tools.Combinators , warnOnOmittedInstance , newtypeSmartConstructors , defaultToolSettings + , defaultDerivedClasses ) where import Data.API.Types @@ -29,6 +30,8 @@ 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,6 +46,8 @@ 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 by api-tools. } -- | Default settings designed to be overridden. @@ -50,8 +55,32 @@ 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. diff --git a/src/Data/API/Tools/DataTypeable.hs b/src/Data/API/Tools/DataTypeable.hs deleted file mode 100644 index b1552f5..0000000 --- a/src/Data/API/Tools/DataTypeable.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.API.Tools.DataTypeable ( - dataTypeableTool - ) where - -import Prelude - -import Data.API.TH -import Data.API.Tools.Combinators -import Data.API.Tools.Datatypes -import Data.API.Types -import Data.Data - -dataTypeableTool :: APITool -dataTypeableTool = apiNodeTool $ - apiSpecTool gen_sn_to gen_sr_to gen_su_to gen_se_to mempty - <> gen_pr - -gen_sn_to :: Tool (APINode, SpecNewtype) -gen_sn_to = mkTool $ \ ts (an, _sn) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] - -gen_sr_to :: Tool (APINode, SpecRecord) -gen_sr_to = mkTool $ \ ts (an, _sr) -> - optionalStandaloneDerivD ts ''Data [nodeRepT an] - -gen_su_to :: Tool (APINode, SpecUnion) -gen_su_to = mkTool $ \ ts (an, _su) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] - -gen_se_to :: Tool (APINode, SpecEnum) -gen_se_to = mkTool $ \ ts (an, _se) -> optionalStandaloneDerivD ts ''Data [nodeRepT an] - -gen_pr :: Tool APINode -gen_pr = mkTool $ \ ts an -> case anConvert an of - Nothing -> return [] - Just (_inj_fn, _prj_fn) -> optionalStandaloneDerivD ts ''Data [nodeT an] diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index ed94f78..e1873cb 100644 --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -2,7 +2,6 @@ module Data.API.Tools.Datatypes ( datatypesTool , datatypesTool' - , defaultDerivedClasses , type_nm , rep_type_nm , nodeT @@ -32,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. @@ -165,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 diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs index c60b1b2..8cefbb6 100644 --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -48,7 +48,7 @@ $(generateAPITools DSL.example ]) $(generateAPIToolsWith (defaultToolSettings { newtypeSmartConstructors = True }) example2 - [ datatypesTool' ((''Generic :) . defaultDerivedClasses) ]) + [ datatypesTool' ((''Generic :) . defaultDerivedClasses defaultToolSettings) ]) data Coord = Coord Int Int deriving (Eq,Show) From a25cec92bc9af5af2add8738b037fe5954626d02 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Thu, 6 Nov 2025 08:34:37 +0100 Subject: [PATCH 5/6] Introduce shrinkUTCRange and shrinkIntRange --- src/Data/API/API/Gen.hs | 7 --- src/Data/API/Tools/Combinators.hs | 2 +- src/Data/API/Tools/QuickCheck.hs | 79 +++++++++++++++++++++++++------ src/Data/API/Types.hs | 1 + 4 files changed, 67 insertions(+), 22 deletions(-) diff --git a/src/Data/API/API/Gen.hs b/src/Data/API/API/Gen.hs index 5505437..4a668ee 100644 --- a/src/Data/API/API/Gen.hs +++ b/src/Data/API/API/Gen.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# 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 diff --git a/src/Data/API/Tools/Combinators.hs b/src/Data/API/Tools/Combinators.hs index 9c9bb77..df6d4b7 100644 --- a/src/Data/API/Tools/Combinators.hs +++ b/src/Data/API/Tools/Combinators.hs @@ -47,7 +47,7 @@ data ToolSettings = ToolSettings -- ^ Rename the constructors of filtered newtypes and generate -- smart constructors that enforce the invariants , defaultDerivedClasses :: APINode -> [Name] - -- ^ The classes which are derived automatically by api-tools. + -- ^ The classes which are derived automatically for datatypes created by 'datatypesTool'. } -- | Default settings designed to be overridden. diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index cd8e42f..f8a61b3 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -50,26 +50,77 @@ gen_sn_ab = mkTool $ \ ts (an, sn) -> case snFilter sn of 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) + mk_instance ts an sn [e| arbitraryIntRange ir |] (shrinkIntRange ir ts an sn) Just (FtrUTC ur) -> - mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkNewtype ts an sn) + mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkUTCRange ur 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)) |]) - [] - ] +-- shrinking a newtype means calling shrink and repack the newtype. +-- Example: +-- shrink = \x -> case x of { Foo y -> map Foo (shrink y) } +shrinkNewtype :: ToolSettings -> APINode -> SpecNewtype -> Q Exp +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)) |]) + [] + ] + +-- | Attempts to shrink an input 'APINode' within the given 'IntRange', i.e. if the 'IntRange' +-- specifies an 'ir_lo', then we shrink such that the resulting shrunk values still satisfies +-- the min constrain of the range (i.e. we never generate values /smaller/ than 'ir_lo'). +-- +-- A few observations/remarks: +-- +-- * If the 'ir_lo' is 'Nothing', then this because just 'shrinkNewtype', because we don't +-- really care about 'ir_hi' as shrinking by default won't generate value higher than the +-- value being shrunk (it would be a nonsense); +-- +-- * We can generate code that typechecks only if we have a 'BTint', otherwise we don't shrink. +shrinkIntRange :: IntRange -> ToolSettings -> APINode -> SpecNewtype -> ExpQ +shrinkIntRange ir ts an sn = case ir_lo ir of + Nothing -> shrinkNewtype ts an sn + Just lowerBound -> do + x <- newName "x" + y <- newName "y" + lamE [varP x] $ + caseE (varE x) [ + match (nodeNewtypeConP ts an sn [varP y]) + (normalB $ do + if snType sn == BTint + then [| map $(nodeNewtypeConE ts an sn) $ filter (>= lowerBound) $ (QC.shrink $(varE y)) |] + else noShrink + ) [] + ] + +noShrink :: ExpQ +noShrink = [e| \_ -> [] |] + +-- | Attempts to shrink an input 'APINode' within the given 'UTCRange', i.e. if the 'UTCRange' +-- specifies an 'ur_lo', then we shrink such that the resulting shrunk values still satisfies +-- the min constrain of the range (i.e. we never generate values /smaller/ than 'ur_lo'). +-- Same proviso as for 'shrinkIntRange', it makes sense to apply the filter only for 'BTutc'. +shrinkUTCRange :: UTCRange -> ToolSettings -> APINode -> SpecNewtype -> ExpQ +shrinkUTCRange ur ts an sn = case ur_lo ur of + Nothing -> shrinkNewtype ts an sn + Just lowerBound -> do + x <- newName "x" + y <- newName "y" + lamE [varP x] $ + caseE (varE x) [ + match (nodeNewtypeConP ts an sn [varP y]) + (normalB $ do + if snType sn == BTutc + then [| map $(nodeNewtypeConE ts an sn) $ filter (>= $(liftUTC lowerBound)) $ (QC.shrink $(varE y)) |] + else noShrink + ) [] + ] -- | Generate an 'Arbitrary' instance for a record: -- diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs index f44e073..5da40a3 100644 --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -35,6 +35,7 @@ module Data.API.Types , inIntRange , inUTCRange , base64ToBinary + , liftUTC ) where import Data.API.Time From 3cf8f1748a883f2a634c67d7a3794d0d01a6e364 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Thu, 6 Nov 2025 14:13:54 +0100 Subject: [PATCH 6/6] Simplify shrinkWithinIntRange and shrinkWithinUTCRange --- src/Data/API/Tools/QuickCheck.hs | 82 ++++++++++++++------------------ 1 file changed, 36 insertions(+), 46 deletions(-) diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index f8a61b3..2c237cb 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Data.API.Tools.QuickCheck @@ -15,13 +16,13 @@ import Control.Applicative import Control.Monad import Data.Monoid import Data.Time +import Data.Coerce import Language.Haskell.TH import Prelude import Test.QuickCheck as QC +import Language.Haskell.TH.Syntax (lift) --- | Tool to generate 'Arbitrary' instances for generated types. This tool generates --- also a stock shrinker via the 'generic-arbitrary' package, which means we require --- the wrapped type to be an instance of 'Generic'. +-- | Tool to generate 'Arbitrary' instances for generated types. quickCheckTool :: APITool quickCheckTool = apiNodeTool $ apiSpecTool gen_sn_ab gen_sr_ab gen_su_ab gen_se_ab mempty @@ -50,9 +51,9 @@ gen_sn_ab = mkTool $ \ ts (an, sn) -> case snFilter sn of 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 |] (shrinkIntRange ir ts an sn) + mk_instance ts an sn [e| arbitraryIntRange ir |] (shrinkIntRange ir sn) Just (FtrUTC ur) -> - mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkUTCRange ur ts an sn) + mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkUTCRange ur sn) Just (FtrStrg _) -> return [] where mk_instance ts an sn arb = @@ -72,32 +73,29 @@ shrinkNewtype ts an sn = do [] ] --- | Attempts to shrink an input 'APINode' within the given 'IntRange', i.e. if the 'IntRange' --- specifies an 'ir_lo', then we shrink such that the resulting shrunk values still satisfies --- the min constrain of the range (i.e. we never generate values /smaller/ than 'ir_lo'). --- --- A few observations/remarks: --- --- * If the 'ir_lo' is 'Nothing', then this because just 'shrinkNewtype', because we don't --- really care about 'ir_hi' as shrinking by default won't generate value higher than the --- value being shrunk (it would be a nonsense); --- --- * We can generate code that typechecks only if we have a 'BTint', otherwise we don't shrink. -shrinkIntRange :: IntRange -> ToolSettings -> APINode -> SpecNewtype -> ExpQ -shrinkIntRange ir ts an sn = case ir_lo ir of - Nothing -> shrinkNewtype ts an sn - Just lowerBound -> do - x <- newName "x" - y <- newName "y" - lamE [varP x] $ - caseE (varE x) [ - match (nodeNewtypeConP ts an sn [varP y]) - (normalB $ do - if snType sn == BTint - then [| map $(nodeNewtypeConE ts an sn) $ filter (>= lowerBound) $ (QC.shrink $(varE y)) |] - else noShrink - ) [] - ] +shrinkWithinIntRange :: IntRange -> Int -> [Int] +shrinkWithinIntRange ir@IntRange{..} x = refine $ QC.shrink x + where + refine = case (ir_lo, ir_hi) of + (Nothing, Nothing) -> id -- avoid filter altogether + _ -> filter (`inIntRange` ir) + +shrinkWithinUTCRange :: UTCRange -> UTCTime -> [UTCTime] +shrinkWithinUTCRange ur@UTCRange{..} x = refine $ QC.shrink x + where + refine = case (ur_lo, ur_hi) of + (Nothing, Nothing) -> id -- avoid filter altogether + _ -> filter (`inUTCRange` ur) + +-- | Attempts to shrink an input 'APINode' within the given 'IntRange'. +-- We can generate code that typechecks only if we have a 'BTint', otherwise we don't shrink. +shrinkIntRange :: IntRange -> SpecNewtype -> ExpQ +shrinkIntRange ir sn = do + x <- newName "x" + lamE [varP x] $ + if snType sn == BTint + then [e| coerce (shrinkWithinIntRange $(lift ir) $ coerce $(varE x)) |] + else noShrink noShrink :: ExpQ noShrink = [e| \_ -> [] |] @@ -106,21 +104,13 @@ noShrink = [e| \_ -> [] |] -- specifies an 'ur_lo', then we shrink such that the resulting shrunk values still satisfies -- the min constrain of the range (i.e. we never generate values /smaller/ than 'ur_lo'). -- Same proviso as for 'shrinkIntRange', it makes sense to apply the filter only for 'BTutc'. -shrinkUTCRange :: UTCRange -> ToolSettings -> APINode -> SpecNewtype -> ExpQ -shrinkUTCRange ur ts an sn = case ur_lo ur of - Nothing -> shrinkNewtype ts an sn - Just lowerBound -> do - x <- newName "x" - y <- newName "y" - lamE [varP x] $ - caseE (varE x) [ - match (nodeNewtypeConP ts an sn [varP y]) - (normalB $ do - if snType sn == BTutc - then [| map $(nodeNewtypeConE ts an sn) $ filter (>= $(liftUTC lowerBound)) $ (QC.shrink $(varE y)) |] - else noShrink - ) [] - ] +shrinkUTCRange :: UTCRange -> SpecNewtype -> ExpQ +shrinkUTCRange ur sn = do + x <- newName "x" + lamE [varP x] $ + if snType sn == BTutc + then [e| coerce (shrinkWithinUTCRange $(lift ur) $ coerce $(varE x)) |] + else noShrink -- | Generate an 'Arbitrary' instance for a record: --