api-tools 0.10.1.1 → 0.11.0.0

raw patch · 38 files changed

+859/−178 lines, 38 filesdep ~QuickCheckdep ~aesondep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, aeson, containers, deepseq, tasty, tasty-hunit, tasty-quickcheck, template-haskell, time

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• api-tools.cabal +20/−23
• changelog +17/−0
• main/MigrationTool.hs +2/−1
• src/Data/API/API.hs +2/−0
• src/Data/API/API/DSL.hs +1/−0
• src/Data/API/API/Gen.hs +1/−3
• src/Data/API/Changes.hs +76/−47
• src/Data/API/Changes/Types.hs +15/−3
• src/Data/API/Doc/Types.hs +1/−0
• src/Data/API/Error.hs +1/−1
• src/Data/API/JSON.hs +12/−0
• src/Data/API/JSONToCBOR.hs +5/−0
• src/Data/API/Markdown.hs +1/−0
• src/Data/API/NormalForm.hs +2/−0
• src/Data/API/PP.hs +1/−0
• src/Data/API/Parse.y +9/−4
• src/Data/API/Scan.x +3/−1
• src/Data/API/TH.hs +14/−2
• src/Data/API/Tools.hs +2/−2
• src/Data/API/Tools/Combinators.hs +28/−0
• src/Data/API/Tools/Datatypes.hs +14/−31
• src/Data/API/Tools/DeepSeq.hs +3/−1
• src/Data/API/Tools/Example.hs +7/−1
• src/Data/API/Tools/JSON.hs +7/−2
• src/Data/API/Tools/QuickCheck.hs +164/−20
• src/Data/API/Tools/Traversal.hs +32/−10
• src/Data/API/Tutorial.hs +21/−8
• src/Data/API/Types.hs +21/−2
• src/Data/API/Value.hs +53/−9
• tests/Data/API/Test/DSL.hs +13/−0
• tests/Data/API/Test/Gen.hs +5/−1
• tests/Data/API/Test/JSON.hs +37/−0
• tests/Data/API/Test/Main.hs +2/−0
• tests/Data/API/Test/Migration.hs +5/−3
• tests/Data/API/Test/MigrationData.hs +6/−2
• tests/Data/API/Test/UnionMigration.hs +169/−0
• tests/Data/API/Test/UnionMigrationData.hs +86/−0

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

@@ -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,21 +12,16 @@ 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-2024+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.4.8, GHC == 9.6.6, GHC == 9.8.2, GHC == 9.10.1+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-  Location:          git://github.com/iconnect/api-tools.git--Source-Repository this-  Type:              git-  Location:          git://github.com/iconnect/api-tools.git-  Tag:               0.10.1.0+  Location:          https://github.com/iconnect/api-tools.git  flag use-attoparsec-aeson   description: Depend on Data.Aeson.Parser from attoparsec-aeson@@ -83,7 +78,7 @@         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 ,@@ -93,8 +88,8 @@         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  ,@@ -102,15 +97,15 @@         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:@@ -124,7 +119,7 @@         -Wall         -fwarn-tabs -  Default-Language: Haskell2010+  Default-Language: GHC2021   Executable migration-tool@@ -143,7 +138,7 @@         -Wall         -fwarn-tabs -  Default-Language: Haskell2010+  Default-Language: GHC2021   Executable perf-test@@ -164,7 +159,7 @@         -fwarn-tabs         -rtsopts -  Default-Language: Haskell2010+  Default-Language: GHC2021   Test-Suite test-api-tools@@ -181,6 +176,8 @@         Data.API.Test.Migration         Data.API.Test.MigrationData         Data.API.Test.Time+        Data.API.Test.UnionMigration+        Data.API.Test.UnionMigrationData    Build-depends:         api-tools,@@ -194,9 +191,9 @@         containers,         safecopy,         serialise,-        tasty                >= 0.10.1   && < 1.5 ,-        tasty-hunit          >= 0.2      && < 10.0,-        tasty-quickcheck     >= 0.3      && < 0.11,+        tasty                >= 0.10.1   && < 1.6 ,+        tasty-hunit          >= 0.2      && < 0.11,+        tasty-quickcheck     >= 0.3      && < 0.12,         time,         template-haskell,         text,@@ -205,7 +202,7 @@   GHC-Options:         -Wall -  Default-Language: Haskell2010+  Default-Language: GHC2021  Benchmark bench-time   Hs-Source-Dirs:   bench@@ -224,4 +221,4 @@   GHC-Options:         -Wall -  Default-Language: Haskell2010+  Default-Language: GHC2021

@@ -1,5 +1,22 @@ -*-change-log-*- +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+	  have an 'Ord' instance; note that records and unions do not derive+	  'Ord' by default, so a set of such a type needs 'datatypesTool''+	  (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 

@@ -71,9 +71,10 @@ data ChangeTag = None     deriving (Read, Show) -customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag+customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag ChangeTag customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)                                     (nope id)        (const noSchemaChanges)+                                    (nope id)                                     (nope id)   where     nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))

@@ -101,6 +101,7 @@ convert_type ty0 =     case ty0 of       TyList  ty    -> D.TY_list  $ convert_type     ty+      TySet   ty    -> D.TY_set   $ convert_type     ty       TyMaybe ty    -> D.TY_maybe $ convert_type     ty       TyName  tn    -> D.TY_ref   $ convert_ref      tn       TyBasic bt    -> D.TY_basic $ convert_basic    bt@@ -201,6 +202,7 @@ unconvert_type ty0 =     case ty0 of       D.TY_list  ty   -> TyList  $ unconvert_type  ty+      D.TY_set   ty   -> TySet   $ unconvert_type  ty       D.TY_maybe ty   -> TyMaybe $ unconvert_type  ty       D.TY_ref   r    -> TyName  $ unconvert_ref r       D.TY_basic bt   -> TyBasic $ unconvert_basic bt

@@ -128,6 +128,7 @@     // one of the following:     = union       | list   :: APIType           // a JSON list of the given type+      | set    :: APIType           // a set of the given type, encoded as a JSON list       | maybe  :: APIType           // either the given type or the null value       | ref    :: TypeRef           // a named type (node) with possible example       | 'basic':: BasicType         // a basic JSON type

@@ -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

@@ -94,11 +94,11 @@ -- custom migration tags in the changelog, as generated by -- 'generateMigrationKind'. -migrateDataDump :: (Read db, Read rec, Read fld)+migrateDataDump :: (Read db, Read rec, Read alt, Read fld)                 => (API, Version)               -- ^ Starting schema and version                 -> (API, VersionExtra)          -- ^ Ending schema and version                 -> APIChangelog                 -- ^ Log of changes, containing both versions-                -> CustomMigrations JS.Object JS.Value db rec fld  -- ^ Custom migration functions+                -> CustomMigrations JS.Object JS.Value db rec alt fld  -- ^ Custom migration functions                 -> TypeName                     -- ^ Name of the dataset's type                 -> DataChecks                   -- ^ How thoroughly to validate changes                 -> JS.Value                     -- ^ Dataset to be migrated@@ -110,11 +110,11 @@     db' <- applyChangesToDatabase root custom' db changes  ?!? uncurry ValueError     return (db', warnings) -migrateDataDump' :: (Read db, Read rec, Read fld)+migrateDataDump' :: (Read db, Read rec, Read alt, Read fld)                 => (API, Version)               -- ^ Starting schema and version                 -> (API, VersionExtra)          -- ^ Ending schema and version                 -> APIChangelog                 -- ^ Log of changes, containing both versions-                -> CustomMigrations Record Value db rec fld  -- ^ Custom migration functions+                -> CustomMigrations Record Value db rec alt fld  -- ^ Custom migration functions                 -> TypeName                     -- ^ Name of the dataset's type                 -> DataChecks                   -- ^ How thoroughly to validate changes                 -> Value.Value                  -- ^ Dataset to be migrated@@ -129,36 +129,41 @@   -- | Custom migrations used in the changelog must be implemented in--- Haskell, and supplied in this record.  There are three kinds:+-- Haskell, and supplied in this record.  There are four kinds: -- -- * Whole-database migrations, which may arbitrarily change the API -- schema and the data to match; ----- * Type migrations, which may change the schema of a single type; and+-- * Type migrations, which may change the schema of a single type; --+-- * Union alternative migrations, which may change the type of a+-- single alternative within a union (with the new type specified in+-- the changelog); and+-- -- * Single field migrations, which may change only the type of the -- field (with the new type specified in the changelog). -- -- For database and type migrations, if the schema is unchanged, the -- corresponding function should return 'Nothing'. ----- The @db@, @ty@ and @fld@ parameters should be instantiated with--- the enumeration types generated by 'generateMigrationKinds', which--- correspond to the exact set of custom migration tags used in the--- changelog.-data CustomMigrations o v db ty fld = CustomMigrations+-- The @db@, @ty@, @alt@ and @fld@ parameters should be instantiated+-- with the enumeration types generated by 'generateMigrationKinds',+-- which correspond to the exact set of custom migration tags used in+-- the changelog.+data CustomMigrations o v db ty alt fld = CustomMigrations     { databaseMigration       :: db -> o -> Either ValueError o     , databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)     , typeMigration           :: ty -> v -> Either ValueError v     , typeMigrationSchema     :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)+    , unionAltMigration       :: alt -> v -> Either ValueError v     , fieldMigration          :: fld -> v -> Either ValueError v } -type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag+type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag MigrationTag -readCustomMigrations :: (Read db, Read ty, Read fld)-                     => CustomMigrations o v db ty fld -> CustomMigrationsTagged o v-readCustomMigrations (CustomMigrations db dbs r rs f) =-    CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read)+readCustomMigrations :: (Read db, Read ty, Read alt, Read fld)+                     => CustomMigrations o v db ty alt fld -> CustomMigrationsTagged o v+readCustomMigrations (CustomMigrations db dbs r rs a f) =+    CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (a . read) (f . read)  -- | Lift a custom record migration to work on arbitrary values mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)@@ -200,10 +205,11 @@  -- | Whether to validate the dataset after this change validateAfter :: DataChecks -> APIChange -> Bool-validateAfter chks (ChChangeField{})  = chks >= CheckCustom-validateAfter chks (ChCustomType{})   = chks >= CheckCustom-validateAfter chks (ChCustomAll{})    = chks >= CheckCustom-validateAfter chks _                  = chks >= CheckAll+validateAfter chks (ChChangeField{})     = chks >= CheckCustom+validateAfter chks (ChChangeUnionAlt{})  = chks >= CheckCustom+validateAfter chks (ChCustomType{})      = chks >= CheckCustom+validateAfter chks (ChCustomAll{})       = chks >= CheckCustom+validateAfter chks _                     = chks >= CheckAll   --------------------@@ -243,22 +249,23 @@   -- | Sets of custom migration tags in the changelog for--- whole-database, single-record and single-field migrations-changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)-changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty)+-- whole-database, single-type, union-alternative and single-field migrations+changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)+changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty, Set.empty) changelogTags (ChangesUpTo _ cs older) =-    unions3 (map changeTags cs) `union3` changelogTags older+    unions4 (map changeTags cs) `union4` changelogTags older   where-    union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z)-    unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs)-      where (xs, ys, zs) = unzip3 xyzs+    union4 (a, b, c, d) (x, y, z, w) = (a `Set.union` x, b `Set.union` y, c `Set.union` z, d `Set.union` w)+    unions4 xyzws = (Set.unions xs, Set.unions ys, Set.unions zs, Set.unions ws)+      where (xs, ys, zs, ws) = unzip4 xyzws  -- | Sets of custom migration tags in a single change-changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)-changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)-changeTags (ChCustomType _ t)      = (Set.empty, Set.singleton t, Set.empty)-changeTags (ChCustomAll t)         = (Set.singleton t, Set.empty, Set.empty)-changeTags _                       = (Set.empty, Set.empty, Set.empty)+changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag, Set MigrationTag)+changeTags (ChChangeField _ _ _ t)     = (Set.empty, Set.empty, Set.empty, Set.singleton t)+changeTags (ChChangeUnionAlt _ _ _ t)  = (Set.empty, Set.empty, Set.singleton t, Set.empty)+changeTags (ChCustomType _ t)          = (Set.empty, Set.singleton t, Set.empty, Set.empty)+changeTags (ChCustomAll t)             = (Set.singleton t, Set.empty, Set.empty, Set.empty)+changeTags _                           = (Set.empty, Set.empty, Set.empty, Set.empty)   --------------------------------@@ -290,6 +297,7 @@      findType :: APIType -> Maybe UpdateTypePos     findType (TyList ty)      = UpdateList <$> findType ty+    findType (TySet ty)       = UpdateSet  <$> findType ty     findType (TyMaybe ty)     = UpdateMaybe <$> findType ty     findType (TyName tname')         | tname' == tname || tname' `Set.member` deps = Just $ UpdateNamed tname'@@ -304,11 +312,11 @@  -- | Check that a changelog adequately describes how to migrate from -- one version to another.-validateChanges :: (Read db, Read rec, Read fld)+validateChanges :: (Read db, Read rec, Read alt, Read fld)                 => (API, Version)              -- ^ Starting schema and version                 -> (API, VersionExtra)         -- ^ Ending schema and version                 -> APIChangelog                -- ^ Changelog to be validated-                -> CustomMigrations o v db rec fld -- ^ Custom migration functions+                -> CustomMigrations o v db rec alt fld -- ^ Custom migration functions                 -> TypeName                    -- ^ Name of the dataset's type                 -> DataChecks                  -- ^ How thoroughly to validate changes                 -> Either ValidateFailure [ValidateWarning]@@ -378,7 +386,7 @@             -> 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'@@ -484,6 +492,14 @@                            . Map.delete fname) unioninfo   return (Map.insert tname tinfo' api, findUpdatePos tname api) +applyAPIChangeToAPI _ _custom (ChChangeUnionAlt tname fname ftype _tag) api = do+  tinfo     <- lookupType tname api+  unioninfo <- expectUnionType tinfo        ?! TypeWrongKind tname TKUnion+  guard (Map.member fname unioninfo)        ?! FieldDoesNotExist tname TKUnion fname+  typeIsValid ftype api                     ?!? TypeMalformed ftype+  let tinfo' = (NUnionType . Map.insert fname ftype) unioninfo+  return (Map.insert tname tinfo' api, findUpdatePos tname api)+ applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do   tinfo    <- lookupType tname api   enuminfo <- expectEnumType tinfo                 ?! TypeWrongKind tname TKEnum@@ -571,6 +587,7 @@              -> UpdateTypePos              -> JS.Value -> Position -> Either (ValueError, Position) JS.Value updateTypeAt upds alter (UpdateList upd)    v p = withArrayElems (updateTypeAt upds alter upd) v p+updateTypeAt upds alter (UpdateSet upd)     v p = withArrayElems (updateTypeAt upds alter upd) v p updateTypeAt upds alter (UpdateMaybe upd)   v p = withMaybe (updateTypeAt upds alter upd) v p updateTypeAt upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of     Just upd -> updateDeclAt upds alter upd v p@@ -607,6 +624,13 @@                     | otherwise             -> return un         Nothing -> Left (JSONError $ SyntaxError "Not singleton", p) +applyChangeToData (ChChangeUnionAlt _ fname _ftype tag) custom = withObject $ \un p ->+  case matchSingletonObject un of+    Just (k, r) | k == _FieldName fname -> do+        r' <- liftMigration (unionAltMigration custom tag) r p+        return $ singletonObject (_FieldName fname) r'+    _ -> return un+ applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->     if s == _FieldName fname then return (_FieldName fname')                            else return s@@ -679,6 +703,9 @@ updateTypeAt' upds alter (UpdateList upd)    v p = do     xs <- expectList v p     List <$!> mapM (\ (i, v') -> updateTypeAt' upds alter upd v' (InElem i : p)) (zip [0..] xs)+updateTypeAt' upds alter (UpdateSet upd)     v p = do+    xs <- expectSetList v p+    SetList <$!> mapM (\ (i, v') -> updateTypeAt' upds alter upd v' (InElem i : p)) (zip [0..] xs) updateTypeAt' upds alter (UpdateMaybe upd)   v p = do     mb <- expectMaybe v p     case mb of@@ -718,6 +745,12 @@     (fn, v') <- expectUnion v p     pure $! if fn == fname then Union fname' v' else v +applyChangeToData' _ (ChChangeUnionAlt _ fname _ftype tag) custom v p = do+    (fn, v') <- expectUnion v p+    if fn == fname+      then Union fn <$!> liftMigration (unionAltMigration custom tag) v' (inField fn:p)+      else pure v+ applyChangeToData' _ (ChRenameEnumVal _ fname fname') _ v p = do     fn <- expectEnum v p     pure $! if fn == fname then Enum fname' else v@@ -800,16 +833,7 @@ 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 (TyMaybe _) = Just DefValMaybe-defaultValueForType _           = Nothing - ------------------------------------------- -- Validation that a dataset matches an API --@@ -835,6 +859,7 @@      valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value     valueMatches (TyList t)      = withArrayElems (valueMatches t)+    valueMatches (TySet t)       = withArrayElems (valueMatches t)     valueMatches (TyMaybe t)     = withMaybe (valueMatches t)     valueMatches (TyName tname)  = \ v p -> do         d <- lookupType tname api ?!? (\ f -> (InvalidAPI f, p))@@ -864,17 +889,21 @@  -- | Generate enumeration datatypes corresponding to the custom -- migrations used in an API migration changelog.-generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec]-generateMigrationKinds changes all_nm rec_nm fld_nm = do+generateMigrationKinds :: APIChangelog -> String -> String -> String -> String -> Q [Dec]+generateMigrationKinds changes all_nm rec_nm alt_nm fld_nm = do     guardNoDups (all_tags `Set.intersection` rec_tags)+    guardNoDups (all_tags `Set.intersection` alt_tags)     guardNoDups (all_tags `Set.intersection` fld_tags)+    guardNoDups (rec_tags `Set.intersection` alt_tags)     guardNoDups (rec_tags `Set.intersection` fld_tags)+    guardNoDups (alt_tags `Set.intersection` fld_tags)      return [ mkDataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs            , mkDataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs+           , mkDataD [] (mkName alt_nm) [] (cons alt_nm alt_tags) derivs            , mkDataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ]   where-    (all_tags, rec_tags, fld_tags) = changelogTags changes+    (all_tags, rec_tags, alt_tags, fld_tags) = changelogTags changes      guardNoDups xs       | Set.null xs = return ()

@@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-} @@ -15,6 +16,8 @@     , UpdateTypePos(..)     , UpdateDeclPos(..)     , APITableChange(..)++    , compactAPITableChanges     ) where  import           Data.API.PP@@ -22,6 +25,7 @@ import           Data.API.Types  import           Data.Map ( Map )+import           Data.Maybe import           Data.Version  @@ -57,6 +61,7 @@     | ChAddUnionAlt    TypeName FieldName APIType     | ChDeleteUnionAlt TypeName FieldName     | ChRenameUnionAlt TypeName FieldName FieldName+    | ChChangeUnionAlt TypeName FieldName APIType MigrationTag        -- Changes for enum types     | ChAddEnumVal    TypeName FieldName@@ -87,6 +92,9 @@                                       , "  alternative removed " ++ pp f]   ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t                                       , "  alternative renamed " ++ pp f ++ " to " ++ pp f']+  ppLines (ChChangeUnionAlt t f ty c) = [ "changed union " ++ pp t+                                        , "  alternative changed " ++ pp f ++ " :: " ++ pp ty+                                          ++ " migration " ++ pp c]   ppLines (ChAddEnumVal t f)        = [ "changed enum " ++ pp t                                       , "  alternative added " ++ pp f]   ppLines (ChDeleteEnumVal t f)     = [ "changed enum " ++ pp t@@ -129,6 +137,7 @@ -- | Represents the positions in a type to apply an update data UpdateTypePos     = UpdateList UpdateTypePos+    | UpdateSet UpdateTypePos     | UpdateMaybe UpdateTypePos     | UpdateNamed TypeName     deriving (Eq, Show)@@ -140,6 +149,9 @@     | 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

@@ -103,6 +103,7 @@  renderAPIType :: DocInfo -> APIType -> String renderAPIType di (TyList  ty  ) = "[" ++ renderAPIType di ty ++ "]"+renderAPIType di (TySet   ty  ) = "Set " ++ renderAPIType di ty renderAPIType di (TyMaybe ty  ) = "?" ++ renderAPIType di ty renderAPIType di (TyName  tn  ) = mk_link (doc_info_type_url di tn) (T.unpack (_TypeName tn)) renderAPIType _  (TyBasic bt  ) = pp bt

@@ -180,7 +180,7 @@     | ApiInvalid { vfInvalidVersion      :: VersionExtra                  , vfMissingDeclarations :: Set TypeName }         -- | changelog entry does not apply-    | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange]+    | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APIChange]                             , vfFailedToApply       :: APIChange                             , vfApplyFailure        :: ApplyFailure }         -- | changelog is incomplete

@@ -80,6 +80,7 @@ import qualified Data.ByteString.Base64         as B64 import qualified Data.ByteString.Lazy           as BL import           Data.Maybe+import qualified Data.Set                       as Set import qualified Data.Text                      as T import qualified Data.Text.Encoding             as T import           Data.Time@@ -204,6 +205,17 @@     where       help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x   parseJSONWithErrs JS.Null      = pure []+  parseJSONWithErrs v            = failWith $ expectedArray v++-- | Sets are encoded as JSON arrays.  Decoding is insensitive to the+-- order of elements and silently discards duplicates (matching the+-- behaviour of 'Data.Set.fromList'); encoding uses 'Data.Set.toList'+-- and hence produces the elements in ascending order.+instance (Ord a, FromJSONWithErrs a) => FromJSONWithErrs (Set.Set a) where+  parseJSONWithErrs (JS.Array a) = Set.fromList <$> traverse help (zip (V.toList a) [0..])+    where+      help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x+  parseJSONWithErrs JS.Null      = pure Set.empty   parseJSONWithErrs v            = failWith $ expectedArray v  instance FromJSONWithErrs Int where

@@ -71,6 +71,8 @@     (TyList  ty, Array arr) | Vec.null arr -> TList []                             | otherwise    -> TListI $ map (jsonToCBORType napi ty) (Vec.toList arr)     (TyList  _ , _)         -> error "serialiseJSONWithSchema: expected array"+    (TySet   ty, Array arr) -> TList $ map (jsonToCBORType napi ty) (Vec.toList arr)+    (TySet   _ , _)         -> error "serialiseJSONWithSchema: expected array"     (TyMaybe _ , Null)      -> TList []     (TyMaybe ty, _)         -> TList [jsonToCBORType napi ty v]     (TyName  tn, _)         -> jsonToCBORTypeName napi tn v@@ -156,6 +158,9 @@ postprocessJSONType :: NormAPI -> APIType -> Value -> Either ValueError Value postprocessJSONType napi ty0 v = case ty0 of     TyList ty  -> case v of+                   Array arr -> Array <$> traverse (postprocessJSONType napi ty) arr+                   _         -> Left $ JSONError $ expectedArray v+    TySet  ty -> case v of                    Array arr -> Array <$> traverse (postprocessJSONType napi ty) arr                    _         -> Left $ JSONError $ expectedArray v     TyMaybe ty -> case v of

@@ -206,6 +206,7 @@ type_md mdm ty =     case ty of       TyList  ty'  -> "[" ++ type_md mdm ty' ++ "]"+      TySet   ty'  -> "Set " ++ type_md mdm ty'       TyMaybe ty'  -> "? " ++ type_md mdm ty'       TyName  nm   -> mdmLink mdm nm       TyBasic bt   -> basic_type_md bt

@@ -124,6 +124,7 @@ -- | Find the set of type names used in an type typeFreeVars :: APIType -> Set TypeName typeFreeVars (TyList  t) = typeFreeVars t+typeFreeVars (TySet   t) = typeFreeVars t typeFreeVars (TyMaybe t) = typeFreeVars t typeFreeVars (TyName  n) = Set.singleton n typeFreeVars (TyBasic _) = Set.empty@@ -223,6 +224,7 @@ -- | Substitute types for type names in a type substType :: (TypeName -> APIType) -> APIType -> APIType substType f (TyList  t)   = TyList (substType f t)+substType f (TySet   t)   = TySet (substType f t) substType f (TyMaybe t)   = TyMaybe (substType f t) substType f (TyName  n)   = f n substType _ t@(TyBasic _) = t

@@ -62,6 +62,7 @@  instance PP APIType where   pp (TyList  ty) = "[" ++ pp ty ++ "]"+  pp (TySet   ty) = "Set " ++ pp ty   pp (TyMaybe ty) = "? " ++ pp ty   pp (TyName  t)  = pp t   pp (TyBasic b)  = pp b

@@ -40,6 +40,7 @@     '::'                                { (,) _ ColCol          }     '='                                 { (,) _ Equals          }     '?'                                 { (,) _ Query           }+    Set                                 { (,) _ Set             }     ','                                 { (,) _ Comma           }     '<='                                { (,) _ LtEq            }     '>='                                { (,) _ GtEq            }@@ -138,7 +139,7 @@ RRFields :: { [(FieldName, FieldType)] } RRFields     : RRFields FieldName '::' FieldType {  ($2,$4) : $1                     }-    |          FieldName '::' FieldType { [($1,$3)]                         }+    |                                   { []                                }  FieldType :: { FieldType } FieldType@@ -187,6 +188,7 @@ Type :: { APIType } Type     : '?' Type                          { TyMaybe            $2             }+    | Set Type                          { TySet              $2             }     | '[' Type ']'                      { TyList             $2             }     | TypeName                          { TyName             $1             }     | BasicType                         { TyBasic            $1             }@@ -280,6 +282,7 @@     : alternative added FieldName '::' Type      { [UnChAdd $3 $5]          }     | alternative removed FieldName              { [UnChDelete $3]          }     | alternative renamed FieldName to FieldName { [UnChRename $3 $5]       }+    | alternative changed FieldName '::' Type migration MigrationTag { [UnChChange $3 $5 $7] }     | comment                                    { []                       }  REnumChanges :: { [EnumChange] }@@ -331,11 +334,13 @@ data UnionChange = UnChAdd FieldName APIType                  | UnChDelete FieldName                  | UnChRename FieldName FieldName+                 | UnChChange FieldName APIType MigrationTag  unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange-unionChangeToAPIChange t (UnChAdd f ty)    = ChAddUnionAlt t f ty-unionChangeToAPIChange t (UnChDelete f)    = ChDeleteUnionAlt t f-unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'+unionChangeToAPIChange t (UnChAdd f ty)       = ChAddUnionAlt t f ty+unionChangeToAPIChange t (UnChDelete f)       = ChDeleteUnionAlt t f+unionChangeToAPIChange t (UnChRename f f')    = ChRenameUnionAlt t f f'+unionChangeToAPIChange t (UnChChange f ty m)  = ChChangeUnionAlt t f ty m  data EnumChange = EnChAdd FieldName                 | EnChDelete FieldName

@@ -43,6 +43,7 @@     "<="                                { simple    LtEq            }     ">="                                { simple    GtEq            }     "?"                                 { simple    Query           }+    "Set"                               { simple    Set             }     ","                                 { simple    Comma           }     version                             { simple    Version         } -- N.B. extend the 'keywords list below     with                                { simple    With            } -- when adding new keywords!@@ -87,7 +88,7 @@            , "binary", "json", "record", "union", "enum", "basic", "changes"            , "added", "removed", "renamed", "changed", "default", "field"            , "alternative", "migration", "to", "nothing", "true", "false"-           , "read-only"+           , "read-only", "Set"            ]  type PToken = (AlexPosn,Token)@@ -108,6 +109,7 @@     | Integer     | UTC     | Query+    | Set     | Record     | String     | Json

@@ -6,6 +6,7 @@ module Data.API.TH     ( applicativeE     , optionalInstanceD+    , optionalStandaloneDerivD     , funSigD     , simpleD     , simpleSigD@@ -28,12 +29,12 @@ -- | Construct an idiomatic expression (an expression in an -- Applicative context), i.e. ----- > app ke []             = ke+-- > app ke []             = pure ke -- > app ke [e1,e2,...,en] = ke <$> e1 <*> e2 ... <*> en applicativeE :: ExpQ -> [ExpQ] -> ExpQ applicativeE ke es0 =     case es0 of-      []   -> ke+      []   -> appE (varE 'pure) ke       e:es -> app' (ke `dl` e) es   where     app' e []      = e@@ -56,6 +57,17 @@   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]

@@ -20,6 +20,7 @@     , defaultToolSettings     , warnOnOmittedInstance     , newtypeSmartConstructors+    , defaultDerivedClasses        -- * Individual tools     , enumTool@@ -56,7 +57,6 @@ 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 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

@@ -22,6 +22,7 @@     , warnOnOmittedInstance     , newtypeSmartConstructors     , defaultToolSettings+    , defaultDerivedClasses     ) where  import           Data.API.Types@@ -29,6 +30,7 @@ import           Control.Applicative import           Data.Monoid import           Data.Semigroup as Sem+import           Data.String import           Language.Haskell.TH import           Prelude @@ -43,6 +45,8 @@     , 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,7 +54,31 @@ 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]++derive_node_nms :: [Name]+derive_node_nms = [''Show,''Eq]++  -- | A @'Tool' a@ is something that can generate TH declarations from -- a value of type @a@.  Tools can be combined using the 'Monoid'

@@ -2,7 +2,6 @@ module Data.API.Tools.Datatypes     ( datatypesTool     , datatypesTool'-    , defaultDerivedClasses     , type_nm     , rep_type_nm     , nodeT@@ -10,11 +9,13 @@     , nodeConE     , nodeConP     , nodeNewtypeConE+    , nodeNewtypeConP     , nodeFieldE     , nodeFieldP     , nodeAltConE     , nodeAltConP     , newtypeProjectionE+    , pref_field_nm     ) where  import           Data.API.TH@@ -27,18 +28,18 @@ import qualified Data.CaseInsensitive           as CI import           Data.Char import           Data.Maybe+import           Data.Set (Set) 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.@@ -58,13 +59,13 @@ -- | 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 @@ -100,7 +101,7 @@ -- >         , _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)]@@ -113,7 +114,7 @@ -- | 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)]@@ -135,7 +136,7 @@ -- >     | 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)]@@ -148,6 +149,7 @@ mk_type ty =     case ty of       TyList  ty'  -> AppT ListT  $ mk_type ty'+      TySet   ty'  -> AppT (ConT ''Set) $ mk_type ty'       TyMaybe ty'  -> AppT (ConT ''Maybe) $ mk_type ty'       TyName  nm   -> ConT  $ mkNameText $ _TypeName nm       TyBasic bt   -> basic_type bt@@ -163,28 +165,6 @@       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@@ -251,6 +231,9 @@ -- | The constructor for a newtype, which might be renamed 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

@@ -31,8 +31,10 @@     x <- newName "x"     optionalInstanceD ts ''NFData [nodeRepT an] [simpleD 'rnf (bdy an sr x)]   where-    bdy an sr x = lamE [varP x] $ foldr f [e|()|] (srFields sr)+    bdy an sr x = lamE [pat] $ foldr f [e|()|] (srFields sr)       where+        pat | null (srFields sr) = wildP+            | otherwise          = varP x         f (fn,_) r = [e| rnf ($(nodeFieldE an fn) $(varE x)) `seq` $r |]  gen_su :: Tool (APINode, SpecUnion)

@@ -19,6 +19,7 @@ import           Data.Aeson import qualified Data.ByteString.Char8          as B import           Data.Monoid+import qualified Data.Set                       as Set import           Data.Time import           Language.Haskell.TH import           Test.QuickCheck                as QC@@ -42,6 +43,9 @@ instance Example a => Example [a] where     example = listOf example +instance (Ord a, Example a) => Example (Set.Set a) where+    example = Set.fromList <$> listOf example+ instance Example Int where     example = arbitrarySizedBoundedIntegral `suchThat` (> 0) @@ -108,7 +112,9 @@ gen_sr_ex = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example (bdy an sr)]   where     bdy an sr = do x <- newName "x"-                   appE (varE 'QC.sized) $ lamE [varP x] $+                   let pat | null (srFields sr) = wildP+                           | otherwise          = varP x+                   appE (varE 'QC.sized) $ lamE [pat] $                        applicativeE (nodeConE an) $                        replicate (length $ srFields sr) $                        [e| QC.resize ($(varE x) `div` 2) example |]

@@ -118,10 +118,13 @@     x <- newName "x"     optionalInstanceD ts ''ToJSON [nodeRepT an] [simpleD 'toJSON (bdy an sr x)]   where-    bdy an sr x = lamE [varP x] $+    bdy an sr x = lamE [pat] $             varE 'object `appE`             listE [ [e| $(fieldNameE fn) .= $(nodeFieldE an fn) $(varE x) |]                   | (fn, _) <- srFields sr ]+      where+        pat | null (srFields sr) = wildP+            | otherwise          = varP x   {-@@ -142,8 +145,10 @@     optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]                       [funD 'parseJSONWithErrs [cl an sr x, clNull, cl' x]]   where-    cl an sr x  = clause [conP 'Object [varP x]] (normalB bdy) []+    cl an sr x  = clause [conP 'Object [pat]] (normalB bdy) []       where+        pat | null (srFields sr) = wildP+            | otherwise          = varP x         bdy = applicativeE (nodeConE an) $ map project (srFields sr)         project (fn, ft) = [e| withDefaultField ro (fmap defaultValueAsJsValue mb_dv) $(fieldNameE fn) parseJSONWithErrs $(varE x) |]           where ro    = ftReadOnly ft

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE TemplateHaskell            #-}  module Data.API.Tools.QuickCheck@@ -12,17 +13,32 @@ 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,50 +48,177 @@ -- 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:     --   sized (\ x -> JobSpecId <$> resize (x `div` 2) arbitrary <*> ...)     bdy an sr = do x <- newName "x"-                   appE (varE 'QC.sized) $ lamE [varP x] $+                   let pat | null (srFields sr) = wildP+                           | otherwise          = varP x+                   appE (varE 'QC.sized) $ lamE [pat] $                      applicativeE (nodeConE an) $                      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: -- -- > instance Arbitrary Foo where--- >     arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ]+-- >     arbitrary = sized $ \ x -> oneOf [ fmap Bar (resize (x `div` 2) arbitrary)+-- >                                      , fmap Baz (resize (x `div` 2) 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) |]-      where-        alts = [ [e| fmap $(nodeAltConE an k) arbitrary |]-               | (k, _) <- suFields su ]+              | otherwise          = do+                  x <- newName "x"+                  let alts = [ [e| fmap $(nodeAltConE an k) (QC.resize ($(varE x) `div` 2) arbitrary) |]+                             | (k, _) <- suFields su ]+                  appE (varE 'QC.sized) $ lamE [varP x] $+                    varE 'oneof `appE` listE alts +    -- 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 +226,15 @@ -- >     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

@@ -37,6 +37,11 @@ -- traversals generated automatically: if required, these must be -- defined manually in the same module as the call to 'traversalTool', -- otherwise the generated code will lead to scope errors.+--+-- If the schema uses sets, the generated traversals of set-valued+-- fields are not lawful 'Traversal's (they cannot be, because+-- 'Set.Set' is not a 'Functor'): they may coalesce multiple elements+-- that are mapped to the same value. traversalTool :: TypeName -> TypeName -> APITool traversalTool root = traversalsTool [root] @@ -60,9 +65,11 @@   -- | @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@@@ -73,6 +80,12 @@     ty = nodeT an  +-- | Traverse the elements of a 'Set.Set'.  This is not a lawful 'Traversal'+-- (it cannot be, because 'Set.Set' is not a 'Functor'), but it is what the+-- traversals generated by 'traversalsTool' use for set-valued fields.+traverseSet :: (Applicative f, Ord b) => (a -> f b) -> Set.Set a -> f (Set.Set b)+traverseSet f = fmap Set.fromList . traverse f . Set.toList+ -- | Construct a traversal of the X substructures of the given type traverser :: NormAPI -> Set.Set TypeName -> TypeName -> APIType -> ExpQ traverser napi targets x ty = fromMaybe [| const pure |] $ traverser' napi targets x ty@@ -81,6 +94,11 @@ -- or return 'Nothing' if there are no substructures to traverse traverser' :: NormAPI -> Set.Set TypeName -> TypeName -> APIType -> Maybe ExpQ traverser' napi targets x (TyList ty)  = fmap (appE [e|(.) traverse|]) $ traverser' napi targets x ty+-- 'Data.Set.Set' is not 'Traversable' (the element type is constrained by+-- 'Ord'), but we can still traverse the elements via the element list.  Note+-- that this may shrink the set, if the function maps distinct elements of the+-- original set to the same value.+traverser' napi targets x (TySet  ty)  = fmap (appE [e|(.) traverseSet|]) $ traverser' napi targets x ty traverser' napi targets x (TyMaybe ty) = fmap (appE [e|(.) traverse|]) $ traverser' napi targets x ty traverser' napi targets x (TyName tn)   | tn == x   = Just [e| id |]@@ -88,8 +106,8 @@   | 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@@ -106,13 +124,16 @@ 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"-      lamE [varP f, varP r] $ applicativeE (nodeConE an) $ map (traverseField f r) (srFields sr)+      let (patF, patR) | null (srFields sr) = (wildP, wildP)+                        | otherwise          = (varP f, varP r)+      lamE [patF, patR] $ applicativeE (nodeConE an) $ map (traverseField f r) (srFields sr)     traverseField f r (fn, fty) = [e| $(traverser napi targets x (ftType fty)) $(varE f) ($(nodeFieldE an fn) $(varE r)) |]  @@ -127,9 +148,10 @@ 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"

@@ -74,10 +74,11 @@ > example = [api| > > rec :: MyRecord->    // A record type containing two fields+>    // A record type containing three fields >    = record >        x :: [integer]   // one field >        y :: ? [utc]     // another field+>        z :: Set integer // a set of integers > > chc :: MyChoice >     // A disjoint union@@ -103,7 +104,16 @@  The basic types available (and their Haskell representations) are @string@ ('Text'), @binary@ ('Binary'), @integer@ ('Int'), @boolean@-('Bool') and @utc@ ('UTCTime').+('Bool') and @utc@ ('UTCTime').  Collections and optionality are+written @[T]@ for lists, @Set T@ for sets and @? T@ for optional+values.  A set is encoded on the wire as an array like a list:+decoding accepts elements in any order and discards duplicates, while+encoding uses ascending order.  Set element types must have an 'Ord'+instance on the Haskell side.  Basic types, newtypes and enumerations+derive 'Ord' automatically, but records and unions do not, so a set of+a record or union type needs 'Data.API.Tools.datatypesTool'' (or the+'Data.API.Tools.defaultDerivedClasses' setting) to add 'Ord' to the+derived classes.  The prefix (given before the @::@ on each type declaration) is used to name record fields and enumeration/union constructors in the generated@@ -120,6 +130,7 @@  > data MyRecord = MyRecord { rec_x :: [Int] >                          , rec_y :: Maybe [UTCTime]+>                          , rec_z :: Data.Set.Set Int >                          } > > data MyChoice = CHC_a MyRecord | CHC_b String@@ -139,8 +150,9 @@  For some types, it may be desirable to use a different datatype in the Haskell code, rather than relying on the generated datatype.  For-example, this allows collection types (such as sets) to be used in-place of lists, or allows additional invariants to be enforced.  The+example, this allows specialised collection or representation types to+be used in place of the defaults, or allows additional invariants to be+enforced.  The JSON serialization agrees with the schema (so the difference is invisible to non-Haskell clients).  This is possible using a @with@ clause in the schema DSL, which follows the type declaration and gives@@ -301,13 +313,14 @@ which describes how to transform the data (and 'API', if appropriate) for each custom migration.  For example, -> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration")+> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "UnionAltMigration" "FieldMigration")  with the changelog fragment above would give -> data DatabaseMigration = MigrateWholeDatabase | ...-> data TypeMigration     = MigrateWidgetType    | ...-> data FieldMigration    = MigrateFooField      | ...+> data DatabaseMigration  = MigrateWholeDatabase | ...+> data TypeMigration      = MigrateWidgetType    | ...+> data UnionAltMigration  = ...+> data FieldMigration     = MigrateFooField      | ...  Calls to 'migrateDataDump' should include a suitable 'CustomMigrations' record, which includes functions to perform the

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP                        #-} {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveLift                 #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -29,17 +30,20 @@     , UTCRange(..)     , RegEx(..)     , Binary(..)+    , defaultValueForType     , defaultValueAsJsValue     , mkRegEx     , 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@@ -261,9 +265,13 @@ -- a projection function name. type Conversion = Maybe (FieldName,FieldName) --- | Type is either a list, Maybe, a named element of the API or a basic type+-- | Type is a list, set, Maybe, a named element of the API or a basic type+--+-- Sets use 'Data.Set.Set' in the generated Haskell types, but are+-- represented on the wire as JSON (and CBOR) arrays. data APIType     = TyList  APIType       -- ^ list elements are types+    | TySet   APIType       -- ^ set elements are types (encoded as an array)     | TyMaybe APIType       -- ^ Maybe elements are types     | TyName  TypeName      -- ^ the referenced type must be defined by the API     | TyBasic BasicType     -- ^ a JSON string, int, bool etc.@@ -276,6 +284,7 @@  instance NFData APIType where   rnf (TyList  ty) = rnf ty+  rnf (TySet   ty) = rnf ty   rnf (TyMaybe ty) = rnf ty   rnf (TyName  tn) = rnf tn   rnf (TyBasic bt) = rnf bt@@ -311,6 +320,16 @@   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.@@ -326,7 +345,7 @@ -- | 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

@@ -22,6 +22,7 @@     , expectEnum     , expectUnion     , expectList+    , expectSetList     , expectMaybe     , lookupType @@ -93,6 +94,26 @@            | Bool    !Bool            | Int     !Int            | List    ![Value]+           -- | A set on the wire.  We retain the serialised order rather+           -- than sorting in the generic representation, so that generic+           -- CBOR decoding agrees with type-specific decoders: a decoder+           -- that never sorts cannot be confused by an 'Ord' instance on+           -- the concrete type whose ordering disagrees with the ordering+           -- of the corresponding 'Value's.+           --+           -- This is deliberately a separate constructor from 'List':+           -- 'encode' has no schema to hand and dispatches purely on the+           -- constructor, and @serialise@ encodes sets and lists+           -- differently on the wire (sets use a definite-length encoding,+           -- via @Codec.Serialise.Class.encodeSetSkel@, where lists use+           -- the indefinite-length encoding), so we could not pick the+           -- right length encoding otherwise.+           --+           -- A consequence is that changing a field between a list and a+           -- set changes its CBOR serialisation format, so such a change+           -- is not wire-compatible and must be treated with caution+           -- (e.g. accompanied by a data migration).+           | SetList ![Value]            | Maybe   !(Maybe Value)            | Union   !FieldName !Value            | Enum    !FieldName@@ -120,6 +141,7 @@   rnf (Bool b)     = rnf b   rnf (Int i)      = rnf i   rnf (List xs)    = rnf xs+  rnf (SetList xs) = rnf xs   rnf (Maybe mb)   = rnf mb   rnf (Union fn v) = rnf fn `seq` rnf v   rnf (Enum fn)    = rnf fn@@ -137,6 +159,7 @@ fromDefaultValue :: NormAPI -> APIType -> DefaultValue -> Maybe Value fromDefaultValue api ty0 dv = case (ty0, dv) of     (TyList  _, DefValList)    -> pure (List [])+    (TySet   _, DefValList)    -> pure (SetList [])     (TyMaybe _, DefValMaybe)   -> pure (Maybe Nothing)     (TyMaybe ty, _)            -> Maybe . Just <$> fromDefaultValue api ty dv     (TyBasic bt, _)            -> fromDefaultValueBasic bt dv@@ -172,6 +195,7 @@                 Bool b         -> JS.Bool b                 Int i          -> JS.toJSON i                 List vs        -> JS.toJSON vs+                SetList vs     -> JS.toJSON vs                 Maybe Nothing  -> JS.Null                 Maybe (Just v) -> JS.toJSON v                 Union fn v     -> JS.object [fieldNameToKey fn JS..= v]@@ -191,6 +215,9 @@     TyList ty  -> case v of                     JS.Array arr -> List <$> traverse (parseJSON api ty) (V.toList arr)                     _            -> failWith (expectedArray v)+    TySet  ty -> case v of+                   JS.Array arr -> SetList <$> traverse (parseJSON api ty) (V.toList arr)+                   _            -> failWith (expectedArray v)     TyMaybe ty -> case v of                     JS.Null -> pure (Maybe Nothing)                     _       -> Maybe . Just <$> parseJSON api ty v@@ -231,6 +258,7 @@     Bool b     -> CBOR.encode b     Int i      -> CBOR.encode i     List vs    -> encodeListWith encode vs+    SetList vs -> CBOR.encodeListLen (fromIntegral (length vs)) <> mconcat (map encode vs)     Maybe mb_v -> encodeMaybeWith encode mb_v     Union fn v -> encodeUnion (_FieldName fn) (encode v)     Enum fn    -> CBOR.encode (_FieldName fn)@@ -246,6 +274,7 @@ decode api ty0 = case ty0 of     TyName tn  -> decodeDecl api (lookupTyName api tn)     TyList ty  -> List  <$!> decodeListWith (decode api ty)+    TySet  ty  -> SetList <$!> decodeListWith (decode api ty)     TyMaybe ty -> Maybe <$!> decodeMaybeWith (decode api ty)     TyJSON     -> JSON  <$!> decodeJSON     TyBasic bt -> decodeBasic bt@@ -289,6 +318,9 @@     TyList ty  -> case v0 of                     List vs -> mapM_ (\ (i, v) -> matchesNormAPI api ty v (InElem i : p)) (zip [0..] vs)                     _       -> Left (JSONError (expectedArray js_v), p)+    TySet  ty -> case v0 of+                   SetList vs -> mapM_ (\ (i, v) -> matchesNormAPI api ty v (InElem i : p)) (zip [0..] vs)+                   _          -> Left (JSONError (expectedArray js_v), p)     TyMaybe ty -> case v0 of                     Maybe Nothing -> return ()                     Maybe (Just v) -> matchesNormAPI api ty v p@@ -351,6 +383,10 @@ expectList (List xs) _ = pure xs expectList v         p = Left (JSONError (Expected ExpArray "List" (JS.toJSON v)), p) +expectSetList :: Value -> Position -> Either (ValueError, Position) [Value]+expectSetList (SetList xs) _ = pure xs+expectSetList v            p = Left (JSONError (Expected ExpArray "Set" (JS.toJSON v)), p)+ expectMaybe :: Value -> Position -> Either (ValueError, Position) (Maybe Value) expectMaybe (Maybe v) _ = pure v expectMaybe v         p = Left (JSONError (Expected ExpArray "Maybe" (JS.toJSON v)), p)@@ -367,12 +403,17 @@                    return (TyName tn, v)  -- | Given a schema and a type, generate an arbitrary value of that--- type.+-- type.  Uses 'QC.sized' and 'QC.resize' to ensure recursive schemas+-- terminate by halving the size parameter at each structural+-- recursion point. arbitraryOfType :: NormAPI -> APIType -> QC.Gen Value-arbitraryOfType api ty0 = case ty0 of-    TyName  tn -> arbitraryOfDecl api (lookupTyName api tn)-    TyList  ty -> List  <$> QC.listOf (arbitraryOfType api ty)-    TyMaybe ty -> Maybe <$> QC.oneof [pure Nothing, Just <$> arbitraryOfType api ty]+arbitraryOfType api ty0 = QC.sized $ \ size -> case ty0 of+    TyName  tn -> QC.resize (size `div` 2) $ arbitraryOfDecl api (lookupTyName api tn)+    TyList  ty -> List  <$> QC.resize (size `div` 2) (QC.listOf (arbitraryOfType api ty))+    TySet   ty -> SetList <$> QC.resize (size `div` 2) (QC.listOf (arbitraryOfType api ty))+    TyMaybe ty -> Maybe <$> if size <= 0+                             then pure Nothing+                             else QC.oneof [pure Nothing, Just <$> QC.resize (size `div` 2) (arbitraryOfType api ty)]     TyJSON     -> JSON  <$> arbitraryJSONValue     TyBasic bt -> arbitraryOfBasicType bt @@ -388,12 +429,15 @@                 <$> QC.arbitrary  arbitraryOfDecl :: NormAPI -> NormTypeDecl -> QC.Gen Value-arbitraryOfDecl api d = case d of-    NRecordType nrt -> Record <$> traverse (\ (fn, ty) -> Field fn <$> arbitraryOfType api ty) (Map.toList nrt)+arbitraryOfDecl api d = QC.sized $ \size ->+  case d of+    NRecordType nrt ->+      let fields = Map.toList nrt+      in Record <$> traverse (\ (fn, ty) -> Field fn <$> QC.resize (size `div` 2) (arbitraryOfType api ty)) fields     NUnionType  nut -> do (fn, ty) <- QC.elements (Map.toList nut)-                          Union fn <$> arbitraryOfType api ty+                          Union fn <$> QC.resize (size `div` 2) (arbitraryOfType api ty)     NEnumType   net -> Enum <$> QC.elements (Set.toList net)-    NTypeSynonym ty -> arbitraryOfType api ty+    NTypeSynonym ty -> QC.resize (size `div` 2) (arbitraryOfType api ty)     NNewtype     bt -> arbitraryOfBasicType bt  -- | A reasonably varied generator for JSON 'JS.Value's.

@@ -24,6 +24,10 @@             [ (,) "wubble"  (TyList $ TyName "Foo", "list of Foo")             , (,) "flubble" (TyBasic BTstring     , "a string"   )             ]) Nothing+    , APINode "IntSetRec" "record with set fields" "isr" (SpRecord $ SpecRecord+            [ (,) "Ints"  (FieldType (TySet (TyBasic BTint))  False Nothing "a set of ints")+            , (,) "Bools" (FieldType (TyMaybe (TySet (TyBasic BTbool))) False Nothing "an optional set of bools")+            ]) Nothing     , APINode "Enumer" "enum test defn" "enm" (SpEnum $ SpecEnum             [ ("wubble", "")             , ("flubble", "")@@ -110,6 +114,12 @@ j :: JSON     = json +srec :: SetRec+    = record+        ints  :: Set integer // a set of integers+        flags :: Set Flag    // a set of boolean newtypes+        utcs  :: ? Set utc   // an optional set of UTC timestamps+ nr :: NewRec     = record         bb :: BasicBinary@@ -127,4 +137,7 @@     = union       | bb :: BasicBinary       | j  :: JSON++er :: EmptyRecord+    = record |]

@@ -14,6 +14,7 @@ import           Data.API.Tools import           Data.API.Tools.Datatypes import           Data.API.Tools.Example+import           Data.API.Tools.Traversal #if !MIN_VERSION_aeson(2,0,3) import           Data.API.Value ( arbitraryJSONValue ) #endif@@ -48,7 +49,7 @@                    ])  $(generateAPIToolsWith (defaultToolSettings { newtypeSmartConstructors = True }) example2-                       [ datatypesTool' ((''Generic :) . defaultDerivedClasses) ])+                       [ datatypesTool' ((''Generic :) . defaultDerivedClasses defaultToolSettings) ])  data Coord = Coord Int Int     deriving (Eq,Show)@@ -145,4 +146,7 @@                    , jsonToCBORTestsTool 'example2 (mkName "example2TestsJSONToCBOR")                    , jsonGenericValueTestsTool 'example2 (mkName "example2JSONGenericValueTests")                    , cborGenericValueTestsTool 'example2 (mkName "example2CBORGenericValueTests")+                     -- generates traverseFlagSetRec, which exercises traversing+                     -- into a set-valued field+                   , traversalTool "SetRec" "Flag"                    ])

@@ -20,6 +20,9 @@ import qualified Data.API.Value           as Value  import qualified Data.Aeson               as JS+import           Data.Functor.Identity    (Identity(..))+import           Data.List                (find)+import qualified Data.Set                 as Set  import           Test.Tasty import           Test.Tasty.HUnit@@ -51,6 +54,15 @@                                , help (JS.object ["id" JS..= JS.Number 3])                                       (Recursive (Id 3) Nothing)                                       True+                                 -- Sets decode from plain arrays, insensitive+                                 -- to element order and to duplicates, and are+                                 -- not decoded from objects.+                               , help (JS.toJSON [3, 1, 2, 1 :: Int])+                                      (Set.fromList [1, 2, 3 :: Int])+                                      True+                               , help (JS.object ["value" JS..= [1 :: Int]])+                                      (Set.fromList [1 :: Int])+                                      False                                , help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True                                , help' noFilter (JS.String "cabcage") (UnsafeMkFilteredString "cabcage") True                                , help' noFilter (JS.String "2014-10-13T15:20:10Z") (UnsafeMkFilteredUTC (unsafeParseUTC "2014-10-13T15:20:10Z")) True@@ -114,11 +126,25 @@     bad_time  = unsafeParseUTC "2014-10-13T15:20:10Z"     good_time = unsafeParseUTC "2014-10-13T15:20:13Z" +-- | Test that empty record definitions are parsed correctly+emptyRecordParsing :: [TestTree]+emptyRecordParsing =+  [ testCase "empty record has no fields" $+      case findNode "EmptyRecord" example2 of+        Nothing   -> assertFailure "EmptyRecord not found in example2 API"+        Just node -> anSpec node @?= SpRecord (SpecRecord [])+  ]+  where+    findNode name = find (\n -> anName n == TypeName name) . concatMap thNode+    thNode (ThNode n) = [n]+    thNode _          = []+ jsonTests :: TestTree jsonTests = testGroup "JSON"   [ testCase  "Basic value decoding"  basicValueDecoding   , testGroup "Decoding invalid data" errorDecoding   , testGroup "Smart constructors"    smartConstructors+  , testGroup "Empty record parsing"  emptyRecordParsing   , testGroup "Round-trip tests"       [ testGroup "example JSON"   $ map (uncurry QC.testProperty) exampleTestsJSON       , testGroup "example CBOR"   $ map (uncurry QC.testProperty) exampleTestsCBOR@@ -144,7 +170,18 @@     , testGroup "example agreement with Serialise" $ map (uncurry QC.testProperty) exampleCBORGenericValueTests     , testGroup "example2 agreement with Serialise" $ map (uncurry QC.testProperty) example2CBORGenericValueTests     ]+  , testCase "traversal visits set elements" setTraversalTest   ]++-- | Generated traversals must descend into set-valued fields, not silently+-- leave them alone.+setTraversalTest :: Assertion+setTraversalTest = assertEqual "flags not traversed" (Set.singleton True) (_srec_flags r')+  where+    -- Flag is a synonym for boolean, so the set has at most two elements;+    -- mapping them all to True must collapse it to a singleton.+    r  = SetRec (Set.fromList [1, 2]) (Set.fromList [False, True]) Nothing+    r' = runIdentity (traverseFlagSetRec (\ _ -> Identity True) r)  exampleNF :: NormAPI exampleNF = apiNormalForm example

@@ -3,6 +3,7 @@ import           Data.API.Test.JSON import           Data.API.Test.Migration import           Data.API.Test.Time+import           Data.API.Test.UnionMigration  import           Test.Tasty import           Test.Tasty.QuickCheck@@ -12,6 +13,7 @@  tests :: TestTree tests = testGroup "api-tools" [ migrationTests+                              , unionMigrationTests                               , jsonTests                               , timeTests                               , testProperty "Convert/unconvert" convertUncovertTest

@@ -40,7 +40,7 @@ #endif  -$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")+$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestUnionAltMigration" "TestFieldMigration")   -- Test of a whole-database migration: copy data between tables@@ -121,18 +121,20 @@ testFieldMigration' ConvertBinaryToString v = Left $ CustomMigrationError "bad data" (JS.toJSON v)  -testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestFieldMigration+testMigration :: CustomMigrations JS.Object JS.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration testMigration = CustomMigrations testDatabaseMigration                                  testDatabaseMigrationSchema                                  testRecordMigration                                  testRecordMigrationSchema+                                 (\ _ -> noDataChanges)                                  testFieldMigration -testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestFieldMigration+testMigration' :: CustomMigrations Value.Record Value.Value TestDatabaseMigration TestRecordMigration TestUnionAltMigration TestFieldMigration testMigration' = CustomMigrations testDatabaseMigration'                                   testDatabaseMigrationSchema                                   testRecordMigration'                                   testRecordMigrationSchema+                                  (\ _ -> noDataChanges)                                   testFieldMigration'  

@@ -57,6 +57,7 @@         id   :: Id         nest :: Nested         en   :: AnEnum+        ens  :: Set AnEnum         un   :: AUnion         quux :: ? IdId @@ -125,10 +126,12 @@         id   :: Id         nest :: RenamedNested         en   :: AnEnum+        ens  :: Set AnEnum         un   :: AUnion         c    :: string         nolist  :: [string]         nomaybe :: ? string+        noset   :: Set string  barPrefix :: RenamedBar     = record@@ -175,6 +178,7 @@   changed record Foo     field added nolist  :: [string]     field added nomaybe :: ? string+    field added noset   :: Set string  version "2.5"   // schema-changing custom record migration@@ -596,8 +600,8 @@   startData, endData :: JS.Value-Just startData = JS.decode "{ \"foo\": [ {\"id\": 42, \"nest\": { \"id\": 3 }, \"en\": \"foo\", \"un\": { \"bar\": { \"id\": 43 } }, \"quux\": null } ], \"bar\": [ { \"id\": 4 } ], \"recur\": [{ \"id\": 9, \"recur\": { \"id\": 8, \"recur\": null} }] }"-Just endData = JS.decode "{ \"foo\": [ {\"id\":42, \"nest\": { \"id\": 3, \"new\": \"hello\" }, \"c\": \"foobar42\", \"en\": \"foofoo\", \"un\": { \"barbar\": { \"id\": 43 } }, \"nolist\": [], \"nomaybe\": null } ], \"boz\": [], \"bar2\": [ {\"id\": 4 } ], \"recur\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }], \"recur2\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }] }"+Just startData = JS.decode "{ \"foo\": [ {\"id\": 42, \"nest\": { \"id\": 3 }, \"en\": \"foo\", \"ens\": [\"foo\", \"bar\"], \"un\": { \"bar\": { \"id\": 43 } }, \"quux\": null } ], \"bar\": [ { \"id\": 4 } ], \"recur\": [{ \"id\": 9, \"recur\": { \"id\": 8, \"recur\": null} }] }"+Just endData = JS.decode "{ \"foo\": [ {\"id\":42, \"nest\": { \"id\": 3, \"new\": \"hello\" }, \"c\": \"foobar42\", \"en\": \"foofoo\", \"ens\": [\"foofoo\", \"bar\"], \"un\": { \"barbar\": { \"id\": 43 } }, \"nolist\": [], \"nomaybe\": null, \"noset\": [] } ], \"boz\": [], \"bar2\": [ {\"id\": 4 } ], \"recur\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }], \"recur2\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }] }"  startVersion :: Version startVersion = changelogStartVersion changelog

@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TemplateHaskell            #-}++-- | Tests for union alternative migration with type changes+--+-- This module tests the 'alternative changed' changelog feature, which allows+-- changing the type of a union alternative with a custom migration function.+module Data.API.Test.UnionMigration+    ( unionMigrationTests+    ) where++import           Data.API.Changes+import           Data.API.JSON+import           Data.API.JSON.Compat+import           Data.API.Types+import           Data.API.Utils++import qualified Data.Aeson               as JS+import qualified Data.Aeson.Encode.Pretty as JS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text                as T+import           Data.Version+import           Test.Tasty+import           Test.Tasty.HUnit++import           Data.API.Test.UnionMigrationData+++-- Generate migration enums from changelog+$(generateMigrationKinds typeSwapChangelog "TypeSwapDbMigration" "TypeSwapRecordMigration" "TypeSwapUnionAltMigration" "TypeSwapFieldMigration")+++-- -----------------------------------------------------------------------------+-- Type Swap Migration (PersonV1 -> PersonV2)+-- -----------------------------------------------------------------------------++-- | Migrate PersonV1 to PersonV2+--+-- PersonV1: { "name": "John" }+-- PersonV2: { "fullName": "John", "age": 0 }+--+-- This is a type migration because we're transforming the entire inner value+-- of the union alternative from one type to another.+migratePersonV1ToV2 :: TypeSwapUnionAltMigration -> JS.Value -> Either ValueError JS.Value+migratePersonV1ToV2 MigratePersonV1ToV2 (JS.Object obj) = do+    nameVal <- lookupKey "name" obj ?! CustomMigrationError "missing 'name' field" (JS.Object obj)+    case nameVal of+        JS.String name -> return $ JS.Object $+            insertKey "fullName" (JS.String name) $+            singletonObject "age" (JS.Number 0)+        _ -> Left $ CustomMigrationError "expected string for 'name'" (JS.Object obj)+migratePersonV1ToV2 MigratePersonV1ToV2 v =+    Left $ CustomMigrationError "expected object for PersonV1" v+++typeSwapMigration :: CustomMigrations JS.Object JS.Value TypeSwapDbMigration TypeSwapRecordMigration TypeSwapUnionAltMigration TypeSwapFieldMigration+typeSwapMigration = CustomMigrations+    { databaseMigration       = \ _ -> noDataChanges+    , databaseMigrationSchema = \ _ -> noSchemaChanges+    , typeMigration           = \ _ -> noDataChanges+    , typeMigrationSchema     = \ _ -> noSchemaChanges+    , unionAltMigration       = migratePersonV1ToV2+    , fieldMigration          = \ _ -> noDataChanges+    }+++-- Test data for type swap+--+-- Start: Container with MyUnion containing PersonV1+-- End:   Container with MyUnion containing PersonV2++-- | Start data: { "person": { "person": { "name": "Alice" } } }+startTypeSwapData :: JS.Value+Just startTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"name\": \"Alice\" } } }"++-- | Expected end data: { "person": { "person": { "fullName": "Alice", "age": 0 } } }+expectedTypeSwapData :: JS.Value+Just expectedTypeSwapData = JS.decode "{ \"person\": { \"person\": { \"fullName\": \"Alice\", \"age\": 0 } } }"++-- | Start data with "other" alternative (should pass through unchanged)+startOtherAltData :: JS.Value+Just startOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }"++-- | Expected end data for "other" alternative (unchanged)+expectedOtherAltData :: JS.Value+Just expectedOtherAltData = JS.decode "{ \"person\": { \"other\": 42 } }"+++-- | Test migrating PersonV1 to PersonV2 within a union+typeSwapMigrationTest :: Assertion+typeSwapMigrationTest = do+    -- Verify start data matches start schema+    case dataMatchesAPI rootName startTypeSwapSchema startTypeSwapData of+        Right () -> return ()+        Left err -> assertFailure $ "Start data does not match start API: "+                                      ++ prettyValueErrorPosition err++    -- Verify expected end data matches end schema+    case dataMatchesAPI rootName endTypeSwapSchema expectedTypeSwapData of+        Right () -> return ()+        Left err -> assertFailure $ "Expected end data does not match end API: "+                                      ++ prettyValueErrorPosition err++    -- Run migration+    case migrateDataDump (startTypeSwapSchema, parseVer "0")+                         (endTypeSwapSchema, Release (parseVer "1.0"))+                         typeSwapChangelog typeSwapMigration rootName CheckAll+                         startTypeSwapData of+      Right (v, [])+          | expectedTypeSwapData == v -> return ()+          | otherwise -> assertFailure $ unlines+              [ "Type swap migration produced wrong result"+              , "Expected:"+              , BL.unpack (JS.encodePretty expectedTypeSwapData)+              , "but got:"+              , BL.unpack (JS.encodePretty v)+              ]+      Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws+      Left err      -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err+++-- | Test that non-matching alternatives pass through unchanged+otherAlternativeUnchangedTest :: Assertion+otherAlternativeUnchangedTest = do+    -- Verify start data matches start schema+    case dataMatchesAPI rootName startTypeSwapSchema startOtherAltData of+        Right () -> return ()+        Left err -> assertFailure $ "Start data does not match start API: "+                                      ++ prettyValueErrorPosition err++    -- Verify expected end data matches end schema+    case dataMatchesAPI rootName endTypeSwapSchema expectedOtherAltData of+        Right () -> return ()+        Left err -> assertFailure $ "Expected end data does not match end API: "+                                      ++ prettyValueErrorPosition err++    -- Run migration - "other" alternative should pass through unchanged+    case migrateDataDump (startTypeSwapSchema, parseVer "0")+                         (endTypeSwapSchema, Release (parseVer "1.0"))+                         typeSwapChangelog typeSwapMigration rootName CheckAll+                         startOtherAltData of+      Right (v, [])+          | expectedOtherAltData == v -> return ()+          | otherwise -> assertFailure $ unlines+              [ "Other alternative was incorrectly modified"+              , "Expected:"+              , BL.unpack (JS.encodePretty expectedOtherAltData)+              , "but got:"+              , BL.unpack (JS.encodePretty v)+              ]+      Right (_, ws) -> assertFailure $ "Unexpected warnings: " ++ show ws+      Left err      -> assertFailure $ "Migration failed: " ++ prettyMigrateFailure err+++rootName :: TypeName+rootName = TypeName "Container"++parseVer :: String -> Version+parseVer s = case simpleParseVersion s of+    Just v -> v+    Nothing -> error $ "Invalid version: " ++ s+++-- | All union migration tests+unionMigrationTests :: TestTree+unionMigrationTests = testGroup "Union Alternative Migration"+  [ testCase "Type swap: PersonV1 -> PersonV2" typeSwapMigrationTest+  , testCase "Other alternatives pass through unchanged" otherAlternativeUnchangedTest+  ]

@@ -0,0 +1,86 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Data for union alternative migration tests+--+-- This module tests the 'alternative changed' changelog feature, which allows+-- swapping the type of a union alternative from one type to a completely+-- different type, with a custom migration function to transform the data.+module Data.API.Test.UnionMigrationData+    ( -- * Type swap scenario (PersonV1 -> PersonV2)+      startTypeSwapSchema+    , endTypeSwapSchema+    , typeSwapChangelog+    ) where++import           Data.API.Changes+import           Data.API.Parse+import           Data.API.Types+++-- -----------------------------------------------------------------------------+-- Type Swap Scenario+--+-- This tests the primary use case: migrating a union alternative from one+-- type (PersonV1) to a completely different type (PersonV2).+--+-- PersonV1 has: name :: string+-- PersonV2 has: fullName :: string, age :: integer+--+-- The migration function transforms PersonV1 data to PersonV2 data.+-- -----------------------------------------------------------------------------++-- | Initial schema with PersonV1+startTypeSwapSchema :: API+startTypeSwapSchema = [api|++personV1Prefix :: PersonV1+    = record+        name :: string++containerPrefix :: Container+    = record+        person :: MyUnion++myUnionPrefix :: MyUnion+    = union+        | person :: PersonV1+        | other  :: integer+|]+++-- | Final schema with PersonV2 and changelog+endTypeSwapSchema :: API+typeSwapChangelog :: APIChangelog+(endTypeSwapSchema, typeSwapChangelog) = [apiWithChangelog|++personV1Prefix :: PersonV1+    = record+        name :: string++personV2Prefix :: PersonV2+    = record+        fullName :: string+        age      :: integer++containerPrefix :: Container+    = record+        person :: MyUnion++myUnionPrefix :: MyUnion+    = union+        | person :: PersonV2+        | other  :: integer++changes++version "1.0"+  // Note: changes are processed bottom-up, so we must list the union change+  // before adding the new type it references+  changed union MyUnion+    alternative changed person :: PersonV2 migration MigratePersonV1ToV2+  added PersonV2 record+    fullName :: string+    age      :: integer++version "0"+|]