diff --git a/api-tools.cabal b/api-tools.cabal index f59d7f1..5a89593 100644 --- a/api-tools.cabal +++ b/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 diff --git a/src/Data/API/API/Gen.hs b/src/Data/API/API/Gen.hs index 33daa0f..4a668ee 100644 --- a/src/Data/API/API/Gen.hs +++ b/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 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..2b6153e 100644 --- a/src/Data/API/Tools.hs +++ b/src/Data/API/Tools.hs @@ -20,6 +20,7 @@ module Data.API.Tools , defaultToolSettings , warnOnOmittedInstance , newtypeSmartConstructors + , defaultDerivedClasses -- * Individual tools , enumTool @@ -56,7 +57,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 @@ -64,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..df6d4b7 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 for datatypes created by 'datatypesTool'. } -- | 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/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index 15a76f8..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 @@ -10,11 +9,13 @@ module Data.API.Tools.Datatypes , 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 diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index f922339..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 @@ -12,17 +13,32 @@ import Data.API.Tools.Datatypes import Data.API.Types import Control.Applicative +import Control.Monad import Data.Monoid import Data.Time +import Data.Coerce import Language.Haskell.TH -import Test.QuickCheck as QC import Prelude - +import Test.QuickCheck as QC +import Language.Haskell.TH.Syntax (lift) -- | 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 +-- | 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,78 @@ 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 |] (shrinkIntRange ir sn) + Just (FtrUTC ur) -> + mk_instance ts an sn [e| arbitraryUTCRange ur |] (shrinkUTCRange ur 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 :: 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)) |]) + [] + ] + +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| \_ -> [] |] + +-- | 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 -> 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: -- -- > 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 +130,64 @@ 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 = \ 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 + -- 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) [ + -- 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 + +-- | 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: -- @@ -67,8 +195,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 +203,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 +221,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) shrinkEnum where bdy an se | null ks = nodeConE an | otherwise = varE 'elements `appE` listE ks where ks = map (nodeAltConE an . fst) $ seAlts se + shrinkEnum :: ExpQ + shrinkEnum = [e| QC.shrinkBoundedEnum |] -- | 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..5da40a3 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 #-} @@ -34,12 +35,14 @@ module Data.API.Types , inIntRange , inUTCRange , base64ToBinary + , liftUTC ) where 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 +329,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 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)