aeson-schemas 1.3.1 → 1.3.2

raw patch · 13 files changed

+192/−125 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• aeson-schemas.cabal +3/−3
• src/Data/Aeson/Schema/Internal.hs +12/−1
• src/Data/Aeson/Schema/Show.hs +0/−49
• src/Data/Aeson/Schema/TH/Getter.hs +3/−2
• src/Data/Aeson/Schema/TH/Schema.hs +4/−4
• src/Data/Aeson/Schema/TH/Unwrap.hs +10/−7
• src/Data/Aeson/Schema/TH/Utils.hs +66/−36
• src/Data/Aeson/Schema/Type.hs +29/−16
• src/Data/Aeson/Schema/Utils/NameLike.hs +36/−0
• test/TestUtils/Arbitrary.hs +9/−3
• test/Tests/SchemaQQ.hs +5/−0
• test/Tests/SchemaQQ/TH.hs +9/−4

@@ -1,5 +1,11 @@ ## Upcoming +## 1.3.2++Performance:++* Optimized including other schemas in a schema, which previously caused a huge slowdown, and possibly even out-of-memory errors.+ ## 1.3.1  Bug fixes:

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 82900f71614e4d0f5e4144719819585f4e34452136bb4bd5c4f9a7fd4f1b495c+-- hash: f878fea8c59bc8e0ba2ad6e3624a633b30cde5f6dba00bc63ed4c4777ac808f7  name:           aeson-schemas-version:        1.3.1+version:        1.3.2 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@@ -58,11 +58,11 @@       Data.Aeson.Schema       Data.Aeson.Schema.Internal       Data.Aeson.Schema.Key-      Data.Aeson.Schema.Show       Data.Aeson.Schema.TH       Data.Aeson.Schema.Type       Data.Aeson.Schema.Utils.All       Data.Aeson.Schema.Utils.Invariant+      Data.Aeson.Schema.Utils.NameLike       Data.Aeson.Schema.Utils.Sum   other-modules:       Data.Aeson.Schema.TH.Enum

@@ -67,6 +67,8 @@     , SchemaType'(..)     , ToSchemaObject     , showSchemaTypeV+    , showSchemaV+    , toSchemaV     ) import Data.Aeson.Schema.Utils.All (All(..)) import Data.Aeson.Schema.Utils.Invariant (unreachable)@@ -111,6 +113,7 @@ type IsSchema (schema :: Schema) =   ( HasSchemaResult (ToSchemaObject schema)   , All HasSchemaResultPair (FromSchema schema)+  , IsSchemaObjectMap (FromSchema schema)   , SchemaResult (ToSchemaObject schema) ~ Object schema   ) @@ -122,7 +125,9 @@ -- > showSchema @MySchema -- showSchema :: forall (schema :: Schema). IsSchema schema => String-showSchema = showSchemaType @(ToSchemaObject schema)+showSchema = "SchemaObject " ++ showSchemaV schema -- TODO: Remove "SchemaObject" prefix? Or rename to "Schema"?+  where+    schema = toSchemaV $ Proxy @schema  showSchemaType :: forall (schemaType :: SchemaType). HasSchemaResult schemaType => String showSchemaType = showSchemaTypeV schemaType@@ -139,6 +144,7 @@   SchemaResult ('SchemaList inner) = [SchemaResult inner]   SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas)   SchemaResult ('SchemaObject inner) = Object ('Schema inner)+  SchemaResult ('SchemaInclude ('Right schema)) = SchemaResult (ToSchemaObject schema)  type family SchemaResultList (xs :: [SchemaType]) where   SchemaResultList '[] = '[]@@ -249,6 +255,11 @@   showValuePair _ o = (showSchemaKey @key, showValue @inner val)     where       val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o++instance IsSchema schema => HasSchemaResult ('SchemaInclude ('Right schema)) where+  parseValue = parseValue @(ToSchemaObject schema)+  toValue = toValue @(ToSchemaObject schema)+  showValue = showValue @(ToSchemaObject schema)  -- | A helper for creating fail messages when parsing a schema. parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Text] -> Value -> m a

@@ -1,49 +0,0 @@-{-|-Module      :  Data.Aeson.Schema.Show-Maintainer  :  Brandon Chinn <brandon@leapyear.io>-Stability   :  experimental-Portability :  portable--Utilities for showing a schema. Meant to be imported qualified.--}-{-# LANGUAGE LambdaCase #-}--module Data.Aeson.Schema.Show-  ( SchemaType(..)-  , showSchemaType-  ) where--import Data.List (intercalate)--import Data.Aeson.Schema.Key (SchemaKeyV, showSchemaKeyV)---- | 'Data.Aeson.Schema.Internal.SchemaType', but for printing.-data SchemaType-  = SchemaScalar String-  | SchemaMaybe SchemaType-  | SchemaTry SchemaType-  | SchemaList SchemaType-  | SchemaObject [(SchemaKeyV, SchemaType)]-  | SchemaUnion [SchemaType]-  deriving (Show,Eq)---- | Pretty show the given SchemaType.-showSchemaType :: SchemaType -> String-showSchemaType schema = case schema of-  SchemaScalar s -> "SchemaScalar " ++ s-  SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaType' inner-  SchemaTry inner -> "SchemaTry " ++ showSchemaType' inner-  SchemaList inner -> "SchemaList " ++ showSchemaType' inner-  SchemaUnion _ -> "SchemaUnion " ++ showSchemaType' schema-  SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema-  where-    showSchemaType' = \case-      SchemaScalar s -> s-      SchemaMaybe inner -> "Maybe " ++ showSchemaType' inner-      SchemaTry inner -> "Try " ++ showSchemaType' inner-      SchemaList inner -> "List " ++ showSchemaType' inner-      SchemaUnion schemas -> "( " ++ mapJoin showSchemaType' " | " schemas ++ " )"-      SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }"-    showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaType' inner--    mapJoin f delim = intercalate delim . map f

@@ -20,7 +20,8 @@ import Data.Aeson.Schema.TH.Parse (GetterExp(..), parseGetterExp) import Data.Aeson.Schema.TH.Unwrap     (FunctorHandler(..), unwrapSchema, unwrapSchemaUsing)-import Data.Aeson.Schema.TH.Utils (reifySchemaName, schemaVToTypeQ)+import Data.Aeson.Schema.TH.Utils (loadSchema, lookupSchema, schemaVToTypeQ)+import Data.Aeson.Schema.Utils.NameLike (NameLike(..))  -- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result -- of the expression.@@ -80,7 +81,7 @@   unless (isNothing start) $     fail $ "Getter expression should start with '.': " ++ ops -  startSchema <- reifySchemaName startSchemaName+  startSchema <- lookupSchema (NameTH startSchemaName) >>= loadSchema    let unwrapResult = unwrapSchema getterOps startSchema       funcResult = unwrapSchemaUsing ApplyFunctors getterOps startSchema

@@ -30,16 +30,15 @@     (SchemaDef(..), SchemaDefObjItem(..), SchemaDefObjKey(..), parseSchemaDef) import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ) import Data.Aeson.Schema.Type-    ( NameLike(..)-    , Schema'(..)+    ( Schema'(..)     , SchemaObjectMapV     , SchemaType'(..)     , SchemaTypeV     , fromSchemaV     , showSchemaTypeV-    , toSchemaObjectV     ) import Data.Aeson.Schema.Utils.Invariant (unreachable)+import Data.Aeson.Schema.Utils.NameLike (NameLike(..))  -- | Defines a QuasiQuoter for writing schemas. --@@ -147,6 +146,7 @@       SchemaTry _ -> True -- even if inner is a non-object schema, it'll still parse to be Nothing       SchemaUnion schemas -> any isValidPhantomSchema schemas       SchemaObject _ -> True+      SchemaInclude _ -> True       _ -> False  -- | Resolve the given keys with the following rules:@@ -181,7 +181,7 @@   SchemaDefMaybe inner   -> SchemaMaybe <$> fromSchemaDefType inner   SchemaDefTry inner     -> SchemaTry <$> fromSchemaDefType inner   SchemaDefList inner    -> SchemaList <$> fromSchemaDefType inner-  SchemaDefInclude other -> toSchemaObjectV <$> reifySchema other+  SchemaDefInclude other -> return $ SchemaInclude $ Left $ NameRef other   SchemaDefUnion schemas -> SchemaUnion . NonEmpty.toList <$> mapM fromSchemaDefType schemas   SchemaDefObj items     -> SchemaObject <$> generateSchemaObjectV items 

@@ -12,7 +12,7 @@  module Data.Aeson.Schema.TH.Unwrap where -import Control.Monad ((>=>))+import Control.Monad ((<=<), (>=>)) import Data.Bifunctor (first) import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH@@ -23,7 +23,7 @@ import Data.Aeson.Schema.TH.Parse     (GetterOperation(..), GetterOps, UnwrapSchema(..), parseUnwrapSchema) import Data.Aeson.Schema.TH.Utils-    (reifySchema, schemaTypeVToTypeQ, schemaVToTypeQ)+    (reifySchema, resolveSchemaType, schemaTypeVToTypeQ, schemaVToTypeQ) import Data.Aeson.Schema.Type     ( Schema'(..)     , SchemaType'(..)@@ -81,7 +81,7 @@  -- | Unwrap the given schema by applying the given operations, using the given 'FunctorHandler'. unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> TypeQ-unwrapSchemaUsing functorHandler getterOps = either fail toResultTypeQ . flip go (NonEmpty.toList getterOps) . toSchemaObjectV+unwrapSchemaUsing functorHandler getterOps = toResultTypeQ <=< flip go (NonEmpty.toList getterOps) . toSchemaObjectV   where     toResultTypeQ :: UnwrapSchemaResult -> TypeQ     toResultTypeQ = \case@@ -97,13 +97,16 @@                 StripFunctors -> ty         in handleFunctor <$> toResultTypeQ schemaResult -    go :: SchemaTypeV -> [GetterOperation] -> Either String UnwrapSchemaResult+    go :: SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult     go schemaType [] = pure $ SchemaResult schemaType-    go schemaType (op:ops) =-      let invalid message = Left $ message ++ ": " ++ showSchemaTypeV schemaType+    go schemaType' (op:ops) = do+      schemaType <- resolveSchemaType schemaType'++      let invalid message = fail $ message ++ ": " ++ showSchemaTypeV schemaType           wrapMaybe = SchemaResultWrapped (ConT ''Maybe)           wrapList = SchemaResultWrapped ListT-      in case op of++      case op of         GetterKey key ->           case schemaType of             SchemaObject pairs ->

@@ -8,42 +8,60 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}  module Data.Aeson.Schema.TH.Utils   ( reifySchema-  , reifySchemaName+  , lookupSchema+  , loadSchema+  , resolveSchemaType   , schemaVToTypeQ   , schemaTypeVToTypeQ   ) where -import Control.Monad (forM, (>=>))+import Control.Applicative (empty)+import Control.Monad (forM) import Data.Bifunctor (bimap)-import Data.Text (Text) import Language.Haskell.TH  import Data.Aeson.Schema.Internal (Object) import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV) import Data.Aeson.Schema.Type-    ( NameLike(..)-    , Schema'(..)+    ( Schema'(..)     , SchemaObjectMapV     , SchemaType'(..)     , SchemaTypeV     , SchemaV     , fromSchemaV+    , toSchemaObjectV     )+import Data.Aeson.Schema.Utils.Invariant (unreachable)+import Data.Aeson.Schema.Utils.NameLike (NameLike(..), resolveName) +{- Loading schema from TH -}+ reifySchema :: String -> Q SchemaV-reifySchema name = lookupTypeName name >>= maybe unknownSchemaErr reifySchemaName-  where-    unknownSchemaErr = fail $ "Unknown schema: " ++ name+reifySchema name = lookupSchema (NameRef name) >>= loadSchema -reifySchemaName :: Name -> Q SchemaV-reifySchemaName = reifySchemaType >=> parseSchema+data ReifiedSchema = ReifiedSchema+  { reifiedSchemaName :: Name+  , reifiedSchemaType :: TypeWithoutKinds+  }++-- | Look up a schema with the given name. Errors if the name doesn't exist or if the name does+-- not refer to a schema.+lookupSchema :: NameLike -> Q ReifiedSchema+lookupSchema nameLike = do+  name <- lookupSchemaName nameLike+  ReifiedSchema name <$> reifySchemaType name   where+    lookupSchemaName = \case+      NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown schema: " ++ name) return+      NameTH name -> return name+     reifySchemaType :: Name -> Q TypeWithoutKinds     reifySchemaType schemaName = reify schemaName >>= \case       TyConI (TySynD _ _ (stripKinds -> ty))@@ -74,33 +92,41 @@       AppT (PromotedT name) _ | name == 'Schema -> True       _ -> False -    parseSchema :: TypeWithoutKinds -> Q SchemaV-    parseSchema ty = maybe (fail $ "Could not parse schema: " ++ show ty) return $ do+loadSchema :: ReifiedSchema -> Q SchemaV+loadSchema ReifiedSchema{reifiedSchemaType} =+  maybe (fail $ "Could not parse schema: " ++ show reifiedSchemaType) return $ parseSchema reifiedSchemaType+  where+    -- should be the inverse of schemaVToTypeQ+    parseSchema :: TypeWithoutKinds -> Maybe SchemaV+    parseSchema ty = do       schemaObjectType <- case ty of-        AppT (PromotedT name) schemaType | name == 'Schema -> Just schemaType-        _ -> Nothing+        AppT (PromotedT name) schemaType | name == 'Schema -> return schemaType+        _ -> empty -      Schema <$> parseSchemaObjectType schemaObjectType+      Schema <$> parseSchemaObjectMap schemaObjectType -    parseSchemaObjectType :: TypeWithoutKinds -> Maybe SchemaObjectMapV-    parseSchemaObjectType schemaObjectType = do+    -- should be the inverse of schemaObjectMapVToTypeQ+    parseSchemaObjectMap :: TypeWithoutKinds -> Maybe SchemaObjectMapV+    parseSchemaObjectMap schemaObjectType = do       schemaObjectListOfPairs <- mapM typeToPair =<< typeToList schemaObjectType       forM schemaObjectListOfPairs $ \(schemaKeyType, schemaTypeType) -> do         schemaKey <- parseSchemaKey schemaKeyType         schemaType <- parseSchemaType schemaTypeType-        Just (schemaKey, schemaType)+        return (schemaKey, schemaType) +    -- should be the inverse of schemaKeyVToTypeQ     parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV     parseSchemaKey = \case       AppT (PromotedT ty) (LitT (StrTyLit key))-        | ty == 'NormalKey -> Just $ NormalKey key-        | ty == 'PhantomKey -> Just $ PhantomKey key-      _ -> Nothing+        | ty == 'NormalKey -> return $ NormalKey key+        | ty == 'PhantomKey -> return $ PhantomKey key+      _ -> empty +    -- should be the inverse of schemaTypeVToTypeQ     parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV     parseSchemaType = \case       AppT (PromotedT name) (ConT inner)-        | name == 'SchemaScalar -> Just $ SchemaScalar $ NameTH inner+        | name == 'SchemaScalar -> return $ SchemaScalar $ NameTH inner        AppT (PromotedT name) inner         | name == 'SchemaMaybe  -> SchemaMaybe <$> parseSchemaType inner@@ -113,10 +139,24 @@             schemas <- typeToList inner             SchemaUnion <$> mapM parseSchemaType schemas -        | name == 'SchemaObject -> SchemaObject <$> parseSchemaObjectType inner+        | name == 'SchemaObject -> SchemaObject <$> parseSchemaObjectMap inner -      _ -> Nothing+      AppT (PromotedT name) (AppT (PromotedT right) (ConT inner))+        | name == 'SchemaInclude+        , right == 'Right+        -> return $ SchemaInclude $ Left $ NameTH inner +      _ -> empty++-- | Resolve SchemaInclude, if present. (Not recursive)+resolveSchemaType :: SchemaTypeV -> Q SchemaTypeV+resolveSchemaType = \case+  SchemaInclude (Left name) -> fmap toSchemaObjectV . loadSchema =<< lookupSchema name+  SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when resolving schema type"+  schemaType -> pure schemaType++{- Splicing schema into TH -}+ schemaVToTypeQ :: SchemaV -> TypeQ schemaVToTypeQ = appT [t| 'Schema |] . schemaObjectMapVToTypeQ . fromSchemaV @@ -139,18 +179,8 @@   SchemaList inner    -> [t| 'SchemaList $(schemaTypeVToTypeQ inner) |]   SchemaUnion schemas -> [t| 'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas) |]   SchemaObject pairs  -> [t| 'SchemaObject $(schemaObjectMapVToTypeQ pairs) |]--resolveName :: NameLike -> Q Name-resolveName = \case-  -- some hardcoded cases-  NameRef "Bool"   -> pure ''Bool-  NameRef "Int"    -> pure ''Int-  NameRef "Double" -> pure ''Double-  NameRef "Text"   -> pure ''Text--  -- general cases-  NameRef name     -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure-  NameTH name      -> pure name+  SchemaInclude (Left name) -> [t| 'SchemaInclude ('Right $(conT . reifiedSchemaName =<< lookupSchema name)) |]+  SchemaInclude (Right _)   -> unreachable "Found 'SchemaInclude Right' when converting to TypeQ"  {- TH utilities -} 

@@ -7,13 +7,14 @@ Defines SchemaType, the AST that defines a JSON schema. -} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-}+{-# LANGUAGE UndecidableInstances #-}  module Data.Aeson.Schema.Type   ( Schema'(..)@@ -21,7 +22,6 @@   , SchemaV   , SchemaTypeV   , SchemaObjectMapV-  , NameLike(..)   , toSchemaObjectV   , fromSchemaV   , showSchemaV@@ -32,6 +32,7 @@   , FromSchema   , IsSchemaType(..)   , IsSchemaObjectMap+  , toSchemaV   ) where  import Data.Kind (Type)@@ -39,15 +40,16 @@ import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) import GHC.TypeLits (Symbol)-import Language.Haskell.TH.Syntax (Lift, Name, nameBase)  import Data.Aeson.Schema.Key     (IsSchemaKey(..), SchemaKey, SchemaKey', SchemaKeyV, showSchemaKeyV) import Data.Aeson.Schema.Utils.All (All(..))+import Data.Aeson.Schema.Utils.Invariant (unreachable)+import Data.Aeson.Schema.Utils.NameLike (NameLike(..), fromName)  -- | The schema definition for a JSON object. data Schema' s ty = Schema (SchemaObjectMap' s ty)-  deriving (Show, Eq, Lift)+  deriving (Show, Eq)  -- | The AST defining a JSON schema. data SchemaType' s ty@@ -57,19 +59,18 @@   | SchemaList (SchemaType' s ty)   | SchemaUnion [SchemaType' s ty] -- ^ @since v1.1.0   | SchemaObject (SchemaObjectMap' s ty)-  deriving (Show, Eq, Lift)+  | SchemaInclude (Either ty (Schema' s ty))+    -- ^ An optimization for including schemas.+    --+    -- Will always be 'Left' when used in a value-level schema and 'Right' when used in+    -- a type-level schema. We can't use a type parameter for this because type synonyms+    -- can't be recursive (e.g. `type Schema = Schema' Symbol Type Schema`).+    --+    -- @since v1.3.2+  deriving (Show, Eq)  type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)] -data NameLike = NameRef String | NameTH Name--instance Eq NameLike where-  ty1 == ty2 = show ty1 == show ty2--instance Show NameLike where-  show (NameRef ty) = ty-  show (NameTH ty) = nameBase ty- {- Value-level schema types -}  type SchemaV = Schema' String NameLike@@ -95,15 +96,18 @@   SchemaList inner -> "SchemaList " ++ showSchemaTypeV' inner   SchemaUnion _ -> "SchemaUnion " ++ showSchemaTypeV' schema   SchemaObject _ -> "SchemaObject " ++ showSchemaTypeV' schema+  SchemaInclude _ -> "SchemaInclude " ++ showSchemaTypeV' schema  showSchemaTypeV' :: SchemaTypeV -> String showSchemaTypeV' = \case-  SchemaScalar ty -> show ty+  SchemaScalar ty -> fromName ty   SchemaMaybe inner -> "Maybe " ++ showSchemaTypeV' inner   SchemaTry inner -> "Try " ++ showSchemaTypeV' inner   SchemaList inner -> "List " ++ showSchemaTypeV' inner   SchemaUnion schemas -> "( " ++ mapJoin showSchemaTypeV' " | " schemas ++ " )"   SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }"+  SchemaInclude (Left name) -> fromName name+  SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when showing schema type"   where     showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaTypeV' inner @@ -129,6 +133,12 @@ type family FromSchema (schema :: Schema) :: SchemaObjectMap where   FromSchema ('Schema schema) = schema +toSchemaV :: forall schema. IsSchemaObjectMap (FromSchema schema) => Proxy schema -> SchemaV+toSchemaV _ = Schema $ toSchemaTypeMapV $ Proxy @(FromSchema schema)++toSchemaTypeMapV :: forall pairs. IsSchemaObjectMap pairs => Proxy pairs -> SchemaObjectMapV+toSchemaTypeMapV _ = mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV+ class IsSchemaType (schemaType :: SchemaType) where   toSchemaTypeV :: Proxy schemaType -> SchemaTypeV @@ -148,7 +158,10 @@   toSchemaTypeV _ = SchemaUnion (mapAll @IsSchemaType @schemas toSchemaTypeV)  instance IsSchemaObjectMap pairs => IsSchemaType ('SchemaObject pairs) where-  toSchemaTypeV _ = SchemaObject (mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV)+  toSchemaTypeV _ = SchemaObject (toSchemaTypeMapV $ Proxy @pairs)++instance IsSchemaObjectMap (FromSchema schema) => IsSchemaType ('SchemaInclude ('Right schema)) where+  toSchemaTypeV _ = toSchemaObjectV $ toSchemaV $ Proxy @schema  type IsSchemaObjectMap (pairs :: SchemaObjectMap) = All IsSchemaObjectPair pairs 

@@ -0,0 +1,36 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Schema.Utils.NameLike+  ( NameLike(..)+  , fromName+  , resolveName+  ) where++import Data.Text (Text)+import Language.Haskell.TH.Syntax (Name, Q, lookupTypeName, nameBase)++data NameLike = NameRef String | NameTH Name++instance Eq NameLike where+  ty1 == ty2 = fromName ty1 == fromName ty2++instance Show NameLike where+  show = show . fromName++fromName :: NameLike -> String+fromName = \case+  NameRef s -> s+  NameTH name -> nameBase name++resolveName :: NameLike -> Q Name+resolveName = \case+  -- some hardcoded cases+  NameRef "Bool"   -> pure ''Bool+  NameRef "Int"    -> pure ''Int+  NameRef "Double" -> pure ''Double+  NameRef "Text"   -> pure ''Text++  -- general cases+  NameRef name     -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure+  NameTH name      -> pure name

@@ -43,16 +43,17 @@ import Data.Aeson.Schema.Key     (IsSchemaKey(..), SchemaKey, SchemaKey'(..), SchemaKeyV, toContext) import Data.Aeson.Schema.Type-    ( NameLike(..)-    , Schema'(..)+    ( Schema'(..)     , SchemaObjectMapV     , SchemaType     , SchemaType'(..)+    , SchemaTypeV     , SchemaV     , showSchemaV     , toSchemaObjectV     ) import Data.Aeson.Schema.Utils.All (All(..))+import Data.Aeson.Schema.Utils.NameLike (NameLike(..), fromName)  data ArbitraryObject where   ArbitraryObject@@ -104,6 +105,8 @@ {- Run time helpers -}  deriving instance Lift NameLike+deriving instance Lift SchemaV+deriving instance Lift SchemaTypeV  genSchema' :: forall schema.   ( ArbitrarySchema ('SchemaObject schema)@@ -134,12 +137,13 @@ getSchemaTypes = getSchemaTypes' . toSchemaObjectV   where     getSchemaTypes' = \case-      SchemaScalar name -> [show name]+      SchemaScalar name -> [fromName name]       SchemaMaybe inner -> "SchemaMaybe" : getSchemaTypes' inner       SchemaTry inner -> "SchemaTry" : getSchemaTypes' inner       SchemaList inner -> "SchemaList" : getSchemaTypes' inner       SchemaUnion schemas -> "SchemaUnion" : concatMap getSchemaTypes' schemas       SchemaObject pairs -> "SchemaObject" : concatMap (getSchemaTypes' . snd) pairs+      SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema"  getObjectSizes :: SchemaV -> [Int] getObjectSizes = getObjectSizes' . toSchemaObjectV@@ -151,6 +155,7 @@       SchemaList inner -> getObjectSizes' inner       SchemaUnion schemas -> concatMap getObjectSizes' schemas       SchemaObject pairs -> length pairs : concatMap (getObjectSizes' . snd) pairs+      SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema"  getObjectDepth :: SchemaV -> Int getObjectDepth = getObjectDepth' . toSchemaObjectV@@ -162,6 +167,7 @@       SchemaList inner -> getObjectDepth' inner       SchemaUnion schemas -> maximum $ map getObjectDepth' schemas       SchemaObject pairs -> 1 + maximum (map (getObjectDepth' . snd) pairs)+      SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema"  tabulate' :: String -> [String] -> Property -> Property #if MIN_VERSION_QuickCheck(2,12,0)

@@ -86,6 +86,11 @@         [schemaRep| { a: #SchemaWithHiddenImport } |]         [r| SchemaObject { "a": { "a": CBool } } |] +  , testCase "Object with an imported schema that itself imports a schema" $+      assertMatches+        [schemaRep| { a: #WithUser } |]+        [r| SchemaObject { "a": { "user": { "name": Text } } } |]+   , testCase "Object with an extended schema" $       assertMatches         [schemaRep| { a: Int, #ExtraSchema } |]

@@ -15,9 +15,7 @@ import Language.Haskell.TH.TestUtils     (MockedMode(..), QMode(..), QState(..), loadNames, runTestQ, runTestQErr) -import Data.Aeson.Schema (schema)-import Data.Aeson.Schema.Internal (showSchemaType)-import Data.Aeson.Schema.Type (ToSchemaObject)+import Data.Aeson.Schema (schema, showSchema) import TestUtils (mkExpQQ) import TestUtils.DeepSeq () @@ -36,6 +34,11 @@ -- Compile above types before reifying $(return []) +type WithUser = [schema| { user: #UserSchema } |]++-- Compile above types before reifying+$(return [])+ qState :: QState 'FullyMocked qState = QState   { mode = MockQ@@ -47,6 +50,7 @@       , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema)       , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema)       , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport)+      , ("WithUser", ''WithUser)       , ("Int", ''Int)       ]   , reifyInfo = $(loadNames@@ -54,6 +58,7 @@       , ''ExtraSchema       , ''ExtraSchema2       , ''SchemaWithHiddenImport+      , ''WithUser       , ''Int       ]     )@@ -65,7 +70,7 @@ schemaRep :: QuasiQuoter schemaRep = mkExpQQ $ \s ->   let schemaType = quoteType schema s-  in [| runTestQ qState (quoteType schema s) `deepseq` showSchemaType @(ToSchemaObject $schemaType) |]+  in [| runTestQ qState (quoteType schema s) `deepseq` showSchema @ $schemaType |]  schemaErr :: QuasiQuoter schemaErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteType schema s) |]