Support sets

changelog

@@ -1,5 +1,15 @@
 -*-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.  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 <adam@well-typed.com> August 2024
 	* Relax dependency bounds and support building on GHC 9.4 through to 9.10
 

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

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

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

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)

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

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
 

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

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

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

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

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             }

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!
@@ -87,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)
@@ -108,6 +109,7 @@ data Token
     | Integer
     | UTC
     | Query
+    | Set
     | Record
     | String
     | Json

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

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)
 

src/Data/API/Tools/Traversal.hs

@@ -37,6 +37,11 @@ import           Prelude
 -- 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]
 
@@ -73,6 +78,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,6 +92,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' (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 |]

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,16 @@ 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.  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 @@ 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 +150,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

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