packages feed

aeson-schemas (empty) → 1.0.0

raw patch · 20 files changed

+1950/−0 lines, 20 filesdep +aesondep +aeson-schemasdep +base

Dependencies added: aeson, aeson-schemas, base, bytestring, first-class-families, megaparsec, raw-strings-qq, tasty, tasty-golden, template-haskell, text, th-test-utils, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+## Upcoming++## 1.0.0++Initial release:++* Defining JSON schemas with the `schema` quasiquoter+* Extract JSON data using the `get` quasiquoter+* Extracting intermediate schemas with the `unwrap` quasiquoter+* Include `mkGetter` helper function for generating corresponding `get` and+  `unwrap` expressions.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2019 LeapYear++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,302 @@+# aeson-schemas++A library that extracts information from JSON input using type-level schemas+and quasiquoters, consuming JSON data in a type-safe manner. Better than+`aeson` for decoding nested JSON data that would be cumbersome to represent as+Haskell ADTs.++## Quickstart++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}++import Data.Aeson (eitherDecodeFileStrict)+import Data.Aeson.Schema+import qualified Data.Text as T++-- First, define the schema of the JSON data+type MySchema = [schema|+  {+    users: List {+      id: Int,+      name: Text,+      age: Maybe Int,+      enabled: Bool,+      groups: Maybe List {+        id: Int,+        name: Text,+      },+    },+  }+|]++main :: IO ()+main = do+  -- Then, load data from a file+  obj <- either fail return =<<+    eitherDecodeFileStrict "examples/input.json" :: IO (Object MySchema)++  -- print all the users' ids+  print [get| obj.users[].id |]++  flip mapM_ [get| obj.users |] $ \user -> do+    -- for each user, print out some information+    putStrLn $ "Details for user #" ++ show [get| user.id |] ++ ":"+    putStrLn $ "* Name: " ++ T.unpack [get| user.name |]+    putStrLn $ "* Age: " ++ maybe "N/A" show [get| user.age |]+    case [get| user.groups |] of+      Nothing -> putStrLn "* No groups"+      Just groups -> putStrLn $ "* Groups: " ++ show groups+```++## Features++### Type safe++Since schemas are defined at the type level, parsing JSON objects is checked at+compile-time:++```+-- using schema from above+>>> [get| obj.users[].isEnabled |]++<interactive>:1:6: error:+    • Key 'isEnabled' does not exist in the following schema:+      '[ '("id", 'Data.Aeson.Schema.SchemaInt),+         '("name", 'Data.Aeson.Schema.SchemaText),+         '("age",+           'Data.Aeson.Schema.SchemaMaybe 'Data.Aeson.Schema.SchemaInt),+         '("enabled", 'Data.Aeson.Schema.SchemaBool),+         '("groups",+           'Data.Aeson.Schema.SchemaMaybe+             ('Data.Aeson.Schema.SchemaList+                ('Data.Aeson.Schema.SchemaObject+                   '[ '("id", 'Data.Aeson.Schema.SchemaInt),+                      '("name", 'Data.Aeson.Schema.SchemaText)])))]+    • In the second argument of ‘(.)’, namely ‘getKey @"isEnabled"’+      In the first argument of ‘(<$:>)’, namely+        ‘(id . getKey @"isEnabled")’+      In the first argument of ‘(.)’, namely+        ‘((id . getKey @"isEnabled") <$:>)’+```++### Point-free definitions++You can also use the `get` quasiquoter to define a pointfree function:++```haskell+getNames :: Object MySchema -> [Text]+getNames = [get| .users[].name |]+```++You can use the `unwrap` quasiquoter to define intermediate schemas:++```haskell+type User = [unwrap| MySchema.users[] |]++getUsers :: Object MySchema -> [User]+getUsers = [get| .users[] |]++groupNames :: User -> Maybe [Text]+groupNames = [get| .groups?[].name |]+```++## Advantages over `aeson`++### JSON keys that are invalid Haskell field names++`aeson` does a really good job of encoding and decoding JSON data into Haskell+values. Most of the time, however, you don't deal with encoding/decoding data+types manually, you would derive `Generic` and automatically derive `FromJSON`.+In this case, you would match the constructor field names with the keys in the+JSON data. The problem is that sometimes, JSON data just isn't suited for being+defined as Haskell ADTs. For example, take the following JSON data:++```json+{+    "id": 1,+    "type": "admin",+    "DOB": "5/23/90"+}+```++The `FromJSON` instance for this data is not able to be automatically generated+from `Generic` because the keys are not valid/ideal field names in Haskell:++```haskell+data Result = Result+  { id :: Int+    -- ^ `id` shadows `Prelude.id`+  , type :: String+    -- ^ `type` is a reserved keyword+  , DOB :: String+    -- ^ fields can't start with an uppercase letter+  } deriving (Generic, FromJSON)+```++The only option is to manually define `FromJSON` -- not a bad option, but less+than ideal.++With this library, you don't have these limitations:++```haskell+type Result = [schema|+  {+    id: Int,+    type: Text,+    DOB: Text,+  }+|]+```++### Nested data++What about nested data? If we wanted to represent nested JSON data as Haskell+data types, you would need to define a Haskell data type for each level.++```json+{+    "permissions": [+        {+            "resource": {+                "name": "secretdata.txt",+                "owner": {+                    "username": "john@example.com"+                }+            },+            "access": "READ"+        }+    ]+}+```++```haskell+data Result = Result+  { permissions :: [Permission]+  }+  deriving (Generic, FromJSON)++data Permission = Permission+  { resource :: Resource+  , access :: String+  } deriving (Generic, FromJSON)++data Resource = Resource+  { name :: String+  , owner :: Owner+  } deriving (Generic, FromJSON)++data Owner = Owner+  { username :: String+  }+```++It might be fine for a single example like this, but if you have to parse this+kind of data often, it'll quickly become cumbersome defining multiple data+types for each JSON schema. Additionally, the namespace becomes more polluted+with each data type. For example, if you imported all four of these data types,+you wouldn't be able to use `name`, `username`, `resource`, etc. as variable+names, which can become a pain.++Compared with this library:++```haskell+type Result = [schema|+  {+    permissions: List {+      resource: {+        name: Text,+        owner: {+          username: Text,+        },+      },+      access: Text,+    }+  }+|]+```++The only identifier added to the namespace is `Result`, and parsing out data+is easier and more readable:++```haskell+-- without aeson-schemas+map (username . owner . resource) . permissions++-- with aeson-schemas+[get| result.permissions[].resource.owner.username |]+```++### Duplicate JSON keys++Maybe you have nested data with JSON keys reused:++```json+{+    "_type": "user",+    "node": {+        "name": "John",+        "groups": [+            {+                "_type": "group",+                "node": {+                    "name": "Admin",+                    "writeAccess": true+                }+            }+        ]+    }+}+```++This might be represented as:++```haskell+data UserNode = UserNode+  { _type :: String+  , node :: User+  }++data User = User+  { name :: String+  , groups :: [GroupNode]+  }++data GroupNode = GroupNode+  { _type :: String+  , node :: Group+  }++data Group = Group+  { name :: String+  , writeAccess :: Bool+  }+```++Here, `_type`, `name`, and `node` are repeated. This works with+`{-# LANGUAGE DuplicateRecordFields #-}`, but you wouldn't be able to use the+accessor function anymore:++```+>>> node userNode++<interactive>:1:1: error:+    Ambiguous occurrence 'node'+    It could refer to either the field 'node',+                             defined at MyModule.hs:3:5+                          or the field 'node', defined at MyModule.hs:13:5+```++So you'd have to pattern match out the data you want:++```haskell+let UserNode{node = User{groups = userGroups}} = userNode+    groupNames = map (\GroupNode{node = Group{name = name}} -> name) userGroups+```++With this library, parsing is much more straightforward++```haskell+let groupNames = [get| userNode.node.groups[].node.name |]+```
+ aeson-schemas.cabal view
@@ -0,0 +1,89 @@+cabal-version: >= 1.10++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: bdf6810338fed8e225df138ff9500c8f2f02eea5b75a50a2ad82760e9c737a77++name:           aeson-schemas+version:        1.0.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+                FromJSON instances.+category:       JSON+homepage:       https://github.com/LeapYear/aeson-schemas#readme+bug-reports:    https://github.com/LeapYear/aeson-schemas/issues+author:         Brandon Chinn <brandon@leapyear.io>+maintainer:     Brandon Chinn <brandon@leapyear.io>+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/LeapYear/aeson-schemas++library+  exposed-modules:+      Data.Aeson.Schema+      Data.Aeson.Schema.Internal+      Data.Aeson.Schema.Show+      Data.Aeson.Schema.TH+  other-modules:+      Data.Aeson.Schema.TH.Enum+      Data.Aeson.Schema.TH.Get+      Data.Aeson.Schema.TH.Getter+      Data.Aeson.Schema.TH.Parse+      Data.Aeson.Schema.TH.Schema+      Data.Aeson.Schema.TH.Unwrap+      Data.Aeson.Schema.TH.Utils+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      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+    , megaparsec >=6.0.0 && <7.1+    , template-haskell >=2.12.0.0 && <2.15+    , text >=1.2.2.2 && <1.3+    , unordered-containers >=0.2.8.0 && <0.3+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  default-language: Haskell2010++test-suite aeson-schemas-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      AllTypes+      Nested+      Schema+      Util+      Paths_aeson_schemas+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      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+    , megaparsec >=6.0.0 && <7.1+    , raw-strings-qq >=1.1 && <1.2+    , tasty >=0.11.3 && <1.3+    , tasty-golden >=2.3.1.2 && <2.4+    , template-haskell >=2.12.0.0 && <2.15+    , text >=1.2.2.2 && <1.3+    , th-test-utils >=1.0.0 && <1.1+    , unordered-containers >=0.2.8.0 && <0.3+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  default-language: Haskell2010
+ src/Data/Aeson/Schema.hs view
@@ -0,0 +1,26 @@+{-|+Module      :  Data.Aeson.Schema+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++This module defines a new way of parsing JSON data by defining type-level schemas and+extracting information using quasiquoters that will check if a given query path is+valid at compile-time.+-}++module Data.Aeson.Schema+  ( -- * Types+    Object+  , SchemaType+  , IsSchemaObject+  , SchemaResult+    -- * Quasiquoters for extracting or manipulating JSON data or schemas+  , schema+  , get+  , unwrap+  , mkGetter+  ) where++import Data.Aeson.Schema.Internal+import Data.Aeson.Schema.TH
+ src/Data/Aeson/Schema/Internal.hs view
@@ -0,0 +1,255 @@+{-|+Module      :  Data.Aeson.Schema.Internal+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Internal definitions for declaring JSON schemas.+-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Aeson.Schema.Internal where++import Control.Applicative ((<|>))+import Data.Aeson (FromJSON(..), Value(..))+import Data.Aeson.Types (Parser)+import Data.Bifunctor (first)+import Data.Dynamic (Dynamic, fromDyn, fromDynamic, toDyn)+import Data.HashMap.Strict (HashMap, (!))+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy(..))+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 GHC.Exts (toList)+import GHC.TypeLits+    (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)++import qualified Data.Aeson.Schema.Show as SchemaShow++{- Schema-validated JSON object -}++-- | The object containing JSON data and its schema.+--+-- Has a 'FromJSON' instance, so you can use the usual 'Data.Aeson' decoding functions.+--+-- > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |])+newtype Object (schema :: SchemaType) = UnsafeObject (HashMap Text Dynamic)++-- | A constraint that checks if the given schema is a 'SchemaObject.+type IsSchemaObject schema = (IsSchemaType schema, SchemaResult schema ~ Object schema)++instance IsSchemaObject schema => Show (Object schema) where+  show = showValue @schema++instance IsSchemaObject schema => FromJSON (Object schema) where+  parseJSON = parseValue @schema []++{- Type-level schema definitions -}++-- | The type-level schema definition for JSON data.+--+-- To view a schema for debugging, use 'showSchema'.+data SchemaType+  = SchemaBool+  | SchemaInt+  | SchemaDouble+  | SchemaText+  | SchemaCustom Type+  | SchemaMaybe SchemaType+  | SchemaList SchemaType+  | SchemaObject [(Symbol, SchemaType)]++-- | Convert 'SchemaType' into 'SchemaShow.SchemaType'.+toSchemaTypeShow :: forall (a :: SchemaType). Typeable a => SchemaShow.SchemaType+toSchemaTypeShow = cast $ typeRep (Proxy @a)+  where+    cast tyRep = case splitTypeRep tyRep of+      ("'SchemaBool", _) -> SchemaShow.SchemaBool+      ("'SchemaInt", _) -> SchemaShow.SchemaInt+      ("'SchemaDouble", _) -> SchemaShow.SchemaDouble+      ("'SchemaText", _) -> SchemaShow.SchemaText+      ("'SchemaCustom", [inner]) -> SchemaShow.SchemaCustom $ typeRepName inner+      ("'SchemaMaybe", [inner]) -> SchemaShow.SchemaMaybe $ cast inner+      ("'SchemaList", [inner]) -> SchemaShow.SchemaList $ cast inner+      ("'SchemaObject", [pairs]) -> SchemaShow.SchemaObject $ getSchemaObjectPairs pairs+      _ -> error $ "Unknown schema type: " ++ show tyRep+    getSchemaObjectPairs 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+      _ -> error $ "Unknown list: " ++ show tyRep+    splitTypeRep = first tyConName . splitTyConApp+    typeRepName = tyConName . typeRepTyCon++-- | Pretty show the given SchemaType.+showSchema :: forall (a :: SchemaType). Typeable a => String+showSchema = SchemaShow.showSchemaType $ toSchemaTypeShow @a++{- Conversions from schema types into Haskell types -}++-- | A type family mapping SchemaType to the corresponding Haskell type.+type family SchemaResult (schema :: SchemaType) where+  SchemaResult 'SchemaBool = Bool+  SchemaResult 'SchemaInt = Int+  SchemaResult 'SchemaDouble = Double+  SchemaResult 'SchemaText = Text+  SchemaResult ('SchemaCustom inner) = inner+  SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner)+  SchemaResult ('SchemaList inner) = [SchemaResult inner]+  SchemaResult ('SchemaObject inner) = Object ('SchemaObject inner)++-- | 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)+  default parseValue :: FromJSON (SchemaResult schema) => [Text] -> Value -> Parser (SchemaResult schema)+  parseValue path value = parseJSON value <|> parseFail @schema path value++  showValue :: SchemaResult schema -> String+  default showValue :: Show (SchemaResult schema) => SchemaResult schema -> String+  showValue = show++instance IsSchemaType 'SchemaBool++instance IsSchemaType 'SchemaInt++instance IsSchemaType 'SchemaDouble++instance IsSchemaType 'SchemaText++instance (Show inner, Typeable inner, FromJSON inner) => IsSchemaType ('SchemaCustom inner)++instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaMaybe inner) where+  parseValue path = \case+    Null -> return Nothing+    value -> (Just <$> parseValue @inner path value)++instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaList inner) where+  parseValue path value = case value of+    Array a -> traverse (parseValue @inner path) (toList a)+    _ -> parseFail @('SchemaList inner) path value++instance IsSchemaType ('SchemaObject '[]) where+  parseValue path = \case+    Object _ -> return $ UnsafeObject mempty+    value -> parseFail @('SchemaObject '[]) path value++  showValue _ = "{}"++instance+  ( KnownSymbol key+  , IsSchemaType inner+  , Show (SchemaResult inner)+  , Typeable (SchemaResult inner)+  , IsSchemaObject ('SchemaObject rest)+  , Typeable rest+  ) => IsSchemaType ('SchemaObject ('(key, 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++      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++  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+      value =+        let dynValue = hm ! Text.pack key+        in maybe (show dynValue) show $ fromDynamic @(SchemaResult inner) dynValue+      pair = "\"" ++ key ++ "\": " ++ value++-- | A helper for creating fail messages when parsing a schema.+parseFail :: forall (schema :: SchemaType) m a. (Monad m, Typeable schema) => [Text] -> Value -> m a+parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value)+  where+    msg = if null path+      then "Could not parse schema " ++ schema'+      else "Could not parse path '" ++ path' ++ "' with schema " ++ schema'+    path' = Text.unpack . Text.intercalate "." $ reverse path+    schema' = "`" ++ showSchema @schema ++ "`"+    ellipses n s = if length s > n then take n s ++ "..." else s++{- Lookups within SchemaObject -}++-- | 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+    )+  LookupSchema key schema = TypeError+    (     'Text "Attempted to lookup key '"+    ':<>: 'Text key+    ':<>: 'Text "' in the following schema:"+    ':$$: 'ShowType schema+    )++-- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in+-- its schema.+--+-- > let o = .. :: Object+-- >             ( 'SchemaObject+-- >                '[ '("foo", 'SchemaInt)+-- >                 , '("bar", 'SchemaObject+-- >                      '[ '("name", 'SchemaText)+-- >                       ]+-- >                 , '("baz", 'SchemaMaybe 'SchemaBool)+-- >                 ]+-- >             )+-- >+-- > getKey @"foo" o                  :: Bool+-- > getKey @"bar" o                  :: Object ('SchemaObject '[ '("name", 'SchemaText) ])+-- > getKey @"name" $ getKey @"bar" o :: Text+-- > getKey @"baz" o                  :: Maybe Bool+--+getKey+  :: forall key schema endSchema result+   . ( endSchema ~ LookupSchema key schema+     , result ~ SchemaResult endSchema+     , KnownSymbol key+     , Typeable result+     , Typeable endSchema+     )+  => Object schema+  -> result+getKey (UnsafeObject object) = fromDyn (object ! Text.pack key) badCast+  where+    key = symbolVal (Proxy @key)+    badCast = error $ "Could not load key: " ++ key
+ src/Data/Aeson/Schema/Show.hs view
@@ -0,0 +1,51 @@+{-|+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)++-- | 'Data.Aeson.Schema.Internal.SchemaType', but for printing.+data SchemaType+  = SchemaBool+  | SchemaInt+  | SchemaDouble+  | SchemaText+  | SchemaCustom String+  | SchemaMaybe SchemaType+  | SchemaList SchemaType+  | SchemaObject [(String, SchemaType)]+  deriving (Show)++-- | Pretty show the given SchemaType.+showSchemaType :: SchemaType -> String+showSchemaType schema = case schema of+  SchemaBool -> "SchemaBool"+  SchemaInt -> "SchemaInt"+  SchemaDouble -> "SchemaDouble"+  SchemaText -> "SchemaText"+  SchemaCustom s -> "SchemaCustom " ++ s+  SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaType' inner+  SchemaList inner -> "SchemaList " ++ showSchemaType' inner+  SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema+  where+    showSchemaType' = \case+      SchemaBool -> "Bool"+      SchemaInt -> "Int"+      SchemaDouble -> "Double"+      SchemaText -> "Text"+      SchemaCustom s -> s+      SchemaMaybe inner -> "Maybe " ++ showSchemaType' inner+      SchemaList inner -> "List " ++ showSchemaType' inner+      SchemaObject pairs -> "{" ++ intercalate ", " (map showPair pairs) ++ "}"+    showPair (key, inner) = "\"" ++ key ++ "\": " ++ showSchemaType' inner
+ src/Data/Aeson/Schema/TH.hs view
@@ -0,0 +1,39 @@+{-|+Module      :  Data.Aeson.Schema.TH+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Template Haskell definitions for doing various @aeson-schemas@ operations.++'Data.Aeson.Schema.SchemaType' defines the shape of the JSON object stored in+'Data.Aeson.Schema.Object', and we can use 'Data.Aeson.Schema.Internal.getKey' to lookup a key that+is checked at compile-time to exist in the object.++To make it easier to extract deeply nested keys, this module defines QuasiQuoters that generate the+corresponding 'Data.Aeson.Schema.Internal.getKey' expressions.++In addition to the QuasiQuotes extension, the following extensions will need to be enabled to+use these QuasiQuoters:++* DataKinds+* FlexibleContexts+* TypeFamilies+-}++module Data.Aeson.Schema.TH+  ( schema+  , get+  , unwrap+  -- * Utilities+  , mkGetter+  -- * Helpers for Enum types+  , mkEnum+  , genFromJSONEnum+  ) where++import Data.Aeson.Schema.TH.Enum+import Data.Aeson.Schema.TH.Get+import Data.Aeson.Schema.TH.Getter+import Data.Aeson.Schema.TH.Schema+import Data.Aeson.Schema.TH.Unwrap
+ src/Data/Aeson/Schema/TH/Enum.hs view
@@ -0,0 +1,110 @@+{-|+Module      :  Data.Aeson.Schema.TH.Enum+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Template Haskell functions for Enum types.+-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Schema.TH.Enum+  ( genFromJSONEnum+  , mkEnum+  ) where++import Control.Monad (forM, unless)+import Data.Aeson (FromJSON(..), Value(..))+import Data.Char (toLower)+import Data.Maybe (mapMaybe)+import qualified Data.Text as Text+import Language.Haskell.TH++-- | Make an enum type with the given constructors, that can be parsed from JSON.+--+-- The 'FromJSON' instance will match to a string value matching the constructor name,+-- case-insensitive.+--+-- @+-- mkEnum "State" ["OPEN", "CLOSED"]+--+-- main = print+--   [ decode \"open" :: Maybe State+--   , decode \"OPEN" :: Maybe State+--   , decode \"closed" :: Maybe State+--   , decode \"CLOSED" :: Maybe State+--   ]+-- @+mkEnum :: String -> [String] -> Q [Dec]+mkEnum name vals = do+  (:) <$> dataDec <*> mkFromJSON name' vals'+  where+    name' = mkName name+    vals' = map mkName vals+    dataDec = dataD (pure []) name' [] Nothing (map toCon vals') [derivClause Nothing deriveClasses]+    deriveClasses =+      [ [t| Eq |]+      , [t| Ord |]+      , [t| Show |]+      , [t| Enum |]+      ]+    toCon val = normalC val []++-- | Generate an instance of 'FromJSON' 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 'FromJSON' instance will match to a string value matching the constructor name,+-- case-insensitive.+--+-- @+-- 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+--   ]+-- @+genFromJSONEnum :: Name -> Q [Dec]+genFromJSONEnum name = do+  -- check if 'name' is an Enum+  ClassI _ instances <- reify ''Enum+  let instanceNames = flip mapMaybe instances $ \case+        InstanceD _ _ (AppT _ (ConT n)) _ -> Just n+        _ -> Nothing+  unless (name `elem` instanceNames) $ fail $ "Not an Enum type: " ++ show name++  -- extract constructor names+  cons <- 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+      toMatch con = match (toPattern con) (normalB [| pure $(conE con) |]) []++  t <- newName "t"+  let parseEnum = caseE [| Text.unpack $ Text.toLower $(varE t) |] $+        map toMatch cons ++ [match wildP (normalB $ appE badParse $ varE t) []]++  [d|+    instance FromJSON $(conT name) where+      parseJSON (String $(varP t)) = $parseEnum+      parseJSON v = $badParse v+    |]+  where+    badParse =+      let prefix = litE $ stringL $ "Bad " ++ nameBase name ++ ": "+      in [| fail . ($prefix ++) . show |]
+ src/Data/Aeson/Schema/TH/Get.hs view
@@ -0,0 +1,124 @@+{-|+Module      :  Data.Aeson.Schema.TH.Get+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++The 'get' quasiquoter.+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Schema.TH.Get where++import Control.Monad (unless, (>=>))+import qualified Data.Maybe as Maybe+import GHC.Stack (HasCallStack)+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Syntax (lift)++import Data.Aeson.Schema.Internal (getKey)+import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse)+import Data.Aeson.Schema.TH.Utils (GetterOperation(..), showGetterOps)++-- | Defines a QuasiQuoter for extracting JSON data.+--+-- Example:+--+-- > let Just result = decode ... :: Maybe (Object MySchema)+-- >+-- > [get| result.foo.a |]          :: Int+-- > [get| result.foo.nodes |]      :: [Object (..)]+-- > [get| result.foo.nodes[] |]    :: [Object (..)]+-- > [get| result.foo.nodes[].b |]  :: [Maybe Bool]+-- > [get| result.foo.nodes[].b! |] :: [Bool] -- runtime error if any values are Nothing+-- > [get| result.foo.c |]          :: Text+-- > [get| result.foo.(a,c) |]      :: (Int, Text)+-- > [get| result.foo.[c,d] |]      :: [Text]+-- >+-- > let nodes = [get| result.foo.nodes |]+-- > flip map nodes $ \node -> fromMaybe ([get| node.num |] == 0) [get| node.b |]+-- > map [get| .num |] nodes+--+-- Syntax:+--+-- * @x.y@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the key @y@.+--+-- * @.y@ returns a function that takes in an 'Data.Aeson.Schema.Object' and returns the value of+--   the key @y@.+--+-- * @x.[y,z.a]@ is only valid if @x@ is an 'Data.Aeson.Schema.Object', and if @y@ and @z.a@ have+--   the same type. Returns the value of the operations @y@ and @z.a@ as a list.+--   MUST be the last operation.+--+-- * @x.(y,z.a)@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the+--   operations @y@ and @z.a@ as a tuple.+--   MUST be the last operation.+--+-- * @x!@ is only valid if @x@ is a 'Maybe'. Unwraps the value of @x@ from a 'Just' value and+--   errors (at runtime!) if @x@ is 'Nothing'.+--+-- * @x[]@ is only valid if @x@ is a list. Applies the remaining rules as an 'fmap' over the+--   values in the list, e.g.+--+--     * @x[]@ without anything after is equivalent to @x@+--     * @x[].y@ gets the key @y@ in all the Objects in @x@+--     * @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'.+get :: QuasiQuoter+get = QuasiQuoter+  { quoteExp = parse getterExp >=> generateGetterExp+  , quoteDec = error "Cannot use `get` for Dec"+  , quoteType = error "Cannot use `get` for Type"+  , quotePat = error "Cannot use `get` for Pat"+  }++generateGetterExp :: GetterExp -> ExpQ+generateGetterExp GetterExp{..} = maybe expr (appE expr . varE . mkName) start+  where+    startDisplay = case start of+      Nothing -> ""+      Just s -> if '.' `elem` s then "(" ++ s ++ ")" else s+    expr = mkGetterExp [] getterOps++    applyToNext next = \case+      Right f -> [| $next . $f |]+      Left f -> infixE (Just next) f Nothing++    applyToEach history fromElems elems = do+      val <- newName "v"+      let mkElem ops = appE (mkGetterExp history ops) (varE val)+      lamE [varP val] $ fromElems $ map mkElem elems++    mkGetterExp history = \case+      [] -> [| id |]+      op:ops ->+        let applyToNext' = applyToNext $ mkGetterExp (op:history) ops+            applyToEach' = applyToEach history+            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 [| (<$:>) |]++-- | fromJust with helpful error message+fromJust :: HasCallStack => String -> Maybe a -> a+fromJust msg = Maybe.fromMaybe (error errMsg)+  where+    errMsg = "Called 'fromJust' on null expression" ++ if null msg then "" else ": " ++ msg++-- | fmap specialized to Maybe+(<$?>) :: (a -> b) -> Maybe a -> Maybe b+(<$?>) = (<$>)++-- | fmap specialized to [a]+(<$:>) :: (a -> b) -> [a] -> [b]+(<$:>) = (<$>)
+ src/Data/Aeson/Schema/TH/Getter.hs view
@@ -0,0 +1,85 @@+{-|+Module      :  Data.Aeson.Schema.TH.Getter+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Template Haskell functions for getter functions.+-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Schema.TH.Getter where++import Control.Monad (unless)+import Data.Aeson.Schema.Internal (Object)+import Data.Maybe (isNothing)+import Language.Haskell.TH++import Data.Aeson.Schema.TH.Get (generateGetterExp)+import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse)+import Data.Aeson.Schema.TH.Utils (reifySchema, unwrapType)++-- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result+-- of the expression.+--+-- > mkGetter "Node" "getNodes" ''MySchema ".nodes![]"+-- >+-- > -- is equivalent to:+-- > type Node = [unwrap| MySchema.nodes[] |] -- Object [schema| { b: Maybe Bool } |]+-- > getNodes :: Object MySchema -> [Node]+-- > getNodes = [get| .nodes![] |]+--+-- 'mkGetter' takes four arguments:+--+--   [@unwrapName@] The name of the type synonym to store the unwrapped schema as+--+--   [@funcName@] The name of the getter function+--+--   [@startSchema@] The schema to extract/unwrap from+--+--   [@ops@] The operation to pass to the 'Data.Aeson.Schema.TH.get' and+--           'Data.Aeson.Schema.TH.unwrap' quasiquoters+--+-- There is one subtlety that occurs from the use of the same @ops@ string for both the+-- 'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters:+-- 'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get'+-- applies within the functor. So in the above example, @".nodes![]"@ strips out the list when+-- saving the schema to @Node@, while in the below example, @".nodes!"@ doesn't strip out the list+-- when saving the schema to @Nodes@.+--+-- > mkGetter "Nodes" "getNodes" ''MySchema ".nodes"+-- >+-- > -- is equivalent to:+-- > type Nodes = [unwrap| MySchema.nodes! |] -- [Object [schema| { b: Maybe Bool } |]]+-- > getNodes :: Object MySchema -> Nodes+-- > getNodes = [get| .nodes! |]+--+-- As another example,+--+-- > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name"+-- >+-- > -- is equivalent to:+-- > type MyName = [unwrap| MySchema.f?[].name |] -- Text+-- > getMyBool :: Object MySchema -> Maybe [MyName]+-- > getMyBool = [get| .f?[].name |]+mkGetter :: String -> String -> Name -> String -> DecsQ+mkGetter unwrapName funcName startSchemaName ops = do+  -- TODO: allow (Object schema)+  startSchemaType <- reifySchema startSchemaName++  getterExp'@GetterExp{..} <- parse getterExp ops+  unless (isNothing start) $+    fail $ "Getter expression should start with '.': " ++ ops++  let unwrapResult = unwrapType False getterOps startSchemaType+      funcResult = unwrapType True getterOps startSchemaType+      getterFunc = generateGetterExp getterExp'+      unwrapName' = mkName unwrapName+      funcName' = mkName funcName++  sequence+    [ tySynD unwrapName' [] unwrapResult+    , sigD funcName' [t| Object $(pure startSchemaType) -> $funcResult |]+    , funD funcName' [clause [] (normalB getterFunc) []]+    ]
+ src/Data/Aeson/Schema/TH/Parse.hs view
@@ -0,0 +1,153 @@+{-|+Module      :  Data.Aeson.Schema.TH.Parse+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++Definitions for parsing input text in QuasiQuoters.+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Aeson.Schema.TH.Parse where++#if !MIN_VERSION_megaparsec(6,4,0)+import Control.Applicative (empty)+#endif+import Control.Monad (void)+import Data.Functor (($>))+import Data.List (intercalate)+import Data.Void (Void)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++import Data.Aeson.Schema.TH.Utils (GetterOperation(..), GetterOps)++type Parser = Parsec Void String++#if !MIN_VERSION_megaparsec(7,0,0)+errorBundlePretty :: (Ord t, ShowToken t, ShowErrorComponent e) => ParseError t e -> String+errorBundlePretty = parseErrorPretty+#endif++parse :: Monad m => Parser a -> String -> m a+parse parser s = either (fail . errorBundlePretty) return $ runParser parser s s++{- Parser primitives -}++parseGetterOp :: Parser GetterOperation+parseGetterOp = choice+  [ lexeme "!" $> GetterBang+  , lexeme "[]" $> GetterMapList+  , lexeme "?" $> GetterMapMaybe+  , optional (lexeme ".") *> choice+      [ GetterKey <$> jsonKey+      , fmap GetterList $ between (lexeme "[") (lexeme "]") $ some parseGetterOp `sepBy1` lexeme ","+      , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ some parseGetterOp `sepBy1` lexeme ","+      ]+  ]++parseSchemaDef :: Parser SchemaDef+parseSchemaDef = choice+  [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems+  , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDef)+  , lexeme "List" *> (SchemaDefList <$> parseSchemaDef)+  , SchemaDefType <$> identifier upperChar+  , SchemaDefInclude <$> parseSchemaReference+  ]+  where+    parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme ","+    parseSchemaDefObjItem = choice+      [ SchemaDefObjPair <$> parseSchemaDefPair+      , SchemaDefObjExtend <$> parseSchemaReference+      ] <* space -- allow any trailing spaces+    parseSchemaDefPair = do+      key <- jsonKey+      lexeme ":"+      value <- parseSchemaDef+      return (key, value)+    parseSchemaReference = char '#' *> namespacedIdentifier upperChar++-- | A Haskell identifier, with the given first character.+identifier :: Parser Char -> Parser String+identifier start = (:) <$> start <*> many (alphaNumChar <|> char '\'')++lexeme :: String -> Parser ()+lexeme = void . L.lexeme (L.space space1 (L.skipLineComment "//") empty) . string++-- | Parses `identifier`, but if parentheses are provided, parses a namespaced identifier.+namespacedIdentifier :: Parser Char -> Parser String+namespacedIdentifier start = choice [lexeme "(" *> namespaced <* lexeme ")", ident]+  where+    ident = identifier start+    namespaced = intercalate "." <$> manyAndEnd (identifier upperChar <* lexeme ".") ident+    manyAndEnd p end = choice+      [ try $ p >>= \x -> (x:) <$> manyAndEnd p end+      , (:[]) <$> end+      ]++-- | A string that can be used as a JSON key.+jsonKey :: Parser String+jsonKey = some $ noneOf $ " " ++ schemaChars ++ getChars+  where+    -- characters that cause ambiguity when parsing 'get' expressions+    getChars = "!?[](),."+    -- characters that should not indicate the start of a key when parsing 'schema' definitions+    schemaChars = ":{}#"++{- SchemaDef -}++data SchemaDef+  = SchemaDefType String+  | SchemaDefMaybe SchemaDef+  | SchemaDefList SchemaDef+  | SchemaDefInclude String+  | SchemaDefObj [SchemaDefObjItem]+  deriving (Show)++data SchemaDefObjItem+  = SchemaDefObjPair (String, SchemaDef)+  | SchemaDefObjExtend String+  deriving (Show)++schemaDef :: Parser SchemaDef+schemaDef = do+  space+  def <- parseSchemaDef+  space+  void eof+  return def++{- GetterExp -}++data GetterExp = GetterExp+  { start     :: Maybe String+  , getterOps :: GetterOps+  } deriving (Show)++getterExp :: Parser GetterExp+getterExp = do+  space+  start <- optional $ namespacedIdentifier lowerChar+  getterOps <- some parseGetterOp+  space+  void eof+  return GetterExp{..}++{- UnwrapSchema -}++data UnwrapSchema = UnwrapSchema+  { startSchema :: String+  , getterOps   :: GetterOps+  } deriving (Show)++unwrapSchema :: Parser UnwrapSchema+unwrapSchema = do+  space+  startSchema <- namespacedIdentifier upperChar+  getterOps <- some parseGetterOp+  space+  void eof+  return UnwrapSchema{..}
+ src/Data/Aeson/Schema/TH/Schema.hs view
@@ -0,0 +1,145 @@+{-|+Module      :  Data.Aeson.Schema.TH.Schema+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++The 'schema' quasiquoter.+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Aeson.Schema.TH.Schema (schema) where++import Control.Monad ((<=<), (>=>))+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (mapMaybe)+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import Data.Aeson.Schema.Internal (SchemaType(..))+import Data.Aeson.Schema.TH.Parse+import Data.Aeson.Schema.TH.Utils (fromTypeList, toTypeList)++-- | Defines a QuasiQuoter for writing schemas.+--+-- Example:+--+-- > import Data.Aeson.Schema (schema)+-- >+-- > type MySchema = [schema|+-- >   {+-- >     foo: {+-- >       a: Int,+-- >       // you can add comments like this+-- >       nodes: List {+-- >         b: Maybe Bool,+-- >       },+-- >       c: Text,+-- >       d: Text,+-- >       e: MyType,+-- >       f: Maybe List {+-- >         name: Text,+-- >       },+-- >     },+-- >   }+-- > |]+--+-- Syntax:+--+-- * @{ key: \<schema\>, ... }@ corresponds to a JSON 'Data.Aeson.Schema.Object' with the given key+--   mapping to the given schema.+--+-- * @Bool@, @Int@, @Double@, and @Text@ correspond to the usual Haskell values.+--+-- * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values+--   specified by the provided schema (no parentheses needed).+--+-- * Any other uppercase identifier corresponds to the respective type in scope -- requires a+--   FromJSON instance.+--+-- * @{ key: #Other, ... }@ maps the given key to the @Other@ schema.+--+-- * @{ #Other, ... }@ extends this schema with the @Other@ schema.+schema :: QuasiQuoter+schema = QuasiQuoter+  { quoteExp = error "Cannot use `schema` for Exp"+  , quoteDec = error "Cannot use `schema` for Dec"+  , quoteType = parse schemaDef >=> \case+      SchemaDefObj items -> generateSchemaObject items+      _ -> fail "`schema` definition must be an object"+  , quotePat = error "Cannot use `schema` for Pat"+  }++generateSchemaObject :: [SchemaDefObjItem] -> TypeQ+generateSchemaObject items = [t| 'SchemaObject $(fromItems items) |]+  where+    fromItems = toTypeList <=< resolveParts . concat <=< mapM toParts++generateSchema :: SchemaDef -> TypeQ+generateSchema = \case+  SchemaDefType "Bool"   -> [t| 'SchemaBool |]+  SchemaDefType "Int"    -> [t| 'SchemaInt |]+  SchemaDefType "Double" -> [t| 'SchemaDouble |]+  SchemaDefType "Text"   -> [t| 'SchemaText |]+  SchemaDefType other    -> [t| 'SchemaCustom $(getType other) |]+  SchemaDefMaybe inner   -> [t| 'SchemaMaybe $(generateSchema inner) |]+  SchemaDefList inner    -> [t| 'SchemaList $(generateSchema inner) |]+  SchemaDefInclude other -> getType other+  SchemaDefObj items     -> generateSchemaObject items++{- Helpers -}++getName :: String -> Q Name+getName ty = maybe (fail $ "Unknown type: " ++ ty) return =<< lookupTypeName ty++getType :: String -> TypeQ+getType = getName >=> conT++data KeySource = Provided | Imported+  deriving (Show,Eq)++-- | 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 = \case+  SchemaDefObjPair (k, v) -> pure . tagAs Provided $ [(k, generateSchema v)]+  SchemaDefObjExtend other -> do+    name <- getName other+    reify name >>= \case+      TyConI (TySynD _ _ (AppT (PromotedT ty) inner)) | ty == 'SchemaObject ->+        tagAs Imported <$> fromTypeList inner+      _ -> fail $ "'" ++ show name ++ "' is not a SchemaObject"+  where+    tagAs source = map $ \(k,v) -> (k,v,source)++-- | 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 parts = do+  resolved <- resolveParts' $ HashMap.fromListWith (++) $ map nameAndSource parts+  return $ mapMaybe (alignWithResolved resolved) parts+  where+    nameAndSource (name, _, source) = (name, [source])+    resolveParts' = HashMap.traverseWithKey $ \name sources -> do+      -- invariant: length sources > 0+      let numOf source = length $ filter (== source) sources+      case (numOf Provided, numOf Imported) of+        (1, _) -> return Provided+        (0, 1) -> return Imported+        (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+      in if resolvedSource == source+        then Just (name, ty)+        else Nothing
+ src/Data/Aeson/Schema/TH/Unwrap.hs view
@@ -0,0 +1,61 @@+{-|+Module      :  Data.Aeson.Schema.TH.Unwrap+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++The 'unwrap' quasiquoter.+-}+{-# LANGUAGE RecordWildCards #-}++module Data.Aeson.Schema.TH.Unwrap where++import Control.Monad ((>=>))+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import Data.Aeson.Schema.TH.Parse (UnwrapSchema(..), parse, unwrapSchema)+import Data.Aeson.Schema.TH.Utils (reifySchema, unwrapType)++-- | Defines a QuasiQuoter to extract a schema within the given schema.+--+-- For example:+--+-- > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |]+-- > type MyFoo = [unwrap| MySchema.foo.nodes[] |]+--+-- If the schema is imported qualified, you can use parentheses to distinguish it from the+-- expression:+--+-- > type MyFoo = [unwrap| (MyModule.Schema).foo.nodes[] |]+--+-- You can then use the type alias as usual:+--+-- > parseBar :: MyFoo -> String+-- > parseBar = maybe "null" show . [get| .b |]+-- >+-- > foo = map parseBar [get| result.foo.nodes[] |]+--+-- The syntax is mostly the same as 'Data.Aeson.Schema.TH.get', except the operations run on the+-- type itself, instead of the values. Differences from 'Data.Aeson.Schema.TH.get':+--+-- * @x!@ is only valid if @x@ is a @Maybe a@ type. Returns @a@, the type wrapped in the 'Maybe'.+--+-- * @x?@ is the same as @x!@.+--+-- * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list.+unwrap :: QuasiQuoter+unwrap = QuasiQuoter+  { quoteExp = error "Cannot use `unwrap` for Exp"+  , quoteDec = error "Cannot use `unwrap` for Dec"+  , quoteType = parse unwrapSchema >=> generateUnwrapSchema+  , quotePat = error "Cannot use `unwrap` for Pat"+  }++generateUnwrapSchema :: UnwrapSchema -> TypeQ+generateUnwrapSchema UnwrapSchema{..} = do+  startSchemaName <- maybe unknownSchema return =<< lookupTypeName startSchema+  startSchemaType <- reifySchema startSchemaName+  unwrapType False getterOps startSchemaType+  where+    unknownSchema = fail $ "Unknown schema: " ++ startSchema
+ src/Data/Aeson/Schema/TH/Utils.hs view
@@ -0,0 +1,162 @@+{-|+Module      :  Data.Aeson.Schema.TH.Utils+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Data.Aeson.Schema.TH.Utils where++import Control.Monad ((>=>))+import Data.Bifunctor (second)+import Data.List (intercalate)+import Data.Text (Text)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift)++import Data.Aeson.Schema.Internal (Object, SchemaResult, SchemaType(..))+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+      ty -> error $ "Unknown type: " ++ show ty+    fromPairs pairs = map (second fromSchemaType) $ fromTypeList' pairs++fromTypeList' :: Type -> [(String, Type)]+fromTypeList' = \case+  PromotedNilT -> []+  AppT (AppT PromotedConsT x) xs -> fromTypeTuple x : fromTypeList' xs+  SigT ty _ -> fromTypeList' 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'++toTypeList :: [(String, TypeQ)] -> TypeQ+toTypeList = foldr (consT . pairT) promotedNilT+  where+    pairT (k, v) = [t| '( $(litT $ strTyLit k), $v) |]+    -- nb. https://stackoverflow.com/a/34457936+    consT x xs = appT (appT promotedConsT x) xs++-- | Strip all kind signatures from the given type.+stripSigs :: Type -> Type+stripSigs = \case+  ForallT tyVars ctx ty -> ForallT tyVars ctx (stripSigs ty)+  AppT ty1 ty2 -> AppT (stripSigs ty1) (stripSigs ty2)+  SigT ty _ -> stripSigs ty+  InfixT ty1 name ty2 -> InfixT (stripSigs ty1) name (stripSigs ty2)+  UInfixT ty1 name ty2 -> UInfixT (stripSigs ty1) name (stripSigs ty2)+  ParensT ty -> ParensT (stripSigs ty)+  ty -> ty++reifySchema :: Name -> TypeQ+reifySchema = reify >=> \case+  TyConI (TySynD _ _ ty) -> pure $ stripSigs ty+  info -> fail $ "Unknown reified schema: " ++ show info++-- | Unwrap the given type using the given getter operations.+--+-- Accepts Bool for whether to maintain functor structure (True) or strip away functor applications+-- (False).+unwrapType :: Bool -> GetterOps -> Type -> TypeQ+unwrapType _ [] = fromSchemaType+  where+    fromSchemaType schema = case schema of+      AppT (PromotedT ty) inner+        | ty == 'SchemaCustom -> [t| SchemaResult $(pure schema) |]+        | ty == 'SchemaMaybe -> [t| Maybe $(fromSchemaType inner) |]+        | ty == 'SchemaList -> [t| [$(fromSchemaType inner)] |]+        | ty == 'SchemaObject -> [t| Object $(pure schema) |]+      PromotedT ty+        | ty == 'SchemaBool -> [t| Bool |]+        | ty == 'SchemaInt -> [t| Int |]+        | ty == 'SchemaDouble -> [t| Double |]+        | ty == 'SchemaText -> [t| Text |]+      AppT t1 t2 -> appT (fromSchemaType t1) (fromSchemaType t2)+      TupleT _ -> pure schema+      _ -> fail $ "Could not convert schema: " ++ showSchemaType schema+unwrapType keepFunctor (op:ops) = \case+  schema@(AppT (PromotedT ty) inner) ->+    case op of+      GetterKey key | ty == 'SchemaObject ->+        case lookup key (getObjectSchema inner) of+          Just schema' -> unwrapType' ops schema'+          Nothing -> fail $ "Key '" ++ key ++ "' does not exist in schema: " ++ showSchemaType schema+      GetterKey key -> fail $ "Cannot get key '" ++ key ++ "' in schema: " ++ showSchemaType schema+      GetterList elems | ty == 'SchemaObject -> do+        (elem':rest) <- mapM (`unwrapType'` schema) elems+        if all (== elem') rest+          then unwrapType' ops elem'+          else fail $ "List contains different types with schema: " ++ showSchemaType schema+      GetterList _ -> fail $ "Cannot get keys in schema: " ++ showSchemaType schema+      GetterTuple elems | ty == 'SchemaObject ->+        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 -> fail $ "Cannot use `!` operator on schema: " ++ showSchemaType schema+      GetterMapMaybe | ty == 'SchemaMaybe -> 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+  -- 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]+  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+    withFunctor f = if keepFunctor then appT f else id++{- GetterOps -}++type GetterOps = [GetterOperation]++data GetterOperation+  = GetterKey String+  | GetterList [GetterOps]+  | GetterTuple [GetterOps]+  | GetterBang+  | GetterMapList+  | GetterMapMaybe+  deriving (Show,Lift)++showGetterOps :: GetterOps -> String+showGetterOps = concatMap showGetterOp+  where+    showGetterOp = \case+      GetterKey key -> '.':key+      GetterList elems -> ".[" ++ intercalate "," (map showGetterOps elems) ++ "]"+      GetterTuple elems -> ".(" ++ intercalate "," (map showGetterOps elems) ++ ")"+      GetterBang -> "!"+      GetterMapList -> "[]"+      GetterMapMaybe -> "?"
+ test/AllTypes.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module AllTypes where++import Data.Aeson (FromJSON(..), withText)+import Data.Aeson.Schema+import Data.Aeson.Schema.TH (mkEnum, mkGetter)+import qualified Data.Text as Text++import Util (getMockedResult)++{- Greeting enum -}++mkEnum "Greeting" ["HELLO", "GOODBYE"]++{- Coordinate scalar -}++newtype Coordinate = Coordinate (Int, Int)+  deriving (Show)++instance FromJSON Coordinate where+  parseJSON = withText "Coordinate" $ \s ->+    case map (read . Text.unpack) $ Text.splitOn "," s of+      [x, y] -> return $ Coordinate (x, y)+      _ -> fail $ "Bad Coordinate: " ++ Text.unpack s++{- AllTypes result -}++type Schema = [schema|+  {+    bool: Bool,+    int: Int,+    int2: Int,+    double: Double,+    text: Text,+    scalar: Coordinate,+    enum: Greeting,+    maybeObject: Maybe {+      text: Text,+    },+    maybeObjectNull: Maybe {+      text: Text,+    },+    maybeList: Maybe List {+      text: Text,+    },+    maybeListNull: Maybe List {+      text: Text,+    },+    // this is a comment+    list: List {+      type: Text,+      maybeBool: Maybe Bool,+      maybeInt: Maybe Int,+      maybeNull: Maybe Bool,+    },+    nonexistent: Maybe Text,+    // future_key: Int,+  }+|]++result :: Object Schema+result = $(getMockedResult "test/all_types.json")++{- AllTypes getters -}++mkGetter "ListItem" "getList" ''AllTypes.Schema ".list[]"
+ test/Main.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++import Data.Aeson.Schema (Object, get, unwrap)+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import Language.Haskell.TH.TestUtils (tryQErr')+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Golden (goldenVsString)+import Text.RawString.QQ (r)++import qualified AllTypes+import qualified Nested+import Schema+import Util++allTypes :: Object AllTypes.Schema+allTypes = AllTypes.result++main :: IO ()+main = defaultMain $ testGroup "aeson-schemas"+  [ testGetterExp+  , testFromObjectAllTypes+  , testFromObjectNested+  , testFromObjectNamespaced+  , testUnwrapSchema+  , testSchemaDef+  , testMkGetter+  ]++goldens' :: String -> String -> TestTree+goldens' name = goldenVsString name fp . pure . ByteString.pack+  where+    fp = "test/goldens/" ++ name ++ ".golden"++goldens :: Show s => String -> s -> TestTree+goldens name = goldens' name . show++testGetterExp :: TestTree+testGetterExp = testGroup "Test getter expressions"+  [ goldens "bool"                     [get| allTypes.bool                  |]+  , goldens "lambda_bool"             ([get| .bool |] allTypes)+  , goldens "int"                      [get| allTypes.int                   |]+  , goldens "int_int2"                 [get| allTypes.[int,int2]            |]+  , goldens "double"                   [get| allTypes.double                |]+  , goldens "bool_int_double"          [get| allTypes.(bool,int,double)     |]+  , goldens "text"                     [get| allTypes.text                  |]+  , goldens "scalar"                   [get| allTypes.scalar                |]+  , goldens "enum"                     [get| allTypes.enum                  |]+  , goldens "maybeObj"                 [get| allTypes.maybeObject           |]+  , goldens "maybeObj_bang"            [get| allTypes.maybeObject!          |]+  , goldens "maybeObj_text"            [get| allTypes.maybeObject?.text     |]+  , goldens "maybeObj_bang_text"       [get| allTypes.maybeObject!.text     |]+  , goldens "maybeObjNull"             [get| allTypes.maybeObjectNull       |]+  , goldens "maybeObjNull_text"        [get| allTypes.maybeObjectNull?.text |]+  , goldens "maybeList"                [get| allTypes.maybeList             |]+  , goldens "maybeList_bang"           [get| allTypes.maybeList!            |]+  , goldens "maybeList_bang_list"      [get| allTypes.maybeList![]          |]+  , goldens "maybeList_bang_list_text" [get| allTypes.maybeList![].text     |]+  , goldens "maybeList_list"           [get| allTypes.maybeList?[]          |]+  , goldens "maybeList_list_text"      [get| allTypes.maybeList?[].text     |]+  , goldens "maybeListNull"            [get| allTypes.maybeListNull         |]+  , goldens "maybeListNull_list"       [get| allTypes.maybeListNull?[]      |]+  , goldens "maybeListNull_list_text"  [get| allTypes.maybeListNull?[].text |]+  , goldens "list"                     [get| allTypes.list                  |]+  , goldens "list_explicit"            [get| allTypes.list[]                |]+  , goldens "list_type"                [get| allTypes.list[].type           |]+  , goldens "list_maybeBool"           [get| allTypes.list[].maybeBool      |]+  , goldens "list_maybeInt"            [get| allTypes.list[].maybeInt       |]+  , goldens "nonexistent"              [get| allTypes.nonexistent           |]+  -- bad 'get' expressions+  , goldens' "maybeListNull_bang" $(getError [get| (AllTypes.result).maybeListNull! |])+#if MIN_VERSION_megaparsec(7,0,0)+  , goldens' "get_empty" $(tryQErr' $ showGet "")+  , goldens' "get_just_start" $(tryQErr' $ showGet "allTypes")+#endif+  , goldens' "get_ops_after_tuple" $(tryQErr' $ showGet "allTypes.(bool,int).foo")+  , goldens' "get_ops_after_list" $(tryQErr' $ showGet "allTypes.[int,int2].foo")+  ]++testFromObjectAllTypes :: TestTree+testFromObjectAllTypes =+  goldens "from_object_all_types" $ map fromObj [get| allTypes.list |]+  where+    fromObj o = case Text.unpack [get| o.type |] of+      "bool" -> show [get| o.maybeBool! |]+      "int"  -> show [get| o.maybeInt!  |]+      "null" -> show [get| o.maybeNull  |]+      _ -> error "unreachable"++testFromObjectNested :: TestTree+testFromObjectNested = goldens "from_object_nested" $ map fromObj [get| (Nested.result).list |]+  where+    fromObj obj = case [get| obj.a |] of+      Just field -> [get| field.b |]+      Nothing    -> [get| obj.b |]++testFromObjectNamespaced :: TestTree+testFromObjectNamespaced = goldens "from_object_namespaced" $+  map fromAllTypes [get| allTypes.list |]+  ++ map fromNested [get| (Nested.result).list |]+  where+    fromAllTypes o = Text.unpack [get| o.type |]+    fromNested o = show [get| o.b |]++type NestedObject = [unwrap| (Nested.Schema).list[] |]++parseNestedObject :: NestedObject -> Int+parseNestedObject obj = fromMaybe [get| obj.b |] [get| obj.a?.b |]++nestedList :: [NestedObject]+nestedList = [get| (Nested.result).list[] |]++testUnwrapSchema :: TestTree+testUnwrapSchema = testGroup "Test unwrapping schemas"+  [ goldens' "unwrap_schema" $(showUnwrap "(Nested.Schema).list[]")+  , goldens "unwrap_schema_nested_list" nestedList+  , goldens "unwrap_schema_nested_object" $ map parseNestedObject nestedList+  -- bad unwrap types+  , goldens' "unwrap_schema_bad_bang" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]!")+  , 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")+  ]++testSchemaDef :: TestTree+testSchemaDef = testGroup "Test generating schema definitions"+  [ goldens' "schema_def_bool" $(showSchema [r| { a: Bool } |])+  , goldens' "schema_def_int" $(showSchema [r| { a: Int } |])+  , goldens' "schema_def_double" $(showSchema [r| { foo123: Double } |])+  , goldens' "schema_def_text" $(showSchema [r| { some_text: Text } |])+  , goldens' "schema_def_custom" $(showSchema [r| { status: Status } |])+  , goldens' "schema_def_maybe" $(showSchema [r| { a: Maybe Int } |])+  , goldens' "schema_def_list" $(showSchema [r| { a: List Int } |])+  , goldens' "schema_def_obj" $(showSchema [r| { a: { b: Int } } |])+  , goldens' "schema_def_maybe_obj" $(showSchema [r| { a: Maybe { b: Int } } |])+  , goldens' "schema_def_list_obj" $(showSchema [r| { a: List { b: Int } } |])+  , 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) } |])+  -- bad schema definitions+  , goldens' "schema_def_duplicate" $(tryQErr' $ showSchema [r| { a: Int, a: 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 } |])+  ]++testMkGetter :: TestTree+testMkGetter = testGroup "Test the mkGetter helper"+  [ goldens "getter_all_types_list" list+  , goldens "getter_all_types_list_item" $ map getType list+  ]+  where+    list :: [AllTypes.ListItem]+    list = AllTypes.getList AllTypes.result++    getType :: AllTypes.ListItem -> Text.Text+    getType = [get| .type |]
+ test/Nested.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Nested where++import Data.Aeson.Schema++import Util (getMockedResult)++type Schema = [schema|+  {+    list: List {+      a: Maybe {+        b: Int,+      },+      b: Int,+    },+  }+|]++result :: Object Schema+result = $(getMockedResult "test/nested.json")
+ test/Schema.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}++module Schema where++import Data.Aeson (FromJSON)+import Data.Aeson.Schema (schema)++newtype Status = Status Int+  deriving (Show,FromJSON)++type UserSchema = [schema| { name: Text } |]+type MySchema = [schema| { extra: Text } |]+type MySchema2 = [schema| { extra: Maybe Text } |]
+ test/Util.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Util where++import Control.Exception (SomeException, try)+import Control.Monad ((<=<))+import Data.Aeson (eitherDecode)+import qualified Data.ByteString.Lazy as ByteStringL+import qualified Data.ByteString.Lazy.Char8 as Char8L+import Data.List (isPrefixOf)+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Syntax (lift)++import Data.Aeson.Schema (Object, get, schema, unwrap)+import qualified Data.Aeson.Schema.Internal as Internal++getMockedResult :: FilePath -> ExpQ+getMockedResult fp = do+  contents <- runIO $ ByteStringL.readFile fp+  [| either error id $ eitherDecode $ Char8L.pack $(lift $ Char8L.unpack contents) |]++-- | Show the expression generated by passing the given string to the 'get' quasiquoter.+showGet :: String -> ExpQ+showGet = lift . pprint <=< quoteExp get++-- | Show the type generated by passing the given string to the 'unwrap' quasiquoter.+showUnwrap :: String -> ExpQ+showUnwrap = showType <=< quoteType unwrap++-- | Show the type generated by passing the given string to the 'schema' quasiquoter.+showSchema :: String -> ExpQ+showSchema = showSchemaType <=< quoteType schema++showType :: Type -> ExpQ+showType = \case+  AppT (ConT name) schema' | name == ''Object -> [| "Object (" ++ $(showSchemaType schema') ++ ")" |]+  ty -> lift $ pprint ty++showSchemaType :: Type -> ExpQ+showSchemaType = appTypeE [| Internal.showSchema |] . pure++-- | Return the 'error' message thrown when evaluating the given expresssion.+getError :: a -> ExpQ+getError x = runIO (try $ x `seq` pure ()) >>= \case+  Right _ -> fail "'getError' expression unexpectedly succeeded"+  Left e -> lift . unlines . stripCallStack . lines . show $ (e :: SomeException)+  where+    stripCallStack [] = []+    stripCallStack (l:ls) = if "CallStack" `isPrefixOf` l+      then []+      else l : stripCallStack ls