From 37cab745037d6a318b508bd55f4ae116058e83f6 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 29 Jul 2026 10:13:05 +0200 Subject: [PATCH 1/3] Support set types in API schemas Add TySet with Set T syntax. Generated Haskell types use Data.Set.Set, while JSON and CBOR wire formats remain plain arrays: decoding accepts arrays in any order and drops duplicates, encoding uses the element order of the corresponding Set. This avoids bespoke CBOR set tags and reuses the existing list default value for set-valued fields. --- changelog | 5 +++++ src/Data/API/API.hs | 2 ++ src/Data/API/API/DSL.hs | 1 + src/Data/API/Changes.hs | 7 +++++++ src/Data/API/Changes/Types.hs | 1 + src/Data/API/Doc/Types.hs | 1 + src/Data/API/JSON.hs | 12 ++++++++++++ src/Data/API/JSONToCBOR.hs | 5 +++++ src/Data/API/Markdown.hs | 1 + src/Data/API/NormalForm.hs | 2 ++ src/Data/API/PP.hs | 1 + src/Data/API/Parse.y | 2 ++ src/Data/API/Scan.x | 2 ++ src/Data/API/Tools/Datatypes.hs | 2 ++ src/Data/API/Tools/Example.hs | 4 ++++ src/Data/API/Tools/Traversal.hs | 3 +++ src/Data/API/Tutorial.hs | 16 ++++++++++++---- src/Data/API/Types.hs | 7 ++++++- src/Data/API/Value.hs | 21 +++++++++++++++++++++ tests/Data/API/Test/DSL.hs | 10 ++++++++++ 20 files changed, 100 insertions(+), 5 deletions(-) diff --git a/changelog b/changelog index 085b682..0bfcecc 100644 --- a/changelog +++ b/changelog @@ -1,5 +1,10 @@ -*-change-log-*- +Unreleased + * 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. + 0.10.1.1 Adam Gundry August 2024 * Relax dependency bounds and support building on GHC 9.4 through to 9.10 diff --git a/src/Data/API/API.hs b/src/Data/API/API.hs index fb8a114..331d1b3 100644 --- a/src/Data/API/API.hs +++ b/src/Data/API/API.hs @@ -101,6 +101,7 @@ convert_type :: APIType -> D.APIType 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 :: D.APIType -> APIType 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 index e94fee1..3b54f37 100644 --- a/src/Data/API/API/DSL.hs +++ b/src/Data/API/API/DSL.hs @@ -128,6 +128,7 @@ ty :: APIType // 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/Changes.hs b/src/Data/API/Changes.hs index 2135979..46f008a 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -297,6 +297,7 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $ 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' @@ -586,6 +587,7 @@ updateTypeAt :: Map TypeName UpdateDeclPos -> 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 @@ -701,6 +703,9 @@ updateTypeAt' :: Map TypeName UpdateDeclPos 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 @@ -834,6 +839,7 @@ compatibleDefaultValue api ty dv = isJust (fromDefaultValue api ty dv) -- have access to the entire API. defaultValueForType :: APIType -> Maybe DefaultValue defaultValueForType (TyList _) = Just DefValList +defaultValueForType (TySet _) = Just DefValList defaultValueForType (TyMaybe _) = Just DefValMaybe defaultValueForType _ = Nothing @@ -863,6 +869,7 @@ dataMatchesNormAPI root api db = void $ valueMatches (TyName root) db [] 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)) diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs index ff90068..0844ce9 100644 --- a/src/Data/API/Changes/Types.hs +++ b/src/Data/API/Changes/Types.hs @@ -133,6 +133,7 @@ data UpdateDeclPos -- | Represents the positions in a type to apply an update data UpdateTypePos = UpdateList UpdateTypePos + | UpdateSet UpdateTypePos | UpdateMaybe UpdateTypePos | UpdateNamed TypeName deriving (Eq, Show) diff --git a/src/Data/API/Doc/Types.hs b/src/Data/API/Doc/Types.hs index e142b81..d594f5c 100644 --- a/src/Data/API/Doc/Types.hs +++ b/src/Data/API/Doc/Types.hs @@ -103,6 +103,7 @@ renderBodyType _ (OtherBody s) = s 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/JSON.hs b/src/Data/API/JSON.hs index 269abb1..a310f42 100644 --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -80,6 +80,7 @@ import qualified Data.ByteString.Char8 as B 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 @@ -206,6 +207,17 @@ instance FromJSONWithErrs a => FromJSONWithErrs [a] where 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 parseJSONWithErrs = withInt "Int" pure diff --git a/src/Data/API/JSONToCBOR.hs b/src/Data/API/JSONToCBOR.hs index 0028700..ba01219 100644 --- a/src/Data/API/JSONToCBOR.hs +++ b/src/Data/API/JSONToCBOR.hs @@ -71,6 +71,8 @@ jsonToCBORType napi ty0 v = case (ty0, v) of (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 @@ -158,6 +160,9 @@ 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 Array arr -> case Vec.toList arr of [] -> pure Null diff --git a/src/Data/API/Markdown.hs b/src/Data/API/Markdown.hs index 1809763..003cd46 100644 --- a/src/Data/API/Markdown.hs +++ b/src/Data/API/Markdown.hs @@ -206,6 +206,7 @@ type_md :: MarkdownMethods -> APIType -> MDComment 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 index 00da053..6f7979d 100644 --- a/src/Data/API/NormalForm.hs +++ b/src/Data/API/NormalForm.hs @@ -124,6 +124,7 @@ typeDeclFreeVars (NNewtype _) = Set.empty -- | 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 @@ substTypeDecl _ d@(NNewtype _) = d -- | 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 index 722912b..cc5b491 100644 --- a/src/Data/API/PP.hs +++ b/src/Data/API/PP.hs @@ -62,6 +62,7 @@ instance PP FieldName where 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 index b28b647..2ba187b 100644 --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -40,6 +40,7 @@ import Text.Regex '::' { (,) _ ColCol } '=' { (,) _ Equals } '?' { (,) _ Query } + Set { (,) _ Set } ',' { (,) _ Comma } '<=' { (,) _ LtEq } '>=' { (,) _ GtEq } @@ -187,6 +188,7 @@ RegEx :: { RegEx } Type :: { APIType } Type : '?' Type { TyMaybe $2 } + | Set Type { TySet $2 } | '[' Type ']' { TyList $2 } | TypeName { TyName $1 } | BasicType { TyBasic $1 } diff --git a/src/Data/API/Scan.x b/src/Data/API/Scan.x index 7d73ec7..164044b 100644 --- a/src/Data/API/Scan.x +++ b/src/Data/API/Scan.x @@ -43,6 +43,7 @@ tokens :- "<=" { 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! @@ -108,6 +109,7 @@ data Token | Integer | UTC | Query + | Set | Record | String | Json diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index e1873cb..96404f2 100644 --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -28,6 +28,7 @@ import Data.Aeson 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 @@ -148,6 +149,7 @@ mk_type :: APIType -> Type 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 diff --git a/src/Data/API/Tools/Example.hs b/src/Data/API/Tools/Example.hs index bfeb0a9..87801f2 100644 --- a/src/Data/API/Tools/Example.hs +++ b/src/Data/API/Tools/Example.hs @@ -19,6 +19,7 @@ import Control.Applicative 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 (Maybe a) where 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) diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs index a425230..a0d8f35 100644 --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -81,6 +81,9 @@ traverser napi targets x ty = fromMaybe [| const pure |] $ traverser' napi targe -- 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', so we do not generate traversals +-- into sets. +traverser' _ _ _ (TySet _) = Nothing 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 |] diff --git a/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs index 85c1210..2c0c199 100644 --- a/src/Data/API/Tutorial.hs +++ b/src/Data/API/Tutorial.hs @@ -74,10 +74,11 @@ quasi-quoter, like this: > 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,12 @@ quasi-quoter, like this: 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. The prefix (given before the @::@ on each type declaration) is used to name record fields and enumeration/union constructors in the generated @@ -120,6 +126,7 @@ declarations. Thus @$(generate example)@ will produce something like: > 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 +146,9 @@ defined in one module and imported into another to call 'generate'. 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 diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs index 5da40a3..0ca1549 100644 --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -264,9 +264,13 @@ instance NFData SpecEnum where -- 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. @@ -279,6 +283,7 @@ instance IsString APIType where 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 diff --git a/src/Data/API/Value.hs b/src/Data/API/Value.hs index 2609d60..3160a57 100644 --- a/src/Data/API/Value.hs +++ b/src/Data/API/Value.hs @@ -22,6 +22,7 @@ module Data.API.Value , expectEnum , expectUnion , expectList + , expectSetList , expectMaybe , lookupType @@ -93,6 +94,10 @@ data Value = String !T.Text | 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. + | SetList ![Value] | Maybe !(Maybe Value) | Union !FieldName !Value | Enum !FieldName @@ -120,6 +125,7 @@ instance NFData Value where 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 +143,7 @@ instance NFData Field where 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 +179,7 @@ instance JS.ToJSON Value where 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 +199,9 @@ parseJSON api ty0 v = case ty0 of 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 +242,7 @@ encode v0 = case v0 of 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 +258,7 @@ decode :: NormAPI -> APIType -> CBOR.Decoder s Value 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 +302,9 @@ matchesNormAPI api ty0 v0 p = case ty0 of 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 +367,10 @@ expectList :: Value -> Position -> Either (ValueError, Position) [Value] 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) @@ -374,6 +394,7 @@ arbitraryOfType :: NormAPI -> APIType -> QC.Gen Value 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)] diff --git a/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs index c366f04..883527b 100644 --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -24,6 +24,10 @@ example = map ThNode [ (,) "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 @@ bb :: BasicBinary 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 From 47de6e2dee71b48f64bbe1ed693e98c916557860 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 29 Jul 2026 10:53:44 +0200 Subject: [PATCH 2/3] Fix set support gaps: traversals, lexer keywords, migration tests Follow-up to "Support set types in API schemas", addressing gaps found while reviewing that change against Adam's review of #79. * Generated traversals now descend into set-valued fields. Previously traverser' returned Nothing for TySet, so traverser fell back to `const pure` and generated traversals silently skipped sets: values of the traversed type nested inside a `Set T` field were never visited. Data.Set.Set is not Traversable (its element type is constrained by Ord), but we can traverse via the element list, so add traverseSet and use it. Note this may shrink the set if the function maps distinct elements to the same value. * Add "Set" to Data.API.Scan.keywords, as the N.B. in Scan.x requires for any new keyword. * Cover TySet in the migration tests. UpdateSet, expectSetList and the implicit set default were previously untested: - Foo gains `ens :: Set AnEnum` in the start and end schemas, so the 2.1 AnEnum alternative rename migrates through a set, in both the JSON and the generic Value paths. - version 2.6 gains `field added noset :: Set string`, exercising defaultValueForType at TySet. * Add a test that the generated traversal visits set elements. * Document that set element types need Ord, and that records and unions do not derive it by default, so a set of such a type requires datatypesTool' (or the defaultDerivedClasses setting). * Note in the changelog that Set is now a reserved word, so a type previously called Set must be written 'Set'. Co-Authored-By: Claude Opus 5 (1M context) --- changelog | 7 ++++++- src/Data/API/Scan.x | 2 +- src/Data/API/Tools/Traversal.hs | 15 ++++++++++++--- src/Data/API/Tutorial.hs | 6 +++++- tests/Data/API/Test/Gen.hs | 4 ++++ tests/Data/API/Test/JSON.hs | 13 +++++++++++++ tests/Data/API/Test/MigrationData.hs | 8 ++++++-- 7 files changed, 47 insertions(+), 8 deletions(-) diff --git a/changelog b/changelog index 0bfcecc..6df80da 100644 --- a/changelog +++ b/changelog @@ -3,7 +3,12 @@ Unreleased * 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. + 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). 0.10.1.1 Adam Gundry August 2024 * Relax dependency bounds and support building on GHC 9.4 through to 9.10 diff --git a/src/Data/API/Scan.x b/src/Data/API/Scan.x index 164044b..58fc1f6 100644 --- a/src/Data/API/Scan.x +++ b/src/Data/API/Scan.x @@ -88,7 +88,7 @@ keywords = [ "version", "with", "integer", "boolean", "utc", "string" , "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) diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs index a0d8f35..2b05c2d 100644 --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -5,6 +5,7 @@ module Data.API.Tools.Traversal ( traversalTool , traversalsTool + , traverseSet ) where import Data.API.NormalForm @@ -73,6 +74,12 @@ traversalType x an = [t| forall f . Applicative f => ($x' -> f $x') -> $ty -> f 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,9 +88,11 @@ traverser napi targets x ty = fromMaybe [| const pure |] $ traverser' napi targe -- 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', so we do not generate traversals --- into sets. -traverser' _ _ _ (TySet _) = Nothing +-- '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 |] diff --git a/src/Data/API/Tutorial.hs b/src/Data/API/Tutorial.hs index 2c0c199..efca926 100644 --- a/src/Data/API/Tutorial.hs +++ b/src/Data/API/Tutorial.hs @@ -109,7 +109,11 @@ 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. +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 diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs index 8cefbb6..cd741bd 100644 --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -14,6 +14,7 @@ import Data.API.Time 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 @@ -145,4 +146,7 @@ $(generateAPIToolsWith (defaultToolSettings { newtypeSmartConstructors = True }) , 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 index 4280aca..fc9dfad 100644 --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -20,7 +20,9 @@ import Data.API.Types 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 @@ -159,8 +161,19 @@ jsonTests = testGroup "JSON" , 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/MigrationData.hs b/tests/Data/API/Test/MigrationData.hs index 0c54c73..11365cf 100644 --- a/tests/Data/API/Test/MigrationData.hs +++ b/tests/Data/API/Test/MigrationData.hs @@ -57,6 +57,7 @@ fooPrefix :: Foo id :: Id nest :: Nested en :: AnEnum + ens :: Set AnEnum un :: AUnion quux :: ? IdId @@ -125,10 +126,12 @@ fooPrefix :: Foo 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 @@ version "2.6" 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 @@ version "0.1" 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 From 9c69f49883b3517323a55d4f22b5bf6635c6bb77 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 29 Jul 2026 10:59:47 +0200 Subject: [PATCH 3/3] Test that sets decode from arrays, not objects Adam's review of #79 asked for the JSON representation of a set to be simply the list of its elements, order-insensitive when decoding. That is what the FromJSONWithErrs instance now does, but nothing asserted it: add decoding cases covering an out-of-order array with a duplicate element, and an object being rejected (the shape the original branch accepted via jsonParseCborSet). Co-Authored-By: Claude Opus 5 (1M context) --- tests/Data/API/Test/JSON.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs index fc9dfad..2337822 100644 --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -54,6 +54,15 @@ basicValueDecoding = sequence_ [ help (JS.String "12") (12 :: Int) True , 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