diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index b07386d..5252faf 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,15 +8,16 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20251019 +# version: 0.19.20260331 # -# REGENDATA ("0.19.20251019",["github","api-tools.cabal","--no-error-unused-packages","--no-error-incomplete-patterns"]) +# REGENDATA ("0.19.20260331",["github","api-tools.cabal","--no-error-unused-packages","--no-error-incomplete-patterns"]) # name: Haskell-CI on: - push - pull_request - merge_group + - workflow_dispatch jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} @@ -29,6 +30,16 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.14.1 + compilerKind: ghc + compilerVersion: 9.14.1 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.12.4 + compilerKind: ghc + compilerVersion: 9.12.4 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.10.3 compilerKind: ghc compilerVersion: 9.10.3 @@ -160,6 +171,7 @@ jobs: echo "packages: ${PKGDIR_api_tools}" >> cabal.project echo "package api-tools" >> cabal.project echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project + echo "allow-newer: cborg:base, cborg:containers, serialise:base, serialise:containers, serialise:time" >> cabal.project cat >> cabal.project <> cabal.project.local diff --git a/LICENSE b/LICENSE index 0c00012..90021b7 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2022, Iris Connect +Copyright (c) 2013-2026, Iris Connect All rights reserved. diff --git a/api-tools.cabal b/api-tools.cabal index 046e2bd..5748da7 100644 --- a/api-tools.cabal +++ b/api-tools.cabal @@ -1,5 +1,5 @@ Name: api-tools -Version: 0.10.1.1 +Version: 0.11.0.0 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the @@ -12,12 +12,12 @@ License: BSD3 License-file: LICENSE Author: Chris Dornan and Adam Gundry Maintainer: Adam Gundry -Copyright: (c) Iris Connect 2013-2025 +Copyright: (c) Iris Connect 2013-2026 Category: Network, Web, Cloud, Distributed Computing Build-type: Simple Extra-source-files: changelog Cabal-version: >=1.10 -Tested-with: GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3 +Tested-with: GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.4, GHC == 9.14.1 Source-Repository head Type: git @@ -78,7 +78,7 @@ Library Text.Regex Build-depends: - QuickCheck >= 2.5.1 && < 2.16 , + QuickCheck >= 2.5.1 && < 2.19 , aeson-pretty >= 0.1 && < 0.9 , array >= 0.4 && < 0.6 , attoparsec >= 0.10.4 && < 0.15 , @@ -88,8 +88,8 @@ Library bytestring >= 0.9 && < 0.13 , case-insensitive >= 1.0 && < 1.3 , cborg >= 0.1.1.0 && < 0.3 , - containers >= 0.5 && < 0.8 , - deepseq >= 1.1 && < 1.6 , + containers >= 0.5 && < 0.9 , + deepseq >= 1.1 && < 1.7 , lens >= 3.8.7 && < 5.4 , regex-base >= 0.93 && < 0.95 , regex-tdfa >= 1.1.0 && < 1.4 , @@ -97,15 +97,15 @@ Library safecopy >= 0.8.1 && < 0.11 , scientific >= 0.3 && < 0.4 , serialise >= 0.1.0.0 && < 0.3 , - template-haskell >= 2.7 && < 2.23 , + template-haskell >= 2.7 && < 2.25 , text >= 0.11.3 && < 2.2 , - time >= 1.5.0 && < 1.14 , + time >= 1.5.0 && < 1.17 , unordered-containers >= 0.2.3.0 && < 0.3 , vector >= 0.10.0.1 && < 0.14 if flag(use-attoparsec-aeson) Build-Depends: - aeson >= 2.2 && < 2.3 , + aeson >= 2.2 && < 2.4 , attoparsec-aeson >= 2.1 && < 2.3 else Build-Depends: diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..5c2d0ef --- /dev/null +++ b/cabal.project @@ -0,0 +1,8 @@ +packages: . + +allow-newer: + cborg:base, + cborg:containers, + serialise:base, + serialise:containers, + serialise:time diff --git a/changelog b/changelog index 6df80da..5b39b3e 100644 --- a/changelog +++ b/changelog @@ -1,6 +1,6 @@ -*-change-log-*- -Unreleased +0.11.0.0 Adam Gundry August 2026 * Add support for sets in schemas with @Set T@ syntax. Sets use 'Data.Set.Set' in generated Haskell types, but are represented as arrays on the JSON and CBOR wire formats. Set element types must @@ -9,6 +9,13 @@ Unreleased (or 'defaultDerivedClasses') to add it. * Breaking: @Set@ is now a reserved word in the schema DSL. A type previously called @Set@ must be written @'Set'@ (in quotes). + * Avoid deriving `Typeable` as this is unnecessary on recent GHC versions. + * Do not generate pointless identity traversal functions in `traversalTool`. + * Adjust definition of `ChangelogEntryInvalid` to avoid accumulating redundant data. + * Remove `instance PPLines APITableChange`. + * Add `Data.API.Types.defaultValueForType`. + * Add `Data.API.Changes.Types.compactAPITableChanges`. + * Relax dependency bounds and support building on GHC 9.6 through to 9.14. 0.10.1.1 Adam Gundry August 2024 * Relax dependency bounds and support building on GHC 9.4 through to 9.10 diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index 46f008a..fa5d3da 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -386,7 +386,7 @@ doChangeAPI :: TypeName -> CustomMigrationsTagged o v -> DataChecks -> Either ValidateFailure (NormAPI, [APITableChange]) doChangeAPI root custom chks (api, changes) change = do (api', pos) <- applyAPIChangeToAPI root custom change api - ?!? ChangelogEntryInvalid changes change + ?!? ChangelogEntryInvalid (compactAPITableChanges changes) change let changes' = APIChange api change pos : changes changes'' | validateAfter chks change = ValidateData api' : changes' | otherwise = changes' @@ -833,16 +833,6 @@ withString _ v p = Left (JSONError $ expectedString v, p) compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool compatibleDefaultValue api ty dv = isJust (fromDefaultValue api ty dv) --- | Check if there is a "default" default value for a field of the --- given type: list and maybe have @[]@ and @nothing@ respectively. --- Note that type synonyms do not preserve defaults, since we do not --- have access to the entire API. -defaultValueForType :: APIType -> Maybe DefaultValue -defaultValueForType (TyList _) = Just DefValList -defaultValueForType (TySet _) = Just DefValList -defaultValueForType (TyMaybe _) = Just DefValMaybe -defaultValueForType _ = Nothing - ------------------------------------------- -- Validation that a dataset matches an API diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs index 0844ce9..af5a82b 100644 --- a/src/Data/API/Changes/Types.hs +++ b/src/Data/API/Changes/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -15,6 +16,8 @@ module Data.API.Changes.Types , UpdateTypePos(..) , UpdateDeclPos(..) , APITableChange(..) + + , compactAPITableChanges ) where import Data.API.PP @@ -22,6 +25,7 @@ import Data.API.NormalForm import Data.API.Types import Data.Map ( Map ) +import Data.Maybe import Data.Version @@ -145,6 +149,9 @@ data APITableChange | ValidateData NormAPI deriving (Eq, Show) -instance PPLines APITableChange where - ppLines (APIChange _ c _) = ppLines c - ppLines (ValidateData _) = [] +-- | Discard the additional metadata from a list of 'APITableChange's to get +-- only the underlying 'APIChange's. +compactAPITableChanges :: [APITableChange] -> [APIChange] +compactAPITableChanges = mapMaybe $ \case + APIChange _ c _ -> Just c + ValidateData _ -> Nothing diff --git a/src/Data/API/Error.hs b/src/Data/API/Error.hs index 358ca2a..c4d3da7 100644 --- a/src/Data/API/Error.hs +++ b/src/Data/API/Error.hs @@ -180,7 +180,7 @@ data ValidateFailure | ApiInvalid { vfInvalidVersion :: VersionExtra , vfMissingDeclarations :: Set TypeName } -- | changelog entry does not apply - | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange] + | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APIChange] , vfFailedToApply :: APIChange , vfApplyFailure :: ApplyFailure } -- | changelog is incomplete diff --git a/src/Data/API/Tools/Combinators.hs b/src/Data/API/Tools/Combinators.hs index df6d4b7..f803229 100644 --- a/src/Data/API/Tools/Combinators.hs +++ b/src/Data/API/Tools/Combinators.hs @@ -31,7 +31,6 @@ import Control.Applicative import Data.Monoid import Data.Semigroup as Sem import Data.String -import Data.Typeable import Language.Haskell.TH import Prelude @@ -74,10 +73,10 @@ default_derived_classes an = case anSpec an of SpSynonym _ -> [] derive_leaf_nms :: [Name] -derive_leaf_nms = [''Show,''Eq,''Ord,''Typeable] +derive_leaf_nms = [''Show,''Eq,''Ord] derive_node_nms :: [Name] -derive_node_nms = [''Show,''Eq,''Typeable] +derive_node_nms = [''Show,''Eq] diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index 96404f2..14f4fe6 100644 --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -59,13 +59,13 @@ gen_sy (as, ty) = return [TySynD (type_nm as) [] $ mk_type ty] -- | Generate a newtype definition, like this: -- -- > newtype JobId = JobId { _JobId :: T.Text } --- > deriving (Show,IsString,Eq,Typeable) +-- > deriving (Show,IsString,Eq) -- -- If a filter has been applied, and smart constructors are enabled, -- instead generate this: -- -- > newtype EmailAddress = UnsafeMkEmailAddress { _EmailAddress :: T.Text } --- > deriving (Show,Eq,Typeable) +-- > deriving (Show,Eq) -- > mkEmailAddress :: T.Text -> Maybe EmailAddress -- > mkEmailAddress t = ... -- check filter @@ -101,7 +101,7 @@ gen_sn_dt deriv ts (as, sn) = (nd :) <$> if smart then sc else return [] -- > , _jsi_output :: JSOutputStatus -- > , _jsi_pipelineId :: PipelineId -- > } --- > deriving (Show,Eq,Typeable) +-- > deriving (Show,Eq) gen_sr_dt :: (APINode -> [Name]) -> (APINode, SpecRecord) -> Q [Dec] gen_sr_dt deriv (as, sr) = return [mkDataD [] nm [] cs (deriv as)] @@ -114,7 +114,7 @@ gen_sr_dt deriv (as, sr) = return [mkDataD [] nm [] cs (deriv as)] -- | Generate a union type definition, like this: -- -- > data Foo = F_Bar Int | F_Baz Bool --- > deriving (Show,Typeable) +-- > deriving (Show) gen_su_dt :: (APINode -> [Name]) -> (APINode, SpecUnion) -> Q [Dec] gen_su_dt deriv (as, su) = return [mkDataD [] nm [] cs (deriv as)] @@ -136,7 +136,7 @@ gen_su_dt deriv (as, su) = return [mkDataD [] nm [] cs (deriv as)] -- > | FR_29_97 -- > | FR_30 -- > | FR_60 --- > deriving (Show,Eq,Ord,Bounded,Enum,Typeable) +-- > deriving (Show,Eq,Ord,Bounded,Enum) gen_se_dt :: (APINode -> [Name]) -> (APINode, SpecEnum) -> Q [Dec] gen_se_dt deriv (as, se) = return [mkDataD [] nm [] cs (deriv as)] diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs index fba7781..e3e54c4 100644 --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -65,9 +65,11 @@ traversalsTool root x = readTool (apiNodeTool . s) -- | @traversalName x tn@ is the name of the function that traverses --- @x@ values inside @tn@ -traversalName :: TypeName -> TypeName -> Name -traversalName x tn = mkNameText $ "traverse" <> _TypeName x <> _TypeName tn +-- @x@ values inside @tn@, or 'Nothing' if the types are identical. +traversalName :: TypeName -> TypeName -> Maybe Name +traversalName x tn + | x == tn = Nothing + | otherwise = Just $ mkNameText $ "traverse" <> _TypeName x <> _TypeName tn -- | @traversalType x an@ is the type of the function that traverses -- @x@ values inside @an@ @@ -104,8 +106,8 @@ traverser' napi targets x (TyName tn) | otherwise = case Map.lookup tn napi of Nothing -> error $ "missing API type declaration: " ++ T.unpack (_TypeName tn) Just (NTypeSynonym ty) -> traverser' napi targets x ty - Just (NRecordType _) -> Just $ varE $ traversalName x tn - Just (NUnionType _) -> Just $ varE $ traversalName x tn + Just (NRecordType _) -> Just $ varE $ fromMaybe 'id $ traversalName x tn + Just (NUnionType _) -> Just $ varE $ fromMaybe 'id $ traversalName x tn Just (NEnumType _) -> Nothing Just (NNewtype _) -> Nothing traverser' _ _ _ (TyBasic _) = Nothing @@ -122,9 +124,10 @@ traversalRecord :: NormAPI -> Set.Set TypeName -> TypeName -> APINode -> SpecRec traversalRecord napi targets x an sr | not (anName an `Set.member` targets) = return [] | anConvert an /= Nothing = return [] - | otherwise = simpleSigD nom (traversalType x an) bdy + | Just nom <- traversalName x (anName an) = simpleSigD nom (traversalType x an) bdy + | otherwise = return [] where - nom = traversalName x (anName an) + bdy = do f <- newName "f" r <- newName "r" @@ -145,9 +148,10 @@ traversalUnion :: NormAPI -> Set.Set TypeName -> TypeName -> APINode -> SpecUnio traversalUnion napi targets x an su | not (anName an `Set.member` targets) = return [] | anConvert an /= Nothing = return [] - | otherwise = funSigD nom (traversalType x an) cls + | Just nom <- traversalName x (anName an) = funSigD nom (traversalType x an) cls + | otherwise = return [] where - nom = traversalName x (anName an) + cls = map cl $ suFields su cl (fn,(ty,_)) = do f <- newName "f" diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs index 0ca1549..2a38823 100644 --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -30,6 +30,7 @@ module Data.API.Types , UTCRange(..) , RegEx(..) , Binary(..) + , defaultValueForType , defaultValueAsJsValue , mkRegEx , inIntRange @@ -319,6 +320,16 @@ instance NFData DefaultValue where rnf (DefValInt i) = rnf i rnf (DefValUtc u) = rnf u +-- | Check if there is a "default" default value for a field of the +-- given type: list and maybe have @[]@ and @nothing@ respectively. +-- Note that type synonyms do not preserve defaults, since we do not +-- have access to the entire API. +defaultValueForType :: APIType -> Maybe DefaultValue +defaultValueForType (TyList _) = Just DefValList +defaultValueForType (TySet _) = Just DefValList +defaultValueForType (TyMaybe _) = Just DefValMaybe +defaultValueForType _ = Nothing + -- | Convert a default value to an Aeson 'Value'. This differs from -- 'toJSON' as it will not round-trip with 'fromJSON': UTC default -- values are turned into strings.