aeson-schemas 1.1.0 → 1.2.0

raw patch · 21 files changed

+269/−76 lines, 21 filesdep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−2
• aeson-schemas.cabal +17/−7
• src/Data/Aeson/Schema/Internal.hs +59/−15
• src/Data/Aeson/Schema/Key.hs +25/−0
• src/Data/Aeson/Schema/Show.hs +9/−2
• src/Data/Aeson/Schema/TH/Parse.hs +12/−2
• src/Data/Aeson/Schema/TH/Schema.hs +41/−11
• src/Data/Aeson/Schema/TH/Utils.hs +48/−36
• src/Data/Aeson/Schema/Utils/Sum.hs +15/−0
• test/AllTypes.hs +9/−0
• test/Main.hs +9/−0
• test/all_types.json +6/−1
• test/goldens/phantom.golden +1/−0
• test/goldens/schema_def_duplicate_phantom.golden +1/−0
• test/goldens/schema_def_nonobject_phantom.golden +1/−0
• test/goldens/tryObj.golden +1/−0
• test/goldens/tryObjNull.golden +1/−0
• test/goldens/tryObjNull_a.golden +1/−0
• test/goldens/tryObj_a.golden +1/−0
• test/goldens/tryObj_bang.golden +1/−0
• test/goldens/tryObj_bang_a.golden +1/−0

@@ -1,10 +1,18 @@ ## Upcoming +## 1.2.0++New features:++* Add support for phantom keys+* Add support for `Try` schemas+ ## 1.1.0  New features:-    * Added support for unions-    * Added `ToJSON` instance for enums generated with `mkEnum`++* Added support for unions+* Added `ToJSON` instance for enums generated with `mkEnum`  ## 1.0.3 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 79cd47bc31fb343c075854b35187f50f082ad4bc23f5bc14a9e514cc8633c9f2+-- hash: f264efe1e9e5d79645f971635649d0dea5c3dedf8e8aee3513f201dd9386a438  name:           aeson-schemas-version:        1.1.0+version:        1.2.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@@ -63,6 +63,7 @@     test/goldens/maybeObjNull.golden     test/goldens/maybeObjNull_text.golden     test/goldens/nonexistent.golden+    test/goldens/phantom.golden     test/goldens/README_Quickstart.golden     test/goldens/scalar.golden     test/goldens/schema_def_bool.golden@@ -70,6 +71,7 @@     test/goldens/schema_def_double.golden     test/goldens/schema_def_duplicate.golden     test/goldens/schema_def_duplicate_extend.golden+    test/goldens/schema_def_duplicate_phantom.golden     test/goldens/schema_def_extend.golden     test/goldens/schema_def_import_user.golden     test/goldens/schema_def_int.golden@@ -78,6 +80,7 @@     test/goldens/schema_def_list_obj.golden     test/goldens/schema_def_maybe.golden     test/goldens/schema_def_maybe_obj.golden+    test/goldens/schema_def_nonobject_phantom.golden     test/goldens/schema_def_not_object.golden     test/goldens/schema_def_obj.golden     test/goldens/schema_def_shadow.golden@@ -86,6 +89,12 @@     test/goldens/schema_def_union_grouped.golden     test/goldens/schema_def_unknown_type.golden     test/goldens/text.golden+    test/goldens/tryObj.golden+    test/goldens/tryObj_a.golden+    test/goldens/tryObj_bang.golden+    test/goldens/tryObj_bang_a.golden+    test/goldens/tryObjNull.golden+    test/goldens/tryObjNull_a.golden     test/goldens/union.golden     test/goldens/union_0.golden     test/goldens/union_0_a.golden@@ -109,6 +118,7 @@   exposed-modules:       Data.Aeson.Schema       Data.Aeson.Schema.Internal+      Data.Aeson.Schema.Key       Data.Aeson.Schema.Show       Data.Aeson.Schema.TH       Data.Aeson.Schema.Utils.Sum@@ -125,12 +135,12 @@       src   ghc-options: -Wall   build-depends:-      aeson >=1.1.2.0 && <1.5+      aeson >=1.1.2.0 && <1.6     , base >=4.9 && <5     , bytestring >=0.10.8.1 && <0.11     , first-class-families >=0.3.0.0 && <0.9     , megaparsec >=6.0.0 && <9-    , template-haskell >=2.12.0.0 && <2.16+    , template-haskell >=2.12.0.0 && <2.17     , text >=1.2.2.2 && <1.3     , unordered-containers >=0.2.8.0 && <0.3   if impl(ghc >= 8.0)@@ -155,18 +165,18 @@   ghc-options: -Wall   build-depends:       QuickCheck >=2.7 && <3-    , aeson >=1.1.2.0 && <1.5+    , aeson >=1.1.2.0 && <1.6     , aeson-schemas     , base >=4.9 && <5     , bytestring >=0.10.8.1 && <0.11     , 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 >=0.11.3 && <1.4     , 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+    , template-haskell >=2.12.0.0 && <2.17     , text >=1.2.2.2 && <1.3     , th-test-utils >=1.0.0 && <1.1     , unordered-containers >=0.2.8.0 && <0.3

@@ -44,7 +44,8 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable, splitTyConApp, tyConName, typeRep, typeRepTyCon)-import Fcf (type (=<<), Eval, FromMaybe, Lookup)+import Fcf (type (<=<), type (=<<))+import qualified Fcf import GHC.Exts (toList) import GHC.TypeLits     (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)@@ -83,8 +84,9 @@   | SchemaText   | SchemaCustom Type   | SchemaMaybe SchemaType+  | SchemaTry SchemaType   | SchemaList SchemaType-  | SchemaObject [(Symbol, SchemaType)]+  | SchemaObject [(SchemaKey, SchemaType)]   | SchemaUnion [SchemaType] -- ^ @since v1.1.0  -- | Convert 'SchemaType' into 'SchemaShow.SchemaType'.@@ -98,6 +100,7 @@       ("'SchemaText", _) -> SchemaShow.SchemaText       ("'SchemaCustom", [inner]) -> SchemaShow.SchemaCustom $ typeRepName inner       ("'SchemaMaybe", [inner]) -> SchemaShow.SchemaMaybe $ cast inner+      ("'SchemaTry", [inner]) -> SchemaShow.SchemaTry $ cast inner       ("'SchemaList", [inner]) -> SchemaShow.SchemaList $ cast inner       ("'SchemaObject", [pairs]) -> SchemaShow.SchemaObject $ map getSchemaObjectPair $ typeRepToList pairs       ("'SchemaUnion", [schemas]) -> SchemaShow.SchemaUnion $ map cast $ typeRepToList schemas@@ -105,8 +108,12 @@      getSchemaObjectPair tyRep =       let (key, val) = typeRepToPair tyRep-          key' = tail . init . typeRepName $ key -- strip leading + trailing quote-      in (key', cast val)+          fromTypeRep = tail . init . typeRepName -- strip leading + trailing quote+          schemaKey = case splitTypeRep key of+            ("'NormalKey", [key']) -> SchemaShow.NormalKey $ fromTypeRep key'+            ("'PhantomKey", [key']) -> SchemaShow.PhantomKey $ fromTypeRep key'+            _ -> error $ "Unknown schema key: " ++ show key+      in (schemaKey, cast val)      typeRepToPair tyRep = case splitTypeRep tyRep of       ("'(,)", [a, b]) -> (a, b)@@ -124,6 +131,30 @@ showSchema :: forall (a :: SchemaType). Typeable a => String showSchema = SchemaShow.showSchemaType $ toSchemaTypeShow @a +-- | The type-level analogue of 'Data.Aeson.Schema.Key.SchemaKey'.+data SchemaKey+  = NormalKey Symbol+  | PhantomKey Symbol++type family FromSchemaKey (schemaKey :: SchemaKey) where+  FromSchemaKey ('NormalKey key) = key+  FromSchemaKey ('PhantomKey key) = key++fromSchemaKey :: forall schemaKey. KnownSymbol (FromSchemaKey schemaKey) => Text+fromSchemaKey = Text.pack $ symbolVal $ Proxy @(FromSchemaKey schemaKey)++class+  ( Typeable schemaKey+  , KnownSymbol (FromSchemaKey schemaKey)+  ) => KnownSchemaKey (schemaKey :: SchemaKey) where+  getContext :: HashMap Text Value -> Value++instance KnownSymbol key => KnownSchemaKey ('NormalKey key) where+  getContext = fromMaybe Null . HashMap.lookup (fromSchemaKey @('NormalKey key))++instance KnownSymbol key => KnownSchemaKey ('PhantomKey key) where+  getContext = Object+ {- Conversions from schema types into Haskell types -}  -- | A type family mapping SchemaType to the corresponding Haskell type.@@ -134,6 +165,7 @@   SchemaResult 'SchemaText = Text   SchemaResult ('SchemaCustom inner) = inner   SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner)+  SchemaResult ('SchemaTry inner) = Maybe (SchemaResult inner)   SchemaResult ('SchemaList inner) = [SchemaResult inner]   SchemaResult ('SchemaObject inner) = Object ('SchemaObject inner)   SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas)@@ -167,6 +199,11 @@     Null -> return Nothing     value -> (Just <$> parseValue @inner path value) +instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaTry inner) where+  parseValue path = wrapTry . parseValue @inner path+    where+      wrapTry parser = (Just <$> parser) <|> pure Nothing+ instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaList inner) where   parseValue path value = case value of     Array a -> traverse (parseValue @inner path) (toList a)@@ -180,34 +217,34 @@   showValue _ = "{}"  instance-  ( KnownSymbol key+  ( KnownSchemaKey schemaKey   , IsSchemaType inner   , Show (SchemaResult inner)   , Typeable (SchemaResult inner)   , IsSchemaObject ('SchemaObject rest)   , Typeable rest-  ) => IsSchemaType ('SchemaObject ('(key, inner) ': rest)) where+  ) => IsSchemaType ('SchemaObject ('(schemaKey, inner) ': rest)) where   parseValue path value = case value of     Object o -> do-      let key = Text.pack $ symbolVal $ Proxy @key-          innerVal = fromMaybe Null $ HashMap.lookup key o+      let key = fromSchemaKey @schemaKey+          innerVal = getContext @schemaKey o        inner <- parseValue @inner (key:path) innerVal       UnsafeObject rest <- parseValue @('SchemaObject rest) path value        return $ UnsafeObject $ HashMap.insert key (toDyn inner) rest-    _ -> parseFail @('SchemaObject ('(key, inner) ': rest)) path value+    _ -> parseFail @('SchemaObject ('(schemaKey, inner) ': rest)) path value    showValue (UnsafeObject hm) = case showValue @('SchemaObject rest) (UnsafeObject hm) of     "{}" -> "{" ++ pair ++ "}"     '{':s -> "{" ++ pair ++ ", " ++ s     s -> error $ "Unknown result when showing Object: " ++ s     where-      key = symbolVal $ Proxy @key+      key = fromSchemaKey @schemaKey       value =-        let dynValue = hm ! Text.pack key+        let dynValue = hm ! key         in maybe (show dynValue) show $ fromDynamic @(SchemaResult inner) dynValue-      pair = "\"" ++ key ++ "\": " ++ value+      pair = show key ++ ": " ++ value  instance   ( All IsSchemaType schemas@@ -229,17 +266,24 @@  {- Lookups within SchemaObject -} +data UnSchemaKey :: SchemaKey -> Fcf.Exp Symbol+type instance Fcf.Eval (UnSchemaKey ('NormalKey key)) = Fcf.Eval (Fcf.Pure key)+type instance Fcf.Eval (UnSchemaKey ('PhantomKey key)) = Fcf.Eval (Fcf.Pure key)++-- first-class-families-0.3.0.1 doesn't support partially applying Lookup+type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst)+ -- | 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-    ( FromMaybe (TypeError+  LookupSchema key ('SchemaObject schema) = Fcf.Eval+    ( Fcf.FromMaybe (TypeError         (     'Text "Key '"         ':<>: 'Text key         ':<>: 'Text "' does not exist in the following schema:"         ':$$: 'ShowType schema         )       )-      =<< Lookup key schema+      =<< Lookup key =<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema     )   LookupSchema key schema = TypeError     (     'Text "Attempted to lookup key '"

@@ -0,0 +1,25 @@+{-|+Module      :  Data.Aeson.Schema.Key+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Defines a SchemaKey.+-}++module Data.Aeson.Schema.Key+  ( SchemaKey(..)+  , fromSchemaKey+  ) where++-- | A key in a JSON object schema.+data SchemaKey+  = NormalKey String+  | PhantomKey String+    -- ^ A key that doesn't actually exist in the object, but whose content should be parsed from+    -- the current object.+  deriving (Show)++fromSchemaKey :: SchemaKey -> String+fromSchemaKey (NormalKey key) = key+fromSchemaKey (PhantomKey key) = key

@@ -11,10 +11,14 @@ module Data.Aeson.Schema.Show   ( SchemaType(..)   , showSchemaType+    -- * Re-exports+  , SchemaKey(..)   ) where  import Data.List (intercalate) +import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey)+ -- | 'Data.Aeson.Schema.Internal.SchemaType', but for printing. data SchemaType   = SchemaBool@@ -23,8 +27,9 @@   | SchemaText   | SchemaCustom String   | SchemaMaybe SchemaType+  | SchemaTry SchemaType   | SchemaList SchemaType-  | SchemaObject [(String, SchemaType)]+  | SchemaObject [(SchemaKey, SchemaType)]   | SchemaUnion [SchemaType]   deriving (Show) @@ -37,6 +42,7 @@   SchemaText -> "SchemaText"   SchemaCustom s -> "SchemaCustom " ++ s   SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaType' inner+  SchemaTry inner -> "SchemaTry " ++ showSchemaType' inner   SchemaList inner -> "SchemaList " ++ showSchemaType' inner   SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema   SchemaUnion _ -> "SchemaUnion " ++ showSchemaType' schema@@ -48,9 +54,10 @@       SchemaText -> "Text"       SchemaCustom s -> s       SchemaMaybe inner -> "Maybe " ++ showSchemaType' inner+      SchemaTry inner -> "Try " ++ showSchemaType' inner       SchemaList inner -> "List " ++ showSchemaType' inner       SchemaObject pairs -> "{" ++ mapJoin showPair ", " pairs ++ "}"       SchemaUnion schemas -> "( " ++ mapJoin showSchemaType' " | " schemas ++ " )"-    showPair (key, inner) = "\"" ++ key ++ "\": " ++ showSchemaType' inner+    showPair (key, inner) = "\"" ++ fromSchemaKey key ++ "\": " ++ showSchemaType' inner      mapJoin f delim = intercalate delim . map f

@@ -66,6 +66,7 @@       [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems       , between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions       , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions)+      , lexeme "Try" *> (SchemaDefTry <$> parseSchemaDefWithoutUnions)       , lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions)       , SchemaDefType <$> identifier upperChar       , SchemaDefInclude <$> parseSchemaReference@@ -77,7 +78,10 @@       , SchemaDefObjExtend <$> parseSchemaReference       ] <* space -- allow any trailing spaces     parseSchemaDefPair = do-      key <- jsonKey+      key <- choice+        [ SchemaDefObjKeyNormal <$> jsonKey+        , SchemaDefObjKeyPhantom <$> between (lexeme "[") (lexeme "]") jsonKey+        ]       lexeme ":"       value <- parseSchemaDefWithUnions       return (key, value)@@ -115,6 +119,7 @@ data SchemaDef   = SchemaDefType String   | SchemaDefMaybe SchemaDef+  | SchemaDefTry SchemaDef   | SchemaDefList SchemaDef   | SchemaDefInclude String   | SchemaDefObj [SchemaDefObjItem]@@ -122,8 +127,13 @@   deriving (Show)  data SchemaDefObjItem-  = SchemaDefObjPair (String, SchemaDef)+  = SchemaDefObjPair (SchemaDefObjKey, SchemaDef)   | SchemaDefObjExtend String+  deriving (Show)++data SchemaDefObjKey+  = SchemaDefObjKeyNormal String+  | SchemaDefObjKeyPhantom String   deriving (Show)  schemaDef :: Parser SchemaDef

@@ -16,7 +16,7 @@  module Data.Aeson.Schema.TH.Schema (schema) where -import Control.Monad ((<=<), (>=>))+import Control.Monad (unless, (<=<), (>=>)) import Data.Bifunctor (second) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (mapMaybe)@@ -24,9 +24,11 @@ import Language.Haskell.TH.Quote (QuasiQuoter(..))  import Data.Aeson.Schema.Internal (SchemaType(..))+import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey)+import qualified Data.Aeson.Schema.Show as SchemaShow import Data.Aeson.Schema.TH.Parse import Data.Aeson.Schema.TH.Utils-    (schemaPairsToTypeQ, typeQListToTypeQ, typeToSchemaPairs)+    (parseSchemaType, schemaPairsToTypeQ, typeQListToTypeQ, typeToSchemaPairs)  -- | Defines a QuasiQuoter for writing schemas. --@@ -62,12 +64,20 @@ -- * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values --   specified by the provided schema (no parentheses needed). --+-- * @Try \<schema\>@ correspond to @Maybe@, where the value will be @Just@ if the given schema+--   successfully parses the value, or @Nothing@ otherwise.+--+-- * Any other uppercase identifier corresponds to the respective type in scope -- requires a+--   FromJSON instance.+--+-- Advanced syntax:+-- -- * @\<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.+-- * @{ [key]: \<schema\> }@ uses the current object to resolve the keys in the given schema. Only+--   object schemas are allowed here. -- -- * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. --@@ -95,6 +105,7 @@   SchemaDefType "Text"   -> [t| 'SchemaText |]   SchemaDefType other    -> [t| 'SchemaCustom $(getType other) |]   SchemaDefMaybe inner   -> [t| 'SchemaMaybe $(generateSchema inner) |]+  SchemaDefTry inner     -> [t| 'SchemaTry $(generateSchema inner) |]   SchemaDefList inner    -> [t| 'SchemaList $(generateSchema inner) |]   SchemaDefInclude other -> getType other   SchemaDefObj items     -> generateSchemaObject items@@ -113,9 +124,20 @@  -- | Parse SchemaDefObjItem into a list of tuples, each containing a key to add to the schema, -- the value for the key, and the source of the key.-toParts :: SchemaDefObjItem -> Q [(String, TypeQ, KeySource)]+toParts :: SchemaDefObjItem -> Q [(SchemaKey, TypeQ, KeySource)] toParts = \case-  SchemaDefObjPair (k, v) -> pure . tagAs Provided $ [(k, generateSchema v)]+  SchemaDefObjPair (schemaDefKey, schemaDefType) -> do+    let schemaKey = schemaDefToSchemaKey schemaDefKey+    schemaType <- generateSchema schemaDefType++    case schemaKey of+      PhantomKey _ -> do+        let schemaTypeShow = parseSchemaType schemaType+        unless (isValidPhantomSchema schemaTypeShow) $+          fail $ "Invalid schema for '" ++ fromSchemaKey schemaKey ++ "': " ++ SchemaShow.showSchemaType schemaTypeShow+      _ -> return ()++    pure . tagAs Provided $ [(schemaKey, pure schemaType)]   SchemaDefObjExtend other -> do     name <- getName other     reify name >>= \case@@ -124,18 +146,26 @@       _ -> fail $ "'" ++ show name ++ "' is not a SchemaObject"   where     tagAs source = map $ \(k,v) -> (k,v,source)+    schemaDefToSchemaKey = \case+      SchemaDefObjKeyNormal key -> NormalKey key+      SchemaDefObjKeyPhantom key -> PhantomKey key+    isValidPhantomSchema = \case+      SchemaShow.SchemaTry _ -> True+      SchemaShow.SchemaObject _ -> True+      SchemaShow.SchemaUnion schemas -> all isValidPhantomSchema schemas+      _ -> False  -- | Resolve the parts returned by 'toParts' as such: -- -- 1. Any explicitly provided keys shadow/overwrite imported keys -- 2. Fail if duplicate keys are both explicitly provided -- 3. Fail if duplicate keys are both imported-resolveParts :: [(String, TypeQ, KeySource)] -> Q [(String, TypeQ)]+resolveParts :: [(SchemaKey, TypeQ, KeySource)] -> Q [(SchemaKey, TypeQ)] resolveParts parts = do   resolved <- resolveParts' $ HashMap.fromListWith (++) $ map nameAndSource parts   return $ mapMaybe (alignWithResolved resolved) parts   where-    nameAndSource (name, _, source) = (name, [source])+    nameAndSource (name, _, source) = (fromSchemaKey name, [source])     resolveParts' = HashMap.traverseWithKey $ \name sources -> do       -- invariant: length sources > 0       let numOf source = length $ filter (== source) sources@@ -145,8 +175,8 @@         (x, _) | x > 1 -> fail $ "Key '" ++ name ++ "' specified multiple times"         (_, x) | x > 1 -> fail $ "Key '" ++ name ++ "' declared in multiple imported schemas"         _ -> fail "Broken invariant in resolveParts"-    alignWithResolved resolved (name, ty, source) =-      let resolvedSource = resolved HashMap.! name+    alignWithResolved resolved (key, ty, source) =+      let resolvedSource = resolved HashMap.! fromSchemaKey key       in if resolvedSource == source-        then Just (name, ty)+        then Just (key, ty)         else Nothing

@@ -6,6 +6,7 @@ -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-}@@ -13,55 +14,56 @@ module Data.Aeson.Schema.TH.Utils where  import Control.Monad ((>=>))-import Data.Bifunctor (bimap, second)+import Data.Bifunctor (bimap, first, second) import Data.List (intercalate) import Data.Text (Text)+import GHC.Stack (HasCallStack) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift)  import Data.Aeson.Schema.Internal (Object, SchemaResult, SchemaType(..))+import qualified Data.Aeson.Schema.Internal as Internal+import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey) import qualified Data.Aeson.Schema.Show as SchemaShow  -- | Show the given schema as a type.-showSchemaType :: Type -> String-showSchemaType = SchemaShow.showSchemaType . fromSchemaType-  where-    fromSchemaType = \case-      PromotedT name-        | name == 'SchemaBool -> SchemaShow.SchemaBool-        | name == 'SchemaInt -> SchemaShow.SchemaInt-        | name == 'SchemaDouble -> SchemaShow.SchemaDouble-        | name == 'SchemaText -> SchemaShow.SchemaText-      AppT (PromotedT name) (ConT inner)-        | name == 'SchemaCustom -> SchemaShow.SchemaCustom $ nameBase inner-      AppT (PromotedT name) inner-        | 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+showSchemaType :: HasCallStack => Type -> String+showSchemaType = SchemaShow.showSchemaType . parseSchemaType -    fromPairs pairs = map (second fromSchemaType) $ typeToSchemaPairs pairs+parseSchemaType :: HasCallStack => Type -> SchemaShow.SchemaType+parseSchemaType = \case+  PromotedT name+    | name == 'SchemaBool -> SchemaShow.SchemaBool+    | name == 'SchemaInt -> SchemaShow.SchemaInt+    | name == 'SchemaDouble -> SchemaShow.SchemaDouble+    | name == 'SchemaText -> SchemaShow.SchemaText+  AppT (PromotedT name) (ConT inner)+    | name == 'SchemaCustom -> SchemaShow.SchemaCustom $ nameBase inner+  AppT (PromotedT name) inner+    | name == 'SchemaMaybe -> SchemaShow.SchemaMaybe $ parseSchemaType inner+    | name == 'SchemaTry -> SchemaShow.SchemaTry $ parseSchemaType inner+    | name == 'SchemaList -> SchemaShow.SchemaList $ parseSchemaType inner+    | name == 'SchemaObject -> SchemaShow.SchemaObject $ fromPairs inner+    | name == 'SchemaUnion -> SchemaShow.SchemaUnion $ map parseSchemaType $ typeToList inner+  ty -> error $ "Unknown type: " ++ show ty+  where+    fromPairs pairs = map (second parseSchemaType) $ typeToSchemaPairs pairs -typeToList :: Type -> [Type]+typeToList :: HasCallStack => Type -> [Type] typeToList = \case   PromotedNilT -> []   AppT (AppT PromotedConsT x) xs -> x : typeToList xs   SigT ty _ -> typeToList ty   ty -> error $ "Not a type-level list: " ++ show ty -typeToPair :: Type -> (Type, Type)+typeToPair :: HasCallStack => 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 -typeToSchemaPairs :: Type -> [(String, Type)]-typeToSchemaPairs = map (bimap toTypeStr stripSigs . typeToPair) . typeToList-  where-    toTypeStr = \case-      LitT (StrTyLit k) -> k-      x -> error $ "Not a type-level string: " ++ show x+typeToSchemaPairs :: HasCallStack => Type -> [(SchemaKey, Type)]+typeToSchemaPairs = map (bimap parseSchemaKey stripSigs . typeToPair) . typeToList  typeQListToTypeQ :: [TypeQ] -> TypeQ typeQListToTypeQ = foldr consT promotedNilT@@ -69,11 +71,23 @@     -- nb. https://stackoverflow.com/a/34457936     consT x xs = appT (appT promotedConsT x) xs -schemaPairsToTypeQ :: [(String, TypeQ)] -> TypeQ+schemaPairsToTypeQ :: [(SchemaKey, TypeQ)] -> TypeQ schemaPairsToTypeQ = typeQListToTypeQ . map pairT   where-    pairT (k, v) = [t| '( $(litT $ strTyLit k), $v) |]+    pairT (k, v) =+      let schemaKey = case k of+            NormalKey key -> [t| 'Internal.NormalKey $(litT $ strTyLit key) |]+            PhantomKey key -> [t| 'Internal.PhantomKey $(litT $ strTyLit key) |]+      in [t| '($schemaKey, $v) |] +parseSchemaKey :: HasCallStack => Type -> SchemaKey+parseSchemaKey = \case+  AppT (PromotedT ty) (LitT (StrTyLit key))+    | ty == 'Internal.NormalKey -> NormalKey key+    | ty == 'Internal.PhantomKey -> PhantomKey key+  SigT ty _ -> parseSchemaKey ty+  ty -> error $ "Could not parse a schema key: " ++ show ty+ -- | Strip all kind signatures from the given type. stripSigs :: Type -> Type stripSigs = \case@@ -101,6 +115,7 @@       AppT (PromotedT ty) inner         | ty == 'SchemaCustom -> [t| SchemaResult $(pure schema) |]         | ty == 'SchemaMaybe -> [t| Maybe $(fromSchemaType inner) |]+        | ty == 'SchemaTry -> [t| Maybe $(fromSchemaType inner) |]         | ty == 'SchemaList -> [t| [$(fromSchemaType inner)] |]         | ty == 'SchemaObject -> [t| Object $(pure schema) |]         | ty == 'SchemaUnion -> [t| SchemaResult $(pure schema) |]@@ -130,8 +145,10 @@         foldl appT (tupleT $ length elems) $ map (`unwrapType'` schema) elems       GetterTuple _ -> fail $ "Cannot get keys in schema: " ++ showSchemaType schema       GetterBang | ty == 'SchemaMaybe -> unwrapType' ops inner+      GetterBang | ty == 'SchemaTry -> unwrapType' ops inner       GetterBang -> fail $ "Cannot use `!` operator on schema: " ++ showSchemaType schema       GetterMapMaybe | ty == 'SchemaMaybe -> withFunctor [t| Maybe |] $ unwrapType' ops inner+      GetterMapMaybe | ty == 'SchemaTry -> withFunctor [t| Maybe |] $ unwrapType' ops inner       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@@ -146,13 +163,8 @@   schema -> fail $ unlines ["Cannot get type:", show schema, show op]   where     unwrapType' = unwrapType keepFunctor-    getObjectSchema = \case-      AppT (AppT PromotedConsT t1) t2 ->-        case t1 of-          AppT (AppT (PromotedTupleT 2) (LitT (StrTyLit key))) ty -> (key, ty) : getObjectSchema t2-          _ -> error $ "Could not parse a (key, schema) tuple: " ++ show t1-      PromotedNilT -> []-      t -> error $ "Could not get object schema: " ++ show t+    getObjectSchema = map (first getSchemaKey . typeToPair) . typeToList+    getSchemaKey = fromSchemaKey . parseSchemaKey     withFunctor f = if keepFunctor then appT f else id  {- GetterOps -}

@@ -97,6 +97,21 @@     Here _ -> Nothing     There xs -> fromSumType' (Proxy @(n - 1)) xs +-- | Extract a value from a 'SumType'+--+-- Example:+--+-- @+-- type Animal = SumType '[Owl, Cat, Toad]+-- let someAnimal = ... :: Animal+--+-- fromSumType (Proxy :: Proxy 0) someAnimal :: Maybe Owl+-- fromSumType (Proxy :: Proxy 1) someAnimal :: Maybe Cat+-- fromSumType (Proxy :: Proxy 2) someAnimal :: Maybe Toad+--+-- -- Compile-time error+-- -- fromSumType (Proxy :: Proxy 3) someAnimal+-- @ fromSumType   :: ( IsInRange n types      , 'Just result ~ GetIndex n types

@@ -45,6 +45,12 @@     maybeObjectNull: Maybe {       text: Text,     },+    tryObject: Try {+      a: Int,+    },+    tryObjectNull: Try {+      a: Int,+    },     maybeList: Maybe List {       text: Text,     },@@ -63,6 +69,9 @@     union: List (         { a: Int } | List Bool | Text     ),+    [phantom]: {+      keyForPhantom: Int,+    },   } |] 

@@ -72,6 +72,12 @@   , goldens "maybeObj_bang_text"       [get| allTypes.maybeObject!.text     |]   , goldens "maybeObjNull"             [get| allTypes.maybeObjectNull       |]   , goldens "maybeObjNull_text"        [get| allTypes.maybeObjectNull?.text |]+  , goldens "tryObj"                   [get| allTypes.tryObject             |]+  , goldens "tryObjNull"               [get| allTypes.tryObjectNull         |]+  , goldens "tryObj_bang"              [get| allTypes.tryObject!            |]+  , goldens "tryObj_a"                 [get| allTypes.tryObject?.a          |]+  , goldens "tryObj_bang_a"            [get| allTypes.tryObject!.a          |]+  , goldens "tryObjNull_a"             [get| allTypes.tryObjectNull?.a      |]   , goldens "maybeList"                [get| allTypes.maybeList             |]   , goldens "maybeList_bang"           [get| allTypes.maybeList!            |]   , goldens "maybeList_bang_list"      [get| allTypes.maybeList![]          |]@@ -92,6 +98,7 @@   , goldens "union_0_a"                [get| allTypes.union[]@0?.a          |]   , goldens "union_1"                  [get| allTypes.union[]@1             |]   , goldens "union_2"                  [get| allTypes.union[]@2             |]+  , goldens "phantom"                  [get| allTypes.phantom.keyForPhantom |]   -- bad 'get' expressions   , goldens' "maybeListNull_bang" $(getError [get| (AllTypes.result).maybeListNull! |]) #if MIN_VERSION_megaparsec(7,0,0)@@ -168,10 +175,12 @@   , 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_phantom" $(tryQErr' $ showSchema [r| { a: Int, [a]: { b: Bool } } |])   , goldens' "schema_def_duplicate_extend" $(tryQErr' $ showSchema [r| { #MySchema, #MySchema2 } |])   , goldens' "schema_def_not_object" $(tryQErr' $ showSchema [r| List { a: Int } |])   , goldens' "schema_def_unknown_type" $(tryQErr' $ showSchema [r| HelloWorld |])   , goldens' "schema_def_invalid_extend" $(tryQErr' $ showSchema [r| { #Int } |])+  , goldens' "schema_def_nonobject_phantom" $(tryQErr' $ showSchema [r| { [a]: Int } |])   ]  testMkGetter :: TestTree

@@ -19,6 +19,10 @@         }     ],     "maybeListNull": null,+    "tryObject": {+        "a": 1+    },+    "tryObjectNull": true,     "list": [         {             "type": "bool",@@ -38,5 +42,6 @@         { "a": 1 },         [true, false],         "World!"-    ]+    ],+    "keyForPhantom": 1 }

@@ -0,0 +1,1 @@+1

@@ -0,0 +1,1 @@+Key 'a' specified multiple times

@@ -0,0 +1,1 @@+Invalid schema for 'a': SchemaInt

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

@@ -0,0 +1,1 @@+Nothing

@@ -0,0 +1,1 @@+Nothing

@@ -0,0 +1,1 @@+Just 1

@@ -0,0 +1,1 @@+{"a": 1}

@@ -0,0 +1,1 @@+1