aeson-schemas 1.0.3 → 1.1.0

raw patch · 29 files changed

+546/−82 lines, 29 filesdep +QuickCheckdep +tasty-hunitdep +tasty-quickcheckdep ~aesondep ~tastydep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-hunit, tasty-quickcheck

Dependency ranges changed: aeson, tasty, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• aeson-schemas.cabal +23/−7
• src/Data/Aeson/Schema/Internal.hs +39/−16
• src/Data/Aeson/Schema/Show.hs +6/−1
• src/Data/Aeson/Schema/TH.hs +1/−0
• src/Data/Aeson/Schema/TH/Enum.hs +65/−22
• src/Data/Aeson/Schema/TH/Get.hs +18/−6
• src/Data/Aeson/Schema/TH/Parse.hs +20/−9
• src/Data/Aeson/Schema/TH/Schema.hs +10/−3
• src/Data/Aeson/Schema/TH/Unwrap.hs +2/−0
• src/Data/Aeson/Schema/TH/Utils.hs +36/−16
• src/Data/Aeson/Schema/Utils/Sum.hs +130/−0
• src/Data/Aeson/Schema/Utils/TypeFamilies.hs +23/−0
• test/AllTypes.hs +3/−0
• test/Enums.hs +13/−0
• test/Main.hs +127/−0
• test/SumType.hs +7/−0
• test/all_types.json +6/−0
• test/goldens/get_empty.golden +1/−1
• test/goldens/get_just_start.golden +1/−1
• test/goldens/schema_def_union.golden +1/−0
• test/goldens/schema_def_union_grouped.golden +1/−0
• test/goldens/union.golden +1/−0
• test/goldens/union_0.golden +1/−0
• test/goldens/union_0_a.golden +1/−0
• test/goldens/union_1.golden +1/−0
• test/goldens/union_2.golden +1/−0
• test/goldens/unwrap_schema_bad_branch.golden +1/−0
• test/goldens/unwrap_schema_branch_out_of_bounds.golden +1/−0

@@ -1,5 +1,11 @@ ## Upcoming +## 1.1.0++New features:+    * Added support for unions+    * Added `ToJSON` instance for enums generated with `mkEnum`+ ## 1.0.3  Support GHC 8.8

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c2bdf380b742a87fa9d09969246278d74fefaa1c713dc1b131df3e2016de3fa0+-- hash: 79cd47bc31fb343c075854b35187f50f082ad4bc23f5bc14a9e514cc8633c9f2  name:           aeson-schemas-version:        1.0.3+version:        1.1.0 synopsis:       Easily consume JSON data on-demand with type-safety description:    Parse JSON data easily and safely without defining new data types. Useful                 for deeply nested JSON data, which is difficult to parse using the default@@ -82,13 +82,22 @@     test/goldens/schema_def_obj.golden     test/goldens/schema_def_shadow.golden     test/goldens/schema_def_text.golden+    test/goldens/schema_def_union.golden+    test/goldens/schema_def_union_grouped.golden     test/goldens/schema_def_unknown_type.golden     test/goldens/text.golden+    test/goldens/union.golden+    test/goldens/union_0.golden+    test/goldens/union_0_a.golden+    test/goldens/union_1.golden+    test/goldens/union_2.golden     test/goldens/unwrap_schema.golden     test/goldens/unwrap_schema_bad_bang.golden+    test/goldens/unwrap_schema_bad_branch.golden     test/goldens/unwrap_schema_bad_key.golden     test/goldens/unwrap_schema_bad_list.golden     test/goldens/unwrap_schema_bad_question.golden+    test/goldens/unwrap_schema_branch_out_of_bounds.golden     test/goldens/unwrap_schema_nested_list.golden     test/goldens/unwrap_schema_nested_object.golden @@ -102,6 +111,8 @@       Data.Aeson.Schema.Internal       Data.Aeson.Schema.Show       Data.Aeson.Schema.TH+      Data.Aeson.Schema.Utils.Sum+      Data.Aeson.Schema.Utils.TypeFamilies   other-modules:       Data.Aeson.Schema.TH.Enum       Data.Aeson.Schema.TH.Get@@ -117,8 +128,8 @@       aeson >=1.1.2.0 && <1.5     , base >=4.9 && <5     , bytestring >=0.10.8.1 && <0.11-    , first-class-families >=0.3.0.0 && <0.6.1-    , megaparsec >=6.0.0 && <7.1+    , first-class-families >=0.3.0.0 && <0.9+    , megaparsec >=6.0.0 && <9     , template-haskell >=2.12.0.0 && <2.16     , text >=1.2.2.2 && <1.3     , unordered-containers >=0.2.8.0 && <0.3@@ -133,23 +144,28 @@   main-is: Main.hs   other-modules:       AllTypes+      Enums       Nested       Schema+      SumType       Util       Paths_aeson_schemas   hs-source-dirs:       test   ghc-options: -Wall   build-depends:-      aeson >=1.1.2.0 && <1.5+      QuickCheck >=2.7 && <3+    , aeson >=1.1.2.0 && <1.5     , aeson-schemas     , base >=4.9 && <5     , bytestring >=0.10.8.1 && <0.11-    , first-class-families >=0.3.0.0 && <0.6.1-    , megaparsec >=6.0.0 && <7.1+    , first-class-families >=0.3.0.0 && <0.9+    , megaparsec >=6.0.0 && <9     , raw-strings-qq >=1.1 && <1.2     , tasty >=0.11.3 && <1.3     , tasty-golden >=2.3.1.2 && <2.4+    , tasty-hunit >=0.9 && <0.11+    , tasty-quickcheck >=0.9 && <0.11     , template-haskell >=2.12.0.0 && <2.16     , text >=1.2.2.2 && <1.3     , th-test-utils >=1.0.0 && <1.1

