WIP support sets (well, kinda of)

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
@@ -120,6 +121,7 @@ convert_basic bt =
 
 convert_default :: DefaultValue -> D.DefaultValue
 convert_default DefValList       = D.DV_list    0
+convert_default DefValSet        = D.DV_set     0
 convert_default DefValMaybe      = D.DV_maybe   0
 convert_default (DefValString s) = D.DV_string  s
 convert_default (DefValBool   b) = D.DV_boolean b
@@ -201,6 +203,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
@@ -220,6 +223,7 @@ unconvert_basic bt =
 
 unconvert_default :: D.DefaultValue -> DefaultValue
 unconvert_default (D.DV_list    _) = DefValList
+unconvert_default (D.DV_set     _) = DefValSet
 unconvert_default (D.DV_maybe   _) = DefValMaybe
 unconvert_default (D.DV_string  s) = DefValString s
 unconvert_default (D.DV_boolean b) = DefValBool   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 JSON set-like of the given type (ordering not guaranteed)
       | 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
@@ -152,6 +153,7 @@ dv :: DefaultValue
     // a default value
     = union
         | 'list'    :: integer
+        | 'set'     :: integer
         | 'maybe'   :: integer
         | 'string'  :: string
         | 'boolean' :: boolean

src/Data/API/Changes.hs

@@ -290,6 +290,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'
@@ -571,6 +572,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
@@ -679,6 +681,10 @@ 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 <- expectSet v p
+    Set . Set.fromDistinctAscList <$!>
+      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
@@ -806,6 +812,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 DefValSet
 defaultValueForType (TyMaybe _) = Just DefValMaybe
 defaultValueForType _           = Nothing
 
@@ -835,6 +842,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

@@ -129,6 +129,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   ) = "{" ++ 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/Error.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DefaultSignatures          #-}
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE TemplateHaskell            #-}
 
 module Data.API.Error
@@ -18,6 +20,7 @@ module Data.API.Error
 
       -- * JSON parse error construction
     , expectedArray
+    , expectedSet
     , expectedBool
     , expectedInt
     , expectedObject
@@ -56,7 +59,6 @@ import qualified Data.Set                       as Set
 import qualified Data.Text                      as T
 import           Data.Time
 
-
 ----------------------------------------------------------
 -- Representation of JSON parsing errors and positions
 --
@@ -92,13 +94,14 @@ data FormatExpected = FmtBinary
                     | FmtOther
   deriving (Eq, Show)
 
-expectedArray, expectedBool, expectedInt, expectedObject, expectedString
+expectedArray, expectedSet, expectedBool, expectedInt, expectedObject, expectedString
   :: JS.Value -> JSONError
 expectedArray  = Expected ExpArray    "Array"
 expectedBool   = Expected ExpBool     "Bool"
 expectedInt    = Expected ExpInt      "Int"
 expectedObject = Expected ExpObject   "Object"
 expectedString = Expected ExpString   "String"
+expectedSet    = Expected ExpObject   "Set"
 
 badFormat :: String -> T.Text -> JSONError
 badFormat = BadFormat FmtOther

src/Data/API/JSON.hs

@@ -76,10 +76,12 @@ import qualified Data.Aeson                     as JS
 import qualified Data.Aeson.Parser              as JS
 import qualified Data.Aeson.Types               as JS
 import           Data.Attoparsec.ByteString
+import           Data.Binary.Serialise.CBOR.JSON
 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 +208,15 @@ instance FromJSONWithErrs a => FromJSONWithErrs [a] where
   parseJSONWithErrs JS.Null      = pure []
   parseJSONWithErrs v            = failWith $ expectedArray v
 
+instance (Ord a, FromJSONWithErrs a) => FromJSONWithErrs (Set.Set a) where
+  parseJSONWithErrs v@(JS.Object kvs) = case jsonParseCborSet kvs of
+    Nothing -> failWith $ expectedSet v
+    Just xs -> fmap Set.fromList <$> traverse help $ zip (V.toList xs) [0..]
+    where
+      help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x
+  parseJSONWithErrs JS.Null      = pure mempty
+  parseJSONWithErrs v            = failWith $ expectedArray v
+
 instance FromJSONWithErrs Int where
   parseJSONWithErrs = withInt "Int" pure
 

src/Data/API/JSONToCBOR.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Data.API.JSONToCBOR
     ( serialiseJSONWithSchema
     , jsonToCBORWithSchema
@@ -13,6 +14,7 @@ import           Data.API.JSON.Compat
 import           Data.API.Time
 import           Data.API.Types
 import           Data.API.Utils
+import           Data.Binary.Serialise.CBOR.Extra
 
 import           Control.Applicative
 import           Data.Aeson hiding (encode)
@@ -32,7 +34,6 @@ import           Data.Time.Clock.POSIX
 import           Data.Time (UTCTime(UTCTime))
 import           Prelude
 
-
 -- | Serialise a JSON value as a CBOR term in a generic but
 -- schema-dependent fashion.  This is necessary because the JSON
 -- representation carries less information than we need in CBOR
@@ -70,6 +71,9 @@ jsonToCBORType :: NormAPI -> APIType -> Value -> Term
 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)
+    (TySet  ty, Array arr)  | Vec.null arr -> TSetI $ []
+                            | otherwise    -> TSetI $ map (jsonToCBORType napi ty) (Vec.toList arr)
+    (TySet  _, _)           -> error "serialiseJSONWithSchema: TySet, expected array"
     (TyList  _ , _)         -> error "serialiseJSONWithSchema: expected array"
     (TyMaybe _ , Null)      -> TList []
     (TyMaybe ty, _)         -> TList [jsonToCBORType napi ty v]
@@ -158,6 +162,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

@@ -196,6 +196,7 @@ default_value :: DefaultValue -> MDComment
 default_value dv =
     case dv of
       DefValList     -> "[]"
+      DefValSet      -> "{}"
       DefValMaybe    -> "null"
       DefValString t -> show t
       DefValBool   b -> map toLower $ show b
@@ -206,6 +207,7 @@ type_md :: MarkdownMethods -> APIType -> MDComment
 type_md mdm ty =
     case ty of
       TyList  ty'  -> "[" ++ type_md mdm ty' ++ "]"
+      TySet   ty'  -> "{" ++ 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)  = "{" ++ pp ty ++ "}"
   pp (TyMaybe ty) = "? " ++ pp ty
   pp (TyName  t)  = pp t
   pp (TyBasic b)  = pp b
@@ -76,6 +77,7 @@ instance PP BasicType where
 
 instance PP DefaultValue where
   pp DefValList           = "[]"
+  pp DefValSet            = "{}"
   pp DefValMaybe          = "nothing"
   pp (DefValString t)     = show t
   pp (DefValBool   True)  = "true"

src/Data/API/Parse.y

@@ -37,6 +37,8 @@ import           Text.Regex
     '|'                                 { (,) _ Bar             }
     '['                                 { (,) _ Bra             }
     ']'                                 { (,) _ Ket             }
+    '{'                                 { (,) _ Cu              }
+    '}'                                 { (,) _ Rly             }
     '::'                                { (,) _ ColCol          }
     '='                                 { (,) _ Equals          }
     '?'                                 { (,) _ Query           }
@@ -188,6 +190,7 @@ Type :: { APIType }
 Type
     : '?' Type                          { TyMaybe            $2             }
     | '[' Type ']'                      { TyList             $2             }
+    | '{' Type '}'                      { TySet              $2             }
     | TypeName                          { TyName             $1             }
     | BasicType                         { TyBasic            $1             }
     | json                              { TyJSON                            }
@@ -265,6 +268,7 @@ MbDefaultValue :: { Maybe DefaultValue }
 
 DefaultValue :: { DefaultValue }
     : '[' ']'                          { DefValList                         }
+    | '{' '}'                          { DefValSet                          }
     | nothing                          { DefValMaybe                        }
     | strlit                           { DefValString (T.pack $1)           }
     | true                             { DefValBool True                    }

src/Data/API/Scan.x

@@ -37,6 +37,8 @@ tokens :-
     "|"                                 { simple    Bar             }
     "["                                 { simple    Bra             }
     "]"                                 { simple    Ket             }
+    "{"                                 { simple    Cu              }
+    "}"                                 { simple    Rly             }
     "::"                                { simple    ColCol          }
     ":"                                 { simple    Colon           }
     "="                                 { simple    Equals          }
@@ -98,6 +100,8 @@ data Token
     | BInary
     | Bra
     | Ket
+    | Cu
+    | Rly
     | ColCol
     | Colon
     | Comma

src/Data/API/Tools/Datatypes.hs

@@ -27,6 +27,7 @@ import qualified Data.CaseInsensitive           as CI
 import           Data.Char
 import           Data.Maybe
 import           Data.String
+import           Data.Set                       (Set)
 import qualified Data.Text                      as T
 import           Data.Time
 import           Data.Typeable
@@ -147,6 +148,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

@@ -22,6 +22,7 @@ import           Data.Monoid
 import           Data.Time
 import           Language.Haskell.TH
 import           Test.QuickCheck                as QC
+import qualified Data.Set                       as Set
 import qualified Data.Text                      as T
 import           Prelude
 
@@ -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

@@ -75,6 +75,7 @@ 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
+traverser' napi targets x (TySet ty)   = fmap (appE [e|(.) traverse|]) $ 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 |]