diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2022, Iris Connect +Copyright (c) 2013-2026, Iris Connect All rights reserved. diff --git a/api-tools.cabal b/api-tools.cabal --- a/api-tools.cabal +++ b/api-tools.cabal @@ -1,5 +1,5 @@ Name: api-tools -Version: 0.10.1.1 +Version: 0.11.0.0 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the @@ -12,21 +12,16 @@ License-file: LICENSE Author: Chris Dornan and Adam Gundry Maintainer: Adam Gundry -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,22 @@ -*-change-log-*- +0.11.0.0 Adam Gundry August 2026 + * Add support for sets in schemas with @Set T@ syntax. Sets use + 'Data.Set.Set' in generated Haskell types, but are represented as + arrays on the JSON and CBOR wire formats. Set element types must + 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 August 2024 * Relax dependency bounds and support building on GHC 9.4 through to 9.10 diff --git a/main/MigrationTool.hs b/main/MigrationTool.hs --- a/main/MigrationTool.hs +++ b/main/MigrationTool.hs @@ -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)) diff --git a/src/Data/API/API.hs b/src/Data/API/API.hs --- a/src/Data/API/API.hs +++ b/src/Data/API/API.hs @@ -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 diff --git a/src/Data/API/API/DSL.hs b/src/Data/API/API/DSL.hs --- a/src/Data/API/API/DSL.hs +++ b/src/Data/API/API/DSL.hs @@ -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 diff --git a/src/Data/API/API/Gen.hs b/src/Data/API/API/Gen.hs --- a/src/Data/API/API/Gen.hs +++ b/src/Data/API/API/Gen.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains datatypes generated from the DSL description -- of the api-tools API; they thus correspond to the types in diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -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 () diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs --- a/src/Data/API/Changes/Types.hs +++ b/src/Data/API/Changes/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -15,6 +16,8 @@ , 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 diff --git a/src/Data/API/Doc/Types.hs b/src/Data/API/Doc/Types.hs --- a/src/Data/API/Doc/Types.hs +++ b/src/Data/API/Doc/Types.hs @@ -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 diff --git a/src/Data/API/Error.hs b/src/Data/API/Error.hs --- a/src/Data/API/Error.hs +++ b/src/Data/API/Error.hs @@ -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 diff --git a/src/Data/API/JSON.hs b/src/Data/API/JSON.hs --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -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 diff --git a/src/Data/API/JSONToCBOR.hs b/src/Data/API/JSONToCBOR.hs --- a/src/Data/API/JSONToCBOR.hs +++ b/src/Data/API/JSONToCBOR.hs @@ -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 diff --git a/src/Data/API/Markdown.hs b/src/Data/API/Markdown.hs --- a/src/Data/API/Markdown.hs +++ b/src/Data/API/Markdown.hs @@ -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 diff --git a/src/Data/API/NormalForm.hs b/src/Data/API/NormalForm.hs --- a/src/Data/API/NormalForm.hs +++ b/src/Data/API/NormalForm.hs @@ -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 diff --git a/src/Data/API/PP.hs b/src/Data/API/PP.hs --- a/src/Data/API/PP.hs +++ b/src/Data/API/PP.hs @@ -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 diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -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 diff --git a/src/Data/API/Scan.x b/src/Data/API/Scan.x --- a/src/Data/API/Scan.x +++ b/src/Data/API/Scan.x @@ -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 diff --git a/src/Data/API/TH.hs b/src/Data/API/TH.hs --- a/src/Data/API/TH.hs +++ b/src/Data/API/TH.hs @@ -6,6 +6,7 @@ module Data.API.TH ( applicativeE , optionalInstanceD + , optionalStandaloneDerivD , funSigD , simpleD , simpleSigD @@ -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] diff --git a/src/Data/API/Tools.hs b/src/Data/API/Tools.hs --- a/src/Data/API/Tools.hs +++ b/src/Data/API/Tools.hs @@ -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 diff --git a/src/Data/API/Tools/Combinators.hs b/src/Data/API/Tools/Combinators.hs --- a/src/Data/API/Tools/Combinators.hs +++ b/src/Data/API/Tools/Combinators.hs @@ -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' diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -2,7 +2,6 @@ module Data.API.Tools.Datatypes ( datatypesTool , datatypesTool' - , defaultDerivedClasses , type_nm , rep_type_nm , nodeT @@ -10,11 +9,13 @@ , 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 diff --git a/src/Data/API/Tools/DeepSeq.hs b/src/Data/API/Tools/DeepSeq.hs --- a/src/Data/API/Tools/DeepSeq.hs +++ b/src/Data/API/Tools/DeepSeq.hs @@ -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) diff --git a/src/Data/API/Tools/Example.hs b/src/Data/API/Tools/Example.hs --- a/src/Data/API/Tools/Example.hs +++ b/src/Data/API/Tools/Example.hs @@ -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 |] diff --git a/src/Data/API/Tools/JSON.hs b/src/Data/API/Tools/JSON.hs --- a/src/Data/API/Tools/JSON.hs +++ b/src/Data/API/Tools/JSON.hs @@ -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 diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Data.API.Tools.QuickCheck @@ -12,17 +13,32 @@ import Data.API.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 diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -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" diff --git a/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs --- a/src/Data/API/Tutorial.hs +++ b/src/Data/API/Tutorial.hs @@ -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 diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -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 diff --git a/src/Data/API/Value.hs b/src/Data/API/Value.hs --- a/src/Data/API/Value.hs +++ b/src/Data/API/Value.hs @@ -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. diff --git a/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -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 |] diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -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" ]) diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -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 diff --git a/tests/Data/API/Test/Main.hs b/tests/Data/API/Test/Main.hs --- a/tests/Data/API/Test/Main.hs +++ b/tests/Data/API/Test/Main.hs @@ -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 diff --git a/tests/Data/API/Test/Migration.hs b/tests/Data/API/Test/Migration.hs --- a/tests/Data/API/Test/Migration.hs +++ b/tests/Data/API/Test/Migration.hs @@ -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' diff --git a/tests/Data/API/Test/MigrationData.hs b/tests/Data/API/Test/MigrationData.hs --- a/tests/Data/API/Test/MigrationData.hs +++ b/tests/Data/API/Test/MigrationData.hs @@ -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 diff --git a/tests/Data/API/Test/UnionMigration.hs b/tests/Data/API/Test/UnionMigration.hs new file mode 100644 --- /dev/null +++ b/tests/Data/API/Test/UnionMigration.hs @@ -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 + ] diff --git a/tests/Data/API/Test/UnionMigrationData.hs b/tests/Data/API/Test/UnionMigrationData.hs new file mode 100644 --- /dev/null +++ b/tests/Data/API/Test/UnionMigrationData.hs @@ -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" +|]