Support GHC 9.14.1

.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 <<EOF
           EOF
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(api-tools)$/; }' >> cabal.project.local

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2013-2022, Iris Connect
+Copyright (c) 2013-2026, Iris Connect
 
 All rights reserved.
 

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 <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com>
 Maintainer:          Adam Gundry <adam@well-typed.com>
-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,24 +88,24 @@ 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  ,
         safe                 >= 0.3.3    && < 0.4  ,
         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:

cabal.project

@@ -0,0 +1,8 @@
+packages: .
+
+allow-newer:
+    cborg:base,
+    cborg:containers,
+    serialise:base,
+    serialise:containers,
+    serialise:time

changelog

@@ -1,6 +1,6 @@
 -*-change-log-*-
 
-Unreleased
+0.11.0.0 Adam Gundry <adam@well-typed.com> 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 <adam@well-typed.com> August 2024
 	* Relax dependency bounds and support building on GHC 9.4 through to 9.10

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

src/Data/API/Changes/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DefaultSignatures          #-}
 {-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
@@ -15,13 +16,16 @@ module Data.API.Changes.Types
     , UpdateTypePos(..)
     , UpdateDeclPos(..)
     , APITableChange(..)
+
+    , compactAPITableChanges
     ) where
 
 import           Data.API.PP
 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

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

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]
 
 
 

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)]

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"

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.