@@ -44,12 +44,14 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable, splitTyConApp, tyConName, typeRep, typeRepTyCon)-import Fcf (type (<=<), type (=<<), Eval, Find, FromMaybe, Fst, Snd, TyEq)+import Fcf (type (=<<), Eval, FromMaybe, Lookup) import GHC.Exts (toList) import GHC.TypeLits     (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)  import qualified Data.Aeson.Schema.Show as SchemaShow+import Data.Aeson.Schema.Utils.Sum (SumType)+import Data.Aeson.Schema.Utils.TypeFamilies (All)  {- Schema-validated JSON object -} @@ -83,6 +85,7 @@   | SchemaMaybe SchemaType   | SchemaList SchemaType   | SchemaObject [(Symbol, SchemaType)]+  | SchemaUnion [SchemaType] -- ^ @since v1.1.0  -- | Convert 'SchemaType' into 'SchemaShow.SchemaType'. toSchemaTypeShow :: forall (a :: SchemaType). Typeable a => SchemaShow.SchemaType@@ -96,16 +99,24 @@       ("'SchemaCustom", [inner]) -> SchemaShow.SchemaCustom $ typeRepName inner       ("'SchemaMaybe", [inner]) -> SchemaShow.SchemaMaybe $ cast inner       ("'SchemaList", [inner]) -> SchemaShow.SchemaList $ cast inner-      ("'SchemaObject", [pairs]) -> SchemaShow.SchemaObject $ getSchemaObjectPairs pairs+      ("'SchemaObject", [pairs]) -> SchemaShow.SchemaObject $ map getSchemaObjectPair $ typeRepToList pairs+      ("'SchemaUnion", [schemas]) -> SchemaShow.SchemaUnion $ map cast $ typeRepToList schemas       _ -> error $ "Unknown schema type: " ++ show tyRep-    getSchemaObjectPairs tyRep = case splitTypeRep tyRep of++    getSchemaObjectPair tyRep =+      let (key, val) = typeRepToPair tyRep+          key' = tail . init . typeRepName $ key -- strip leading + trailing quote+      in (key', cast val)++    typeRepToPair tyRep = case splitTypeRep tyRep of+      ("'(,)", [a, b]) -> (a, b)+      _ -> error $ "Unknown pair: " ++ show tyRep++    typeRepToList tyRep = case splitTypeRep tyRep of       ("'[]", []) -> []-      ("':", [x, rest]) -> case splitTypeRep x of-        ("'(,)", [key, val]) ->-          let key' = tail . init . typeRepName $ key -- strip leading + trailing quote-          in (key', cast val) : getSchemaObjectPairs rest-        _ -> error $ "Unknown pair: " ++ show x+      ("':", [x, rest]) -> x : typeRepToList rest       _ -> error $ "Unknown list: " ++ show tyRep+     splitTypeRep = first tyConName . splitTyConApp     typeRepName = tyConName . typeRepTyCon @@ -125,7 +136,12 @@   SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner)   SchemaResult ('SchemaList inner) = [SchemaResult inner]   SchemaResult ('SchemaObject inner) = Object ('SchemaObject inner)+  SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas) +type family SchemaResultList (xs :: [SchemaType]) where+  SchemaResultList '[] = '[]+  SchemaResultList (x ': xs) = SchemaResult x ': SchemaResultList xs+ -- | A type-class for types that can be parsed from JSON for an associated schema type. class Typeable schema => IsSchemaType (schema :: SchemaType) where   parseValue :: [Text] -> Value -> Parser (SchemaResult schema)@@ -193,6 +209,13 @@         in maybe (show dynValue) show $ fromDynamic @(SchemaResult inner) dynValue       pair = "\"" ++ key ++ "\": " ++ value +instance+  ( All IsSchemaType schemas+  , Typeable schemas+  , Show (SchemaResult ('SchemaUnion schemas))+  , FromJSON (SchemaResult ('SchemaUnion schemas))+  ) => IsSchemaType ('SchemaUnion schemas)+ -- | A helper for creating fail messages when parsing a schema. parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, Typeable schema) => [Text] -> Value -> m a parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value)@@ -209,14 +232,14 @@ -- | The type-level function that return the schema of the given key in a 'SchemaObject'. type family LookupSchema (key :: Symbol) (schema :: SchemaType) :: SchemaType where   LookupSchema key ('SchemaObject schema) = Eval-    ( Snd-    =<< FromMaybe (TypeError-      (     'Text "Key '"-      ':<>: 'Text key-      ':<>: 'Text "' does not exist in the following schema:"-      ':$$: 'ShowType schema-      ))-    =<< Find (TyEq key <=< Fst) schema+    ( FromMaybe (TypeError+        (     'Text "Key '"+        ':<>: 'Text key+        ':<>: 'Text "' does not exist in the following schema:"+        ':$$: 'ShowType schema+        )+      )+      =<< Lookup key schema     )   LookupSchema key schema = TypeError     (     'Text "Attempted to lookup key '"

@@ -25,6 +25,7 @@   | SchemaMaybe SchemaType   | SchemaList SchemaType   | SchemaObject [(String, SchemaType)]+  | SchemaUnion [SchemaType]   deriving (Show)  -- | Pretty show the given SchemaType.@@ -38,6 +39,7 @@   SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaType' inner   SchemaList inner -> "SchemaList " ++ showSchemaType' inner   SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema+  SchemaUnion _ -> "SchemaUnion " ++ showSchemaType' schema   where     showSchemaType' = \case       SchemaBool -> "Bool"@@ -47,5 +49,8 @@       SchemaCustom s -> s       SchemaMaybe inner -> "Maybe " ++ showSchemaType' inner       SchemaList inner -> "List " ++ showSchemaType' inner-      SchemaObject pairs -> "{" ++ intercalate ", " (map showPair pairs) ++ "}"+      SchemaObject pairs -> "{" ++ mapJoin showPair ", " pairs ++ "}"+      SchemaUnion schemas -> "( " ++ mapJoin showSchemaType' " | " schemas ++ " )"     showPair (key, inner) = "\"" ++ key ++ "\": " ++ showSchemaType' inner++    mapJoin f delim = intercalate delim . map f

@@ -30,6 +30,7 @@   -- * Helpers for Enum types   , mkEnum   , genFromJSONEnum+  , genToJSONEnum   ) where  import Data.Aeson.Schema.TH.Enum

@@ -11,15 +11,17 @@  module Data.Aeson.Schema.TH.Enum   ( genFromJSONEnum+  , genToJSONEnum   , mkEnum   ) where  import Control.Monad (forM, unless)-import Data.Aeson (FromJSON(..), Value(..))+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..)) import Data.Char (toLower) import Data.Maybe (mapMaybe) import qualified Data.Text as Text import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)  -- | Make an enum type with the given constructors, that can be parsed from JSON. --@@ -27,18 +29,19 @@ -- case-insensitive. -- -- @--- mkEnum "State" ["OPEN", "CLOSED"]+-- mkEnum \"State" [\"OPEN", \"CLOSED"] ----- main = print---   [ decode \"open" :: Maybe State---   , decode \"OPEN" :: Maybe State---   , decode \"closed" :: Maybe State---   , decode \"CLOSED" :: Maybe State---   ]+-- -- generates equivalent of:+-- --   data State = OPEN | CLOSED deriving (...)+-- --   genFromJSONEnum ''State+-- --   genToJSONEnum ''State -- @ mkEnum :: String -> [String] -> Q [Dec]-mkEnum name vals = do-  (:) <$> dataDec <*> mkFromJSON name' vals'+mkEnum name vals = concat <$> sequence+  [ (:[]) <$> dataDec+  , mkFromJSON name' vals'+  , mkToJSON name' vals'+  ]   where     name' = mkName name     vals' = map mkName vals@@ -60,18 +63,53 @@ -- case-insensitive. -- -- @--- data State = OPEN | CLOSED deriving (Show,Enum)+-- data State = Open | CLOSED deriving (Show,Enum) -- genFromJSONEnum ''State ----- main = print---   [ decode \"open" :: Maybe State---   , decode \"OPEN" :: Maybe State---   , decode \"closed" :: Maybe State---   , decode \"CLOSED" :: Maybe State+-- -- outputs:+-- --   Just Open+-- --   Just Open+-- --   Just CLOSED+-- --   Just CLOSED+-- main = mapM_ print+--   [ decodeState \"open"+--   , decodeState \"OPEN"+--   , decodeState \"closed"+--   , decodeState \"CLOSED" --   ]+--   where+--     decodeState :: String -> Maybe State+--     decodeState = decode . show -- @ genFromJSONEnum :: Name -> Q [Dec]-genFromJSONEnum name = do+genFromJSONEnum name = getEnumConstructors name >>= mkFromJSON name++-- | Generate an instance of 'ToJSON' for the given data type.+--+-- Prefer using 'mkEnum'; this function is useful for data types in which you want greater control+-- over the actual data type.+--+-- The 'ToJSON' instance will encode the enum as a string matching the constructor name.+--+-- @+-- data State = Open | CLOSED deriving (Show,Enum)+-- genToJSONEnum ''State+--+-- -- outputs:+-- --   \"Open"+-- --   \"CLOSED"+-- main = mapM_ print+--   [ encode Open+--   , encode CLOSED+--   ]+-- @+genToJSONEnum :: Name -> Q [Dec]+genToJSONEnum name = getEnumConstructors name >>= mkToJSON name++{- Helpers -}++getEnumConstructors :: Name -> Q [Name]+getEnumConstructors name = do   -- check if 'name' is an Enum   ClassI _ instances <- reify ''Enum   let instanceNames = flip mapMaybe instances $ \case@@ -80,16 +118,12 @@   unless (name `elem` instanceNames) $ fail $ "Not an Enum type: " ++ show name    -- extract constructor names-  cons <- reify name >>= \case+  reify name >>= \case     TyConI (DataD _ _ _ _ cons _) -> forM cons $ \case       NormalC con [] -> return con       con -> fail $ "Invalid constructor: " ++ show con     info -> fail $ "Invalid data type: " ++ show info -  mkFromJSON name cons--{- Helpers -}- mkFromJSON :: Name -> [Name] -> Q [Dec] mkFromJSON name cons = do   let toPattern = litP . stringL . map toLower . nameBase@@ -108,3 +142,12 @@     badParse =       let prefix = litE $ stringL $ "Bad " ++ nameBase name ++ ": "       in [| fail . ($prefix ++) . show |]++mkToJSON :: Name -> [Name] -> Q [Dec]+mkToJSON name cons =+  [d|+    instance ToJSON $(conT name) where+      toJSON = $(lamCaseE $ map encodeConstructor cons)+    |]+  where+    encodeConstructor con = match (conP con []) (normalB [| String $ Text.pack $(lift $ nameBase con) |]) []

@@ -15,6 +15,7 @@  import Control.Monad (unless, (>=>)) import qualified Data.Maybe as Maybe+import Data.Proxy (Proxy(..)) import GHC.Stack (HasCallStack) import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..))@@ -23,6 +24,7 @@ import Data.Aeson.Schema.Internal (getKey) import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse) import Data.Aeson.Schema.TH.Utils (GetterOperation(..), showGetterOps)+import Data.Aeson.Schema.Utils.Sum (fromSumType)  -- | Defines a QuasiQuoter for extracting JSON data. --@@ -69,6 +71,13 @@ --     * @x[]!@ unwraps all 'Just' values in @x@ (and errors if any 'Nothing' values exist in @x@) -- -- * @x?@ follows the same rules as @x[]@ except it's only valid if @x@ is a 'Maybe'.+--+-- * @x\@#@ is only valid if @x@ is a 'SumType'. If the sum type contains a value at the given+--   branch (e.g. @x\@0@ for @Here v@), return 'Just' that value, otherwise 'Nothing'. (added in+--   v1.1.0)+--+--   e.g. with the schema @{ a: Int | Bool }@, calling @[get| .a\@0 |]@ will return @Maybe Int@ if+--   the sum type contains an 'Int'. get :: QuasiQuoter get = QuasiQuoter   { quoteExp = parse getterExp >=> generateGetterExp@@ -102,12 +111,15 @@             checkLast label = unless (null ops) $ fail $ label ++ " operation MUST be last."             fromJustMsg = startDisplay ++ showGetterOps (reverse history)         in case op of-          GetterKey key     -> applyToNext' $ Right $ appTypeE [| getKey |] (litT $ strTyLit key)-          GetterList elems  -> checkLast ".[*]" >> applyToEach' listE elems-          GetterTuple elems -> checkLast ".(*)" >> applyToEach' tupE elems-          GetterBang        -> applyToNext' $ Right [| fromJust $(lift fromJustMsg) |]-          GetterMapMaybe    -> applyToNext' $ Left [| (<$?>) |]-          GetterMapList     -> applyToNext' $ Left [| (<$:>) |]+          GetterKey key       -> applyToNext' $ Right $ appTypeE [| getKey |] (litT $ strTyLit key)+          GetterList elems    -> checkLast ".[*]" >> applyToEach' listE elems+          GetterTuple elems   -> checkLast ".(*)" >> applyToEach' tupE elems+          GetterBang          -> applyToNext' $ Right [| fromJust $(lift fromJustMsg) |]+          GetterMapMaybe      -> applyToNext' $ Left [| (<$?>) |]+          GetterMapList       -> applyToNext' $ Left [| (<$:>) |]+          GetterBranch branch ->+            let branchTyLit = litT $ numTyLit $ fromIntegral branch+            in applyToNext' $ Right [| fromSumType (Proxy :: Proxy $branchTyLit) |]  -- | fromJust with helpful error message fromJust :: HasCallStack => String -> Maybe a -> a

@@ -45,6 +45,7 @@   [ lexeme "!" $> GetterBang   , lexeme "[]" $> GetterMapList   , lexeme "?" $> GetterMapMaybe+  , lexeme "@" *> (GetterBranch . read <$> some digitChar)   , optional (lexeme ".") *> choice       [ GetterKey <$> jsonKey       , fmap GetterList $ between (lexeme "[") (lexeme "]") $ some parseGetterOp `sepBy1` lexeme ","@@ -53,14 +54,23 @@   ]  parseSchemaDef :: Parser SchemaDef-parseSchemaDef = choice-  [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems-  , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDef)-  , lexeme "List" *> (SchemaDefList <$> parseSchemaDef)-  , SchemaDefType <$> identifier upperChar-  , SchemaDefInclude <$> parseSchemaReference-  ]+parseSchemaDef = parseSchemaDefWithUnions   where+    parseSchemaDefWithUnions =+      let parseSchemaUnion [] = error "Parsed no schema definitions" -- should not happen; sepBy1 returns one or more+          parseSchemaUnion [schemaDef'] = schemaDef'+          parseSchemaUnion schemaDefs = SchemaDefUnion schemaDefs+      in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|"++    parseSchemaDefWithoutUnions = choice+      [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems+      , between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions+      , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions)+      , lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions)+      , SchemaDefType <$> identifier upperChar+      , SchemaDefInclude <$> parseSchemaReference+      ] <* space -- allow any trailing spaces+     parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme ","     parseSchemaDefObjItem = choice       [ SchemaDefObjPair <$> parseSchemaDefPair@@ -69,7 +79,7 @@     parseSchemaDefPair = do       key <- jsonKey       lexeme ":"-      value <- parseSchemaDef+      value <- parseSchemaDefWithUnions       return (key, value)     parseSchemaReference = char '#' *> namespacedIdentifier upperChar @@ -96,7 +106,7 @@ jsonKey = some $ noneOf $ " " ++ schemaChars ++ getChars   where     -- characters that cause ambiguity when parsing 'get' expressions-    getChars = "!?[](),."+    getChars = "!?[](),.@"     -- characters that should not indicate the start of a key when parsing 'schema' definitions     schemaChars = ":{}#" @@ -108,6 +118,7 @@   | SchemaDefList SchemaDef   | SchemaDefInclude String   | SchemaDefObj [SchemaDefObjItem]+  | SchemaDefUnion [SchemaDef]   deriving (Show)  data SchemaDefObjItem

@@ -17,6 +17,7 @@ module Data.Aeson.Schema.TH.Schema (schema) where  import Control.Monad ((<=<), (>=>))+import Data.Bifunctor (second) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (mapMaybe) import Language.Haskell.TH@@ -24,7 +25,8 @@  import Data.Aeson.Schema.Internal (SchemaType(..)) import Data.Aeson.Schema.TH.Parse-import Data.Aeson.Schema.TH.Utils (fromTypeList, toTypeList)+import Data.Aeson.Schema.TH.Utils+    (schemaPairsToTypeQ, typeQListToTypeQ, typeToSchemaPairs)  -- | Defines a QuasiQuoter for writing schemas. --@@ -60,6 +62,10 @@ -- * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values --   specified by the provided schema (no parentheses needed). --+-- * @\<schema1\> | \<schema2\>@ corresponds to a JSON value that matches one of the given schemas.+--   When extracted from an 'Data.Aeson.Schema.Object', it deserializes into a+--   'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0)+-- -- * Any other uppercase identifier corresponds to the respective type in scope -- requires a --   FromJSON instance. --@@ -79,7 +85,7 @@ generateSchemaObject :: [SchemaDefObjItem] -> TypeQ generateSchemaObject items = [t| 'SchemaObject $(fromItems items) |]   where-    fromItems = toTypeList <=< resolveParts . concat <=< mapM toParts+    fromItems = schemaPairsToTypeQ <=< resolveParts . concat <=< mapM toParts  generateSchema :: SchemaDef -> TypeQ generateSchema = \case@@ -92,6 +98,7 @@   SchemaDefList inner    -> [t| 'SchemaList $(generateSchema inner) |]   SchemaDefInclude other -> getType other   SchemaDefObj items     -> generateSchemaObject items+  SchemaDefUnion schemas -> [t| 'SchemaUnion $(typeQListToTypeQ $ map generateSchema schemas) |]  {- Helpers -} @@ -113,7 +120,7 @@     name <- getName other     reify name >>= \case       TyConI (TySynD _ _ (AppT (PromotedT ty) inner)) | ty == 'SchemaObject ->-        tagAs Imported <$> fromTypeList inner+        pure . tagAs Imported . map (second pure) $ typeToSchemaPairs inner       _ -> fail $ "'" ++ show name ++ "' is not a SchemaObject"   where     tagAs source = map $ \(k,v) -> (k,v,source)

@@ -44,6 +44,8 @@ -- * @x?@ is the same as @x!@. -- -- * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list.+--+-- * @x\@#@ is only valid if @x@ is a @SumType@. Returns the type at that branch in the sum type. unwrap :: QuasiQuoter unwrap = QuasiQuoter   { quoteExp = error "Cannot use `unwrap` for Exp"

@@ -13,7 +13,7 @@ module Data.Aeson.Schema.TH.Utils where  import Control.Monad ((>=>))-import Data.Bifunctor (second)+import Data.Bifunctor (bimap, second) import Data.List (intercalate) import Data.Text (Text) import Language.Haskell.TH@@ -38,31 +38,42 @@         | name == 'SchemaMaybe -> SchemaShow.SchemaMaybe $ fromSchemaType inner         | name == 'SchemaList -> SchemaShow.SchemaList $ fromSchemaType inner         | name == 'SchemaObject -> SchemaShow.SchemaObject $ fromPairs inner+        | name == 'SchemaUnion -> SchemaShow.SchemaUnion $ map fromSchemaType $ typeToList inner       ty -> error $ "Unknown type: " ++ show ty-    fromPairs pairs = map (second fromSchemaType) $ fromTypeList' pairs -fromTypeList' :: Type -> [(String, Type)]-fromTypeList' = \case+    fromPairs pairs = map (second fromSchemaType) $ typeToSchemaPairs pairs++typeToList :: Type -> [Type]+typeToList = \case   PromotedNilT -> []-  AppT (AppT PromotedConsT x) xs -> fromTypeTuple x : fromTypeList' xs-  SigT ty _ -> fromTypeList' ty+  AppT (AppT PromotedConsT x) xs -> x : typeToList xs+  SigT ty _ -> typeToList ty   ty -> error $ "Not a type-level list: " ++ show ty-  where-    fromTypeTuple = \case-      AppT (AppT (PromotedTupleT 2) (LitT (StrTyLit k))) v -> (k, stripSigs v)-      SigT ty _ -> fromTypeTuple ty-      x -> error $ "Not a type-level tuple: " ++ show x -fromTypeList :: Type -> Q [(String, TypeQ)]-fromTypeList = pure . map (second pure) . fromTypeList'+typeToPair :: Type -> (Type, Type)+typeToPair = \case+  AppT (AppT (PromotedTupleT 2) a) b -> (a, b)+  SigT ty _ -> typeToPair ty+  ty -> error $ "Not a type-level pair: " ++ show ty -toTypeList :: [(String, TypeQ)] -> TypeQ-toTypeList = foldr (consT . pairT) promotedNilT+typeToSchemaPairs :: Type -> [(String, Type)]+typeToSchemaPairs = map (bimap toTypeStr stripSigs . typeToPair) . typeToList   where-    pairT (k, v) = [t| '( $(litT $ strTyLit k), $v) |]+    toTypeStr = \case+      LitT (StrTyLit k) -> k+      x -> error $ "Not a type-level string: " ++ show x++typeQListToTypeQ :: [TypeQ] -> TypeQ+typeQListToTypeQ = foldr consT promotedNilT+  where     -- nb. https://stackoverflow.com/a/34457936     consT x xs = appT (appT promotedConsT x) xs +schemaPairsToTypeQ :: [(String, TypeQ)] -> TypeQ+schemaPairsToTypeQ = typeQListToTypeQ . map pairT+  where+    pairT (k, v) = [t| '( $(litT $ strTyLit k), $v) |]+ -- | Strip all kind signatures from the given type. stripSigs :: Type -> Type stripSigs = \case@@ -92,6 +103,7 @@         | ty == 'SchemaMaybe -> [t| Maybe $(fromSchemaType inner) |]         | ty == 'SchemaList -> [t| [$(fromSchemaType inner)] |]         | ty == 'SchemaObject -> [t| Object $(pure schema) |]+        | ty == 'SchemaUnion -> [t| SchemaResult $(pure schema) |]       PromotedT ty         | ty == 'SchemaBool -> [t| Bool |]         | ty == 'SchemaInt -> [t| Int |]@@ -123,6 +135,12 @@       GetterMapMaybe -> fail $ "Cannot use `?` operator on schema: " ++ showSchemaType schema       GetterMapList | ty == 'SchemaList -> withFunctor (pure ListT) $ unwrapType' ops inner       GetterMapList -> fail $ "Cannot use `[]` operator on schema: " ++ showSchemaType schema+      GetterBranch branch | ty == 'SchemaUnion ->+        let subTypes = typeToList inner+        in if branch >= length subTypes+          then fail $ "Branch out of bounds for schema: " ++ showSchemaType schema+          else unwrapType' ops $ subTypes !! branch+      GetterBranch _ -> fail $ "Cannot use `@` operator on schema: " ++ showSchemaType schema   -- allow starting from (Object schema)   AppT (ConT ty) inner | ty == ''Object -> unwrapType' (op:ops) inner   schema -> fail $ unlines ["Cannot get type:", show schema, show op]@@ -148,6 +166,7 @@   | GetterBang   | GetterMapList   | GetterMapMaybe+  | GetterBranch Int   deriving (Show,Lift)  showGetterOps :: GetterOps -> String@@ -160,3 +179,4 @@       GetterBang -> "!"       GetterMapList -> "[]"       GetterMapMaybe -> "?"+      GetterBranch x -> '@' : show x

@@ -0,0 +1,130 @@+{-|+Module      :  Data.Aeson.Schema.Utils.Sum+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++The 'SumType' data type that represents a sum type consisting of types+specified in a type-level list.+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Schema.Utils.Sum+  ( SumType(..)+  , fromSumType+  ) where++import Control.Applicative ((<|>))+import Data.Aeson (FromJSON(..))+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy(..))+import GHC.TypeLits (type (-), ErrorMessage(..), Nat, TypeError)++-- | Represents a sum type.+--+-- Loads the first type that successfully parses the JSON value.+--+-- Example:+--+-- @+-- data Owl = Owl+-- data Cat = Cat+-- data Toad = Toad+-- type Animal = SumType '[Owl, Cat, Toad]+--+-- Here Owl                         :: Animal+-- There (Here Cat)                 :: Animal+-- There (There (Here Toad))        :: Animal+--+-- {- Fails at compile-time+-- Here True                        :: Animal+-- Here Cat                         :: Animal+-- There (Here Owl)                 :: Animal+-- There (There (There (Here Owl))) :: Animal+-- -}+-- @+data SumType (types :: [Type]) where+  Here  :: forall x xs. x          -> SumType (x ': xs)+  There :: forall x xs. SumType xs -> SumType (x ': xs)++deriving instance (Show x, Show (SumType xs)) => Show (SumType (x ': xs))+instance Show (SumType '[]) where+  show = error "impossible"++deriving instance (Eq x, Eq (SumType xs)) => Eq (SumType (x ': xs))+instance Eq (SumType '[]) where+  (==) = error "impossible"++deriving instance (Ord x, Ord (SumType xs)) => Ord (SumType (x ': xs))+instance Ord (SumType '[]) where+  compare = error "impossible"++instance (FromJSON x, FromJSON (SumType xs)) => FromJSON (SumType (x ': xs)) where+  parseJSON v = (Here <$> parseJSON v) <|> (There <$> parseJSON v)++instance FromJSON (SumType '[]) where+  parseJSON _ = fail "Could not parse sum type"++{- Extracting sum type branches -}++class FromSumType (n :: Nat) (types :: [Type]) (x :: Type) where+  fromSumType' :: 'Just x ~ GetIndex n types => proxy1 n -> SumType types -> Maybe x++instance {-# OVERLAPPING #-} FromSumType 0 (x ': xs) x where+  fromSumType' _ = \case+    Here x -> Just x+    There _ -> Nothing++instance {-# OVERLAPPABLE #-}+  ( FromSumType (n - 1) xs x+  , 'Just x ~ GetIndex (n - 1) xs+  ) => FromSumType n (_x ': xs) x where+  fromSumType' _ = \case+    Here _ -> Nothing+    There xs -> fromSumType' (Proxy @(n - 1)) xs++fromSumType+  :: ( IsInRange n types+     , 'Just result ~ GetIndex n types+     , FromSumType n types result+     )+  => proxy n -> SumType types -> Maybe result+fromSumType = fromSumType'++{- Helpers -}++type family IsInRange (n :: Nat) (xs :: [Type]) :: Constraint where+  IsInRange n xs = IsInRange'+    ( TypeError+      (     'Text "Index "+      ':<>: 'ShowType n+      ':<>: 'Text " does not exist in list: "+      ':<>: 'ShowType xs+      )+    )+    n+    xs++type family IsInRange' typeErr (n :: Nat) (xs :: [Type]) :: Constraint where+  IsInRange' typeErr _ '[] = typeErr+  IsInRange' _ 0 (_ ': _) = ()+  IsInRange' typeErr n (_ ': xs) = IsInRange' typeErr (n - 1) xs++type family GetIndex (n :: Nat) (types :: [Type]) :: Maybe Type where+  GetIndex 0 (x ': xs) = 'Just x+  GetIndex _ '[] = 'Nothing+  GetIndex n (_ ': xs) = GetIndex (n - 1) xs

@@ -0,0 +1,23 @@+{-|+Module      :  Data.Aeson.Schema.Utils.TypeFamilies+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Utilities for working with type families.+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Aeson.Schema.Utils.TypeFamilies+  ( All+  ) where++import Data.Kind (Constraint)++type family All (f :: a -> Constraint) (xs :: [a]) :: Constraint where+  All _ '[] = ()+  All f (x ': xs) = (f x, All f xs)

@@ -60,6 +60,9 @@     },     nonexistent: Maybe Text,     // future_key: Int,+    union: List (+        { a: Int } | List Bool | Text+    ),   } |] 

@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module Enums (State(..), Color(..)) where++import Data.Aeson.Schema.TH (genFromJSONEnum, genToJSONEnum, mkEnum)++mkEnum "State" ["OPEN", "CLOSED"]++data Color = Red | LightBlue | Yellow | DarkGreen | Black | JustABitOffWhite+  deriving (Show, Eq, Enum)++genFromJSONEnum ''Color+genToJSONEnum ''Color

@@ -1,23 +1,34 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +import Data.Aeson (ToJSON, decode, eitherDecode, encode) import Data.Aeson.Schema (Object, get, unwrap)+import Data.Aeson.Schema.Utils.Sum (SumType(..), fromSumType) import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.Char (toLower, toUpper) import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy(..)) import qualified Data.Text as Text import Language.Haskell.TH.TestUtils (tryQErr') import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Golden (goldenVsString)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck+    (arbitrary, elements, infiniteListOf, oneof, testProperty, (===)) import Text.RawString.QQ (r)  import qualified AllTypes+import Enums import qualified Nested import Schema+import SumType import Util  allTypes :: Object AllTypes.Schema@@ -32,6 +43,8 @@   , testUnwrapSchema   , testSchemaDef   , testMkGetter+  , testEnumTH+  , testSumType   ]  goldens' :: String -> String -> TestTree@@ -74,6 +87,11 @@   , goldens "list_maybeBool"           [get| allTypes.list[].maybeBool      |]   , goldens "list_maybeInt"            [get| allTypes.list[].maybeInt       |]   , goldens "nonexistent"              [get| allTypes.nonexistent           |]+  , goldens "union"                    [get| allTypes.union                 |]+  , goldens "union_0"                  [get| allTypes.union[]@0             |]+  , goldens "union_0_a"                [get| allTypes.union[]@0?.a          |]+  , goldens "union_1"                  [get| allTypes.union[]@1             |]+  , goldens "union_2"                  [get| allTypes.union[]@2             |]   -- bad 'get' expressions   , goldens' "maybeListNull_bang" $(getError [get| (AllTypes.result).maybeListNull! |]) #if MIN_VERSION_megaparsec(7,0,0)@@ -127,6 +145,8 @@   , goldens' "unwrap_schema_bad_question" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]?")   , goldens' "unwrap_schema_bad_list" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[][]")   , goldens' "unwrap_schema_bad_key" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list.a")+  , goldens' "unwrap_schema_bad_branch" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list@0")+  , goldens' "unwrap_schema_branch_out_of_bounds" $(tryQErr' $ showUnwrap "(AllTypes.Schema).union[]@10")   ]  testSchemaDef :: TestTree@@ -144,6 +164,8 @@   , goldens' "schema_def_import_user" $(showSchema [r| { user: #UserSchema } |])   , goldens' "schema_def_extend" $(showSchema [r| { a: Int, #(Schema.MySchema) } |])   , goldens' "schema_def_shadow" $(showSchema [r| { extra: Bool, #(Schema.MySchema) } |])+  , goldens' "schema_def_union" $(showSchema [r| { a: List Int | Text } |])+  , goldens' "schema_def_union_grouped" $(showSchema [r| { a: List (Int | Text) } |])   -- bad schema definitions   , goldens' "schema_def_duplicate" $(tryQErr' $ showSchema [r| { a: Int, a: Bool } |])   , goldens' "schema_def_duplicate_extend" $(tryQErr' $ showSchema [r| { #MySchema, #MySchema2 } |])@@ -163,3 +185,108 @@      getType :: AllTypes.ListItem -> Text.Text     getType = [get| .type |]++testEnumTH :: TestTree+testEnumTH = testGroup "Test the Enum TH helpers"+  -- State+  [ testProperty "mkEnum decode is case insensitive" $ do+      (val, enumVal) <- elements+        [ ("OPEN", OPEN)+        , ("CLOSED", CLOSED)+        ]+      casedVal <- randomlyCased val+      return $ decode (ByteString.pack $ show casedVal) === Just enumVal+  , testCase "mkEnum encode keeps case of constructor" $ do+      encode OPEN @?= "\"OPEN\""+      encode CLOSED @?= "\"CLOSED\""+  , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do+      enumVal <- elements [OPEN, CLOSED]+      return $ (decode . encode) enumVal === Just enumVal++  -- Color+  , testProperty "genFromJSONEnum decode is case insensitive" $ do+      (val, enumVal) <- elements+        [ ("Red", Red)+        , ("LightBlue", LightBlue)+        , ("Yellow", Yellow)+        , ("DarkGreen", DarkGreen)+        , ("Black", Black)+        , ("JustABitOffWhite", JustABitOffWhite)+        ]+      casedVal <- randomlyCased val+      return $ decode (ByteString.pack $ show casedVal) === Just enumVal+  , testCase "genToJSONEnum encode keeps case of constructor" $ do+      encode Red @?= "\"Red\""+      encode LightBlue @?= "\"LightBlue\""+      encode Yellow @?= "\"Yellow\""+      encode DarkGreen @?= "\"DarkGreen\""+      encode Black @?= "\"Black\""+      encode JustABitOffWhite @?= "\"JustABitOffWhite\""+  , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do+      enumVal <- elements+        [ Red+        , LightBlue+        , Yellow+        , DarkGreen+        , Black+        , JustABitOffWhite+        ]+      return $ (decode . encode) enumVal === Just enumVal+  ]+  where+    randomlyCased s = do+      caseFuncs <- infiniteListOf $ elements [toLower, toUpper]+      return $ zipWith ($) caseFuncs s++testSumType :: TestTree+testSumType = testGroup "Test the SumType helper"+  [ testCase "Sanity checks" $+      let values =+            [ Here True+            , Here False+            , There (Here 1)+            , There (Here 10)+            , There (There (Here []))+            , There (There (Here ["a"]))+            ] :: [SpecialJSON]+      in values @?= values+  , testGroup "Decode SumType"+    [ testProperty "branch 1" $ \(b :: Bool) ->+        toSpecialJSON b === Right (Here b)+    , testProperty "branch 2" $ \(x :: Int) ->+        toSpecialJSON x === Right (There (Here x))+    , testProperty "branch 3" $ \(l :: [String]) ->+        toSpecialJSON l === Right (There (There (Here l)))+    , testCase "invalid SumType" $+        toSpecialJSON [True] @?= Left "Error in $: Could not parse sum type"+    ]+  , testGroup "fromSumType"+    [ testProperty "branch 0 valid" $ \b ->+        fromSumType (Proxy @0) (Here b :: SpecialJSON) === Just b+    , testProperty "branch 0 invalid" $ do+        value <- oneof+          [ There . Here <$> arbitrary+          , There . There . Here <$> arbitrary+          ]+        return $ fromSumType (Proxy @0) (value :: SpecialJSON) === Nothing+    , testProperty "branch 1 valid" $ \x ->+        fromSumType (Proxy @1) (There (Here x) :: SpecialJSON) === Just x+    , testProperty "branch 1 invalid" $ do+        value <- oneof+          [ Here <$> arbitrary+          , There . There . Here <$> arbitrary+          ]+        return $ fromSumType (Proxy @1) (value :: SpecialJSON) === Nothing+    , testProperty "branch 2 valid" $ \l ->+        fromSumType (Proxy @2) (There (There (Here l)) :: SpecialJSON) === Just l+    , testProperty "branch 2 invalid" $ do+        value <- oneof+          [ Here <$> arbitrary+          , There . Here <$> arbitrary+          ]+        return $ fromSumType (Proxy @2) (value :: SpecialJSON) === Nothing+    ]+  ]+  where+    toSpecialJSON :: ToJSON a => a -> Either String SpecialJSON+    toSpecialJSON = eitherDecode . encode

@@ -0,0 +1,7 @@+{-# LANGUAGE DataKinds #-}++module SumType where++import Data.Aeson.Schema.Utils.Sum (SumType(..))++type SpecialJSON = SumType '[Bool, Int, [String]]

@@ -32,5 +32,11 @@             "type": "null",             "maybeNull": null         }+    ],+    "union": [+        "Hello",+        { "a": 1 },+        [true, false],+        "World!"     ] }

@@ -3,4 +3,4 @@ 1 | <empty line>   | ^ unexpected end of input-expecting "[]", '!', '(', '.', '?', '[', lowercase letter, or white space+expecting "[]", '!', '(', '.', '?', '@', '[', lowercase letter, or white space

@@ -3,4 +3,4 @@ 1 | allTypes   |         ^ unexpected end of input-expecting "[]", '!', ''', '(', '.', '?', '[', or alphanumeric character+expecting "[]", '!', ''', '(', '.', '?', '@', '[', or alphanumeric character

@@ -0,0 +1,1 @@+SchemaObject {"a": ( List Int | Text )}

@@ -0,0 +1,1 @@+SchemaObject {"a": List ( Int | Text )}

@@ -0,0 +1,1 @@+[There (There (Here "Hello")),Here {"a": 1},There (Here [True,False]),There (There (Here "World!"))]

@@ -0,0 +1,1 @@+[Nothing,Just {"a": 1},Nothing,Nothing]

@@ -0,0 +1,1 @@+[Nothing,Just 1,Nothing,Nothing]

@@ -0,0 +1,1 @@+[Nothing,Nothing,Just [True,False],Nothing]

@@ -0,0 +1,1 @@+[Just "Hello",Nothing,Nothing,Just "World!"]

@@ -0,0 +1,1 @@+Cannot use `@` operator on schema: SchemaList {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -0,0 +1,1 @@+Branch out of bounds for schema: SchemaUnion ( {"a": Int} | List Bool | Text )