json-spec 1.4.0.1 → 2.0.0.0

raw patch · 19 files changed

+2531/−912 lines, 19 filesdep +megaparsecdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• README.md +9/−3
• json-spec.cabal +71/−12
• src/Data/JsonSpec.hs +26/−67
• src/Data/JsonSpec/Codec/Tuple.hs +95/−0
• src/Data/JsonSpec/Codec/Tuple/Decode.hs +159/−0
• src/Data/JsonSpec/Codec/Tuple/Encode.hs +135/−0
• src/Data/JsonSpec/Codec/Tuple/Internal.hs +272/−0
• src/Data/JsonSpec/Decode.hs +0/−164
• src/Data/JsonSpec/Encode.hs +0/−146
• src/Data/JsonSpec/Language/Parser.hs +413/−0
• src/Data/JsonSpec/Language/QQ.hs +140/−0
• src/Data/JsonSpec/Spec.hs +172/−346
• test/jsonlet.hs +122/−0
• test/jsonlet2.hs +68/−0
• test/jsonlet3.hs +99/−0
• test/jsonspec.hs +206/−158
• test/language.hs +506/−0
• test/stable-environment.hs +18/−16

@@ -1,5 +1,25 @@ # Changelog +## 2.0.0.0++Breaking release: the specification DSL and tuple codec API were+reworked.++- Add a textual JsonSpec language with parser+  (`Data.JsonSpec.Language.Parser`), Template Haskell quasiquoter+  (`Data.JsonSpec.Language.QQ`), and language documentation+  (`docs/language-spec.md`). Specs can use open `type` and closed+  `module` bindings, `let` frames, and backtick-escaped identifiers+  when a name collides with a keyword.+- Split tuple-based encoding/decoding out of `Data.JsonSpec` into+  `Data.JsonSpec.Codec.Tuple` (`SpecJson`, `TupleEncoding`,+  `TupleDecoding`, `Field`, etc.).+- Rename JSON acronyms to camel case (for example `SpecJSON` →+  `SpecJson`, `toJSONStructure` → `toJsonStructure`,+  `JSONStructure` → `JsonStructure`).+- Replace the old encode/decode class surface with a `Module`-centered+  binding model (`Module`, `BindingSpec`, `JsonModule`, `:=`, `::=`).+ ## 1.4.0.1  - Relax the `aeson` upper bound to allow 2.3.x.

@@ -41,26 +41,32 @@   , lastLogin :: UTCTime   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON User)+  deriving (ToJSON, FromJSON) via (SpecJson User) instance HasJsonEncodingSpec User where   type EncodingSpec User =     JsonObject '[       Required "name" JsonString,       Required "last-login" JsonDateTime     ]-  toJSONStructure user =+instance TupleEncoding User where+  toJsonStructure user =     (Field @"name" (name user),     (Field @"last-login" (lastLogin user),     ())) instance HasJsonDecodingSpec User where   type DecodingSpec User = EncodingSpec User-  fromJSONStructure+instance TupleDecoding User where+  fromJsonStructure       (Field @"name" name,       (Field @"last-login" lastLogin,       ()))     =       pure User { name , lastLogin } ```++Import `"Data.JsonSpec"` for the specification language and+`"Data.JsonSpec.Codec.Tuple"` for the tuple codec (`Field`, `TupleEncoding`,+`SpecJson`, etc.).  For more examples, take a look at the test suite. 

@@ -1,9 +1,24 @@ cabal-version:       3.0 name:                json-spec-version:             1.4.0.1+version:             2.0.0.0 synopsis:            Type-level JSON specification maintainer:          rick@owensmurray.com-description:         See the README at: https://github.com/owensmurray/json-spec#json-spec+description:+  See the README at: https://github.com/owensmurray/json-spec#json-spec++  = Modules++  ["Data.JsonSpec"]+    Type-level JSON specifications.++  ["Data.JsonSpec.Codec.Tuple"]+    Encode and decode via nested tuples.++  ["Data.JsonSpec.Language.Parser"]+    Parser for the JsonSpec textual language.++  ["Data.JsonSpec.Language.QQ"]+    Quasi-quoters for the JsonSpec language. homepage:            https://github.com/owensmurray/json-spec license:             MIT license-file:        LICENSE@@ -18,13 +33,15 @@  common dependencies   build-depends:-    , aeson      >= 2.2.1.0  && < 2.4-    , base       >= 4.19.0.0 && < 4.23-    , containers >= 0.6.8    && < 0.9-    , scientific >= 0.3.7.0  && < 0.4-    , text       >= 2.1      && < 2.2-    , time       >= 1.9.3    && < 1.16-    , vector     >= 0.13.0.0 && < 0.14+    , aeson            >= 2.2.1.0  && < 2.4+    , base             >= 4.19.0.0 && < 4.23+    , containers       >= 0.6.8    && < 0.9+    , megaparsec       >= 9.6.0    && < 9.9+    , scientific       >= 0.3.7.0  && < 0.4+    , template-haskell >= 2.21.0.0 && < 2.25+    , text             >= 2.1      && < 2.2+    , time             >= 1.9.3    && < 1.16+    , vector           >= 0.13.0.0 && < 0.14  common warnings   ghc-options:@@ -38,10 +55,14 @@   import: dependencies, warnings   exposed-modules:     Data.JsonSpec-  other-modules:       -    Data.JsonSpec.Encode-    Data.JsonSpec.Decode+    Data.JsonSpec.Language.Parser+    Data.JsonSpec.Language.QQ+    Data.JsonSpec.Codec.Tuple+  other-modules:     Data.JsonSpec.Spec+    Data.JsonSpec.Codec.Tuple.Internal+    Data.JsonSpec.Codec.Tuple.Decode+    Data.JsonSpec.Codec.Tuple.Encode   -- other-extensions:       hs-source-dirs:      src   default-language:    Haskell2010@@ -70,3 +91,41 @@     , bytestring >= 0.12.0.2 && < 0.13     , hspec      >= 2.11.0   && < 2.12     , om-show    >= 0.1.2.9  && < 0.2++test-suite language+  import: dependencies, warnings+  main-is: language.hs+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-language: Haskell2010+  build-depends:+    , json-spec+    , hspec >= 2.11.0 && < 2.12+++test-suite json-let+  import: dependencies, warnings+  main-is: jsonlet.hs+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-language: Haskell2010+  build-depends:+    , json-spec++test-suite json-let2+  import: dependencies, warnings+  main-is: jsonlet2.hs+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-language: Haskell2010+  build-depends:+    , json-spec++test-suite json-let3+  import: dependencies, warnings+  main-is: jsonlet3.hs+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-language: Haskell2010+  build-depends:+    , json-spec

@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExplicitNamespaces #-}  {-|+  Description : Type-level JSON specifications+   This module provides a way to specify the shape of your JSON data at   the type level. @@ -13,20 +13,23 @@   >   , lastLogin :: UTCTime   >   }   >   deriving stock (Show, Eq)-  >   deriving (ToJSON, FromJSON) via (SpecJSON User)+  >   deriving (ToJSON, FromJSON) via (SpecJson User)   > instance HasJsonEncodingSpec User where   >   type EncodingSpec User =-  >     JsonObject '[-  >       Required "name" JsonString,-  >       Required "last-login" JsonDateTime-  >     ]-  >   toJSONStructure user =+  >     'Module+  >       (JsonObject '[+  >         Required "name" JsonString,+  >         Required "last-login" JsonDateTime+  >       ])+  > instance TupleEncoding User where+  >   toJsonStructure user =   >     (Field @"name" (name user),   >     (Field @"last-login" (lastLogin user),   >     ()))   > instance HasJsonDecodingSpec User where   >   type DecodingSpec User = EncodingSpec User-  >   fromJSONStructure+  > instance TupleDecoding User where+  >   fromJsonStructure   >       (Field @"name" name,   >       (Field @"last-login" lastLogin,   >       ()))@@ -66,78 +69,34 @@   is still pretty new, but it at least includes OpenApi compatibility   (i.e. ToSchema instances) and Elm code generation. +  For the tuple-based encoding/decoding interpretation of a+  'Specification', see "Data.JsonSpec.Codec.Tuple". -} module Data.JsonSpec (   -- * Writing specifications   Specification(..),+  Module(..),+  BindingSpec(..),   (:::),   (::?),+  (:=),+  (::=),   FieldSpec(..), -  -- * Encoding/decoding via a Specification+  -- * Associating a type with a Module   HasJsonEncodingSpec(..),   HasJsonDecodingSpec(..),-  SpecJSON(..),-  Tag(..),-  Field(..),-  unField,-  Ref(..),--  -- * Direct encoding/decoding-  eitherDecode,-  encode,--  -- * Other stuff-  {-|-    The items in this section are mainly exported because once in a-    while you might need to include them in a type signature, but they-    are not intended to be used directly.-  -}-  JSONStructure,-  StructureFromJSON,-  StructureToJSON, ) where -import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))-import Data.JsonSpec.Decode-  ( HasJsonDecodingSpec(DecodingSpec, fromJSONStructure)-  , StructureFromJSON(reprParseJSON), eitherDecode-  )-import Data.JsonSpec.Encode-  ( HasJsonEncodingSpec(EncodingSpec, toJSONStructure)-  , StructureToJSON(reprToJSON), encode-  ) import Data.JsonSpec.Spec-  ( Field(Field), FieldSpec(Optional, Required), Ref(Ref, unRef)+  ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required)+  , HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec)+  , Module(Module)   , Specification     ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither-    , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef-    , JsonString, JsonTag+    , JsonInt, JsonLet, JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw+    , JsonRef, JsonString, JsonTag     )-  , Tag(Tag), (:::), (::?), JSONStructure, unField+  , type (:::), type (::=), type (::?), type (:=)   )-import Prelude ((.), (<$>), (=<<))--{- |-  Helper for defining 'ToJSON' and 'FromJSON' instances based on-  'HasEncodingJsonSpec'.--  Use with -XDerivingVia like:--  > data MyObj = MyObj-  >   { foo :: Int-  >   , bar :: Text-  >   }-  >   deriving (ToJSON, FromJSON) via (SpecJSON MyObj)-  > instance HasEncodingSpec MyObj where ...-  > instance HasDecodingSpec MyObj where ...--}-newtype SpecJSON a = SpecJSON {unSpecJson :: a}-instance (StructureToJSON (JSONStructure (EncodingSpec a)), HasJsonEncodingSpec a) => ToJSON (SpecJSON a) where-  toJSON = reprToJSON . toJSONStructure . unSpecJson-instance (StructureFromJSON (JSONStructure (DecodingSpec a)), HasJsonDecodingSpec a) => FromJSON (SpecJSON a) where-  parseJSON v =-    SpecJSON <$>-      (fromJSONStructure =<< reprParseJSON v)- 

@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+  Description : Encode and decode via nested tuples++  Tuple-based interpretation of 'Specification'. The purpose of this+  module is to encode and decode Haskell values to and from Aeson+  'Value's, using a nested tuple structure as the intermediate+  representation.++  A type-level 'Specification' is translated into a canonical nested+  tuple type—an ordinary, inhabited Haskell type whose values you can+  construct and pattern-match on. Encoding and decoding then amount to+  converting between your domain types and that tuple structure, and+  between the tuple structure and an Aeson 'Value'.+-}+module Data.JsonSpec.Codec.Tuple (+  -- * Direct encoding/decoding+  {-|+    Encode or decode a value directly to or from an Aeson 'Value',+    given a 'Specification' and the corresponding tuple conversion.+  -}+  eitherDecode,+  encode,++  -- * Interacting with Aeson+  {-|+    'SpecJson' is the main way to plug a 'Specification' into Aeson's+    'ToJSON' / 'FromJSON' ecosystem (typically via @DerivingVia@).+  -}+  SpecJson(..),++  -- * Tuple encoding and decoding+  {-|+    'TupleEncoding' and 'TupleDecoding' convert between your Haskell+    types and the nested tuple structure that backs 'SpecJson' (and+    the direct encode/decode helpers above).+  -}+  TupleEncoding(..),+  TupleDecoding(..),+  Tag(..),+  Field(..),+  unField,+  Ref(..),++  -- * Other stuff+  {-|+    The items in this section are mainly exported because once in a+    while you might need to include them in a type signature, but they+    are not intended to be used directly.+  -}+  JsonStructure,+  StructureFromJson,+  StructureToJson,+) where++import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.JsonSpec.Codec.Tuple.Decode+  ( StructureFromJson(reprParseJson), TupleDecoding(fromJsonStructure)+  , eitherDecode+  )+import Data.JsonSpec.Codec.Tuple.Encode+  ( StructureToJson(reprToJson), TupleEncoding(toJsonStructure), encode+  )+import Data.JsonSpec.Codec.Tuple.Internal+  ( Field(Field), Ref(Ref, unRef), Tag(Tag), JsonStructure, unField+  )+import Data.JsonSpec.Spec+  ( HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec)+  )+import Prelude ((.), (<$>), (=<<))++{- |+  Helper for defining 'ToJSON' and 'FromJSON' instances based on+  'HasEncodingJsonSpec'.++  Use with -XDerivingVia like:++  > data MyObj = MyObj+  >   { foo :: Int+  >   , bar :: Text+  >   }+  >   deriving (ToJSON, FromJSON) via (SpecJson MyObj)+  > instance HasEncodingSpec MyObj where ...+  > instance HasDecodingSpec MyObj where ...+-}+newtype SpecJson a = SpecJson {unSpecJson :: a}+instance (StructureToJson (JsonStructure (EncodingSpec a)), TupleEncoding a) => ToJSON (SpecJson a) where+  toJSON = reprToJson . toJsonStructure . unSpecJson+instance (StructureFromJson (JsonStructure (DecodingSpec a)), TupleDecoding a) => FromJSON (SpecJson a) where+  parseJSON v =+    SpecJson <$>+      (fromJsonStructure =<< reprParseJson v)

@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Tuple-structure decoding for specs. -}+module Data.JsonSpec.Codec.Tuple.Decode (+  StructureFromJson(..),+  TupleDecoding(..),+  eitherDecode,+) where++import Control.Applicative (Alternative((<|>)))+import Data.Aeson.Types+  ( FromJSON(parseJSON), Value(Null, Object), Parser, parseEither, withArray+  , withObject, withScientific, withText+  )+import Data.JsonSpec.Codec.Tuple.Internal+  ( Field(Field), Ref(Ref), Tag(Tag), JStruct, JsonStructure, sym+  )+import Data.JsonSpec.Spec (HasJsonDecodingSpec(DecodingSpec), Module)+import Data.Map (Map)+import Data.Proxy (Proxy)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.TypeLits (KnownSymbol)+import Prelude+  ( Applicative(pure), Either(Left, Right), Eq((==)), Functor(fmap)+  , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>))+  , Traversable(traverse), ($), (.), (<$>), Bool, Int, String+  )+import qualified Data.Aeson.Key as AK+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Map as Map+import qualified Data.Vector as Vector++{- |+  Decode a value from the structure appropriate for its specification.++  Given the structural encoding of the JSON data, parse the structure+  into the final type. The reason this returns a @'Parser' a@ instead of+  just a plain @a@ is because there may still be some invariants of the+  JSON data that the 'Specification' language is not able to express,+  and so you may need to fail parsing in those cases. For instance,+  'Specification' is not powerful enough to express "this field must+  contain only prime numbers".+-}+class (HasJsonDecodingSpec a) => TupleDecoding a where+  fromJsonStructure :: JsonStructure (DecodingSpec a) -> Parser a++++{- |+  Analog of 'Data.Aeson.FromJSON', but specialized for decoding our+  "json representations", and closed to the user because the haskell+  representation scheme is fixed and not extensible by the user.++  We can't just use 'Data.Aeson.FromJSON' because the types we are using+  to represent "json data" (i.e. the 'JsonStructure' type family) already+  have 'ToJSON' instances. Even if we were to make a bunch of newtypes+  or whatever to act as the json representation (and therefor also force+  the user to do a lot of wrapping and unwrapping), that still wouldn't+  be sufficient because someone could always write an overlapping (or+  incoherent) 'ToJSON' instance of our newtype! This way we don't have+  to worry about any of that, and the types that the user must deal with+  when implementing 'fromJsonRepr' can be simple tuples and such.+-}+class StructureFromJson a where+  reprParseJson :: Value -> Parser a+instance StructureFromJson Value where+  reprParseJson = pure+instance StructureFromJson Text where+  reprParseJson = withText "string" pure+instance StructureFromJson Scientific where+  reprParseJson = withScientific "number" pure+instance StructureFromJson Int where+  reprParseJson = parseJSON+instance StructureFromJson () where+  reprParseJson =+    withObject "empty object" $ \_ -> pure ()+instance StructureFromJson Bool where+  reprParseJson = parseJSON+instance (KnownSymbol key, StructureFromJson val, StructureFromJson more) => StructureFromJson (Field key val, more) where+  reprParseJson =+    withObject "object" $ \o -> do+      more <- reprParseJson (Object o)+      case KM.lookup (sym @key) o of+        Nothing -> fail $ "could not find key: " <> sym @key+        Just rawVal -> do+          val <- reprParseJson rawVal+          pure (Field val, more)+instance (KnownSymbol key, StructureFromJson val, StructureFromJson more) => StructureFromJson (Maybe (Field key val), more) where+  reprParseJson =+    withObject "object" $ \o -> do+      more <- reprParseJson (Object o)+      case KM.lookup (sym @key) o of+        Nothing ->+          pure (Nothing, more)+        Just rawVal -> do+          val <- reprParseJson rawVal+          pure (Just (Field val), more)+instance (StructureFromJson left, StructureFromJson right) => StructureFromJson (Either left right) where+  reprParseJson v =+    (Left <$> reprParseJson v)+    <|> (Right <$> reprParseJson v)+instance (KnownSymbol const) => StructureFromJson (Tag const) where+  reprParseJson =+    withText "constant" $ \c ->+      if c == sym @const then pure Tag+      else fail "unexpected constant value"+instance (StructureFromJson a) => StructureFromJson [a] where+  reprParseJson =+    withArray+      "list"+      (fmap Vector.toList . traverse reprParseJson)+instance (StructureFromJson a) => StructureFromJson (Map Text a) where+  reprParseJson =+    withObject+      "dict"+      ( fmap Map.fromList+          . traverse+              ( \(key, val) ->+                  (\val_ -> (AK.toText key, val_)) <$> reprParseJson val+              )+          . KM.toList+      )+instance StructureFromJson UTCTime where+  reprParseJson = parseJSON+instance (StructureFromJson a) => StructureFromJson (Maybe a) where+  reprParseJson val = do+    case val of+      Null -> pure Nothing+      _ -> Just <$> reprParseJson val+instance+    (StructureFromJson (JStruct env spec))+  =>+    StructureFromJson (Ref env spec)+  where+  reprParseJson val =+    Ref <$> reprParseJson val+++{-|+  Directly decode some JSON accoring to a spec without going through+  any To/FromJSON instances.+-}+eitherDecode+  :: forall spec.+     (StructureFromJson (JsonStructure spec))+   => Proxy (spec :: Module)+  -> Value+  -> Either String (JsonStructure spec)+eitherDecode _spec =+  parseEither reprParseJson

@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.JsonSpec.Codec.Tuple.Encode (+  TupleEncoding(..),+  StructureToJson(..),+  encode,+) where++import Data.Aeson (ToJSON(toJSON), Value)+import Data.JsonSpec.Codec.Tuple.Internal+  ( Field(Field), Ref(unRef), JStruct, JsonStructure, Tag, sym+  )+import Data.JsonSpec.Spec (HasJsonEncodingSpec(EncodingSpec))+import Data.Map (Map)+import Data.Proxy (Proxy(Proxy))+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.TypeLits (KnownSymbol)+import Prelude+  ( Either(Left, Right), Functor(fmap), Maybe(Just, Nothing), Monoid(mempty)+  , (.), Bool, Int, id, maybe+  )+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AK+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Map as Map++{- |+  Encode a value into the structure appropriate for its specification.+-}+class (HasJsonEncodingSpec a) => TupleEncoding a where+  {- | Encode the value into the structure appropriate for the specification. -}+  toJsonStructure :: a -> JsonStructure (EncodingSpec a)+++{- |+  This is like 'ToJSON', but specialized for our custom "json+  representation" types (i.e. the 'JsonStructure' type family). It is+  also closed (i.e. not exported, so the user can't add instances),+  because our json representation is closed.++  see 'StructureFromJson' for an explaination about why we don't just use+  'ToJSON'.+-}+class StructureToJson a where+  reprToJson :: a -> Value+instance StructureToJson Value where+  reprToJson = id+instance StructureToJson () where+  reprToJson () = A.object []+instance StructureToJson Bool where+  reprToJson = toJSON+instance StructureToJson Text where+  reprToJson = toJSON+instance StructureToJson Scientific where+  reprToJson = toJSON+instance StructureToJson Int where+  reprToJson = toJSON+instance (ToJsonObject (a, b)) => StructureToJson (a, b) where+  reprToJson = A.Object . toJsonObject+instance (StructureToJson left, StructureToJson right) => StructureToJson (Either left right) where+  reprToJson = \case+    Left val -> reprToJson val+    Right val -> reprToJson val+instance (KnownSymbol const) => StructureToJson (Tag const) where+  reprToJson _proxy = toJSON (sym @const @Text)+instance (StructureToJson a) => StructureToJson [a] where+  reprToJson = toJSON . fmap reprToJson+instance (StructureToJson a) => StructureToJson (Map Text a) where+  reprToJson =+    A.Object+      . KM.fromList+      . fmap (\(key, val) -> (AK.fromText key, reprToJson val))+      . Map.toList+instance StructureToJson UTCTime where+  reprToJson = toJSON+instance (StructureToJson a) => StructureToJson (Maybe a) where+  reprToJson = maybe A.Null reprToJson+instance+    (StructureToJson (JStruct env spec))+  =>+    StructureToJson (Ref env spec)+  where+    reprToJson = reprToJson . unRef+++{- |+  This class is to help 'StructureToJson' recursively encode objects, and+  is mutually recursive with 'StructureToJson'. If we tried to "recurse+  on the rest of the object" directly in 'StructureToJson' we would end+  up with a partial function, because 'reprToJson' returns a 'Value'+  not an 'Object'. We would therefore have to pattern match on 'Value'+  to get the 'Object' back out, but we would have to call 'error' if the+  'Value' mysteriously somehow wasn't an 'Object' after all. Instead of+  calling error because "it can't ever happen", we use this helper so+  the compiler can prove it never happens.+-}+class ToJsonObject a where+  toJsonObject :: a -> A.Object+instance ToJsonObject () where+  toJsonObject _ = mempty+instance (KnownSymbol key, StructureToJson val, ToJsonObject more) => ToJsonObject (Field key val, more) where+  toJsonObject (Field val, more) =+    KM.insert+      (sym @key)+      (reprToJson val)+      (toJsonObject more)+instance (KnownSymbol key, StructureToJson val, ToJsonObject more) => ToJsonObject (Maybe (Field key val), more) where+  toJsonObject (mval, more) =+    case mval of+      Nothing -> toJsonObject more+      Just (Field val) ->+        KM.insert+          (sym @key)+          (reprToJson val)+          (toJsonObject more)+++{-|+  Given a raw Haskell structure, directly encode it directly into an+  aeson Value without having to go through any To/FromJSON instances.++  See also: `Data.JsonSpec.Codec.Tuple.eitherDecode`.+-}+encode :: StructureToJson (JsonStructure spec) => Proxy spec -> JsonStructure spec -> Value+encode Proxy = reprToJson

@@ -0,0 +1,272 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Internal tuple-structure representation. Not part of the public API. -}+module Data.JsonSpec.Codec.Tuple.Internal (+  JsonStructure,+  JStruct,+  Tag(..),+  Field(..),+  unField,+  Ref(..),+  sym,+) where++import Data.Aeson (Value)+import Data.JsonSpec.Spec+  ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required)+  , Module(Module)+  , Specification+    ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither+    , JsonInt, JsonLet, JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw+    , JsonRef, JsonString, JsonTag+    )+  )+import Data.Kind (Type)+import Data.Map (Map)+import Data.Proxy (Proxy(Proxy))+import Data.Scientific (Scientific)+import Data.String (IsString(fromString))+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Records (HasField(getField))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Prelude (Maybe(Just, Nothing), ($), Bool, Either, Eq, Int, Show)+import qualified GHC.TypeError as GE++{- |+  @'JsonStructure' spec@ is the Haskell type used to contain the JSON data+  that will be encoded or decoded according to the provided @spec@.++  Basically, we represent JSON objects as "list-like" nested tuples of+  the form:++  > (Field @key1 valueType,+  > (Field @key2 valueType,+  > (Field @key3 valueType,+  > ())))++  Note! "Object structures" of this type have the appropriate 'HasField'+  instances, which allows you to use -XOverloadedRecordDot to extract+  values as an alternative to pattern matching the whole tuple structure+  when building your 'HasJsonDecodingSpec' instances. See @TestHasField@+  in the tests for an example++  Arrays, dicts, booleans, numbers, and strings are just Lists,+  @'Map' 'Text'@, 'Bool's, 'Scientific's, and 'Text's respectively.++  If the user can convert their normal business logic type to/from this+  tuple type, then they get a JSON encoding to/from their type that is+  guaranteed to be compliant with the 'Specification'+-}+type family JsonStructure (spec :: Module) where+  JsonStructure ('Module s) = JStruct '[] s+++{-|+  Make the correct reference type by looking up the symbol, and providing+  the environment in which the symbol was _defined_. We mustn't use the+  environment in which the reference is _used_, or else 'Specification'+  would be a dynamically scoped language, instead of a statically scoped+  language.+-}+type family+    LookupRef+      (env :: Env)+      (search :: Env)+      (target :: Symbol)+    :: Type+  where+    LookupRef+        env+        ( ('(target, spec) : moreDefs) : moreStack )+        target+      =+        Ref env spec++    LookupRef+        env+        ( ('(miss, spec) : moreDefs) : moreStack)+        target+      =+        LookupRef env ( moreDefs : moreStack) target++    LookupRef+        env+        ( '[] : moreStack)+        target+      =+        LookupRef moreStack moreStack target+++type family PushAll (a :: [k]) (b :: [k]) :: [k] where+  PushAll '[] b = b+  PushAll (e : more) b = PushAll more (e : b)+++{-|+  Structural type for `JsonEither`: nested `Either` for two or more branches,+  or the lone branch type for a singleton list. Empty list is disallowed.+-}+type family EitherJStruct (env :: Env) (specs :: [Specification]) :: Type where+  EitherJStruct _env '[] =+    GE.TypeError (GE.Text "JsonEither requires at least one branch")+  EitherJStruct env '[spec] =+    JStruct env spec+  EitherJStruct env (a ': b ': more) =+    Either (JStruct env a) (EitherJStruct env (b ': more))+++type family+  JStruct+    (env :: Env)+    (spec :: Specification)+  :: Type+  where+    JStruct env (JsonObject '[]) = ()+    JStruct env (JsonObject ( Required key s : more )) =+      (+        Field key (JStruct env s),+        JStruct env (JsonObject more)+      )+    JStruct env (JsonObject ( Optional key s : more )) =+      (+        Maybe (Field key (JStruct env s)),+        JStruct env (JsonObject more)+      )+    JStruct env JsonString = Text+    JStruct env JsonNum = Scientific+    JStruct env JsonInt = Int+    JStruct env (JsonArray spec) = [JStruct env spec]+    JStruct env (JsonDict spec) = Map Text (JStruct env spec)+    JStruct env JsonBool = Bool+    JStruct env (JsonEither specs) =+      EitherJStruct env specs+    JStruct env (JsonTag tag) = Tag tag+    JStruct env JsonDateTime = UTCTime+    JStruct env (JsonNullable spec) = Maybe (JStruct env spec)+    JStruct env (JsonLet defs spec) =+      JStruct (BindingsToFrame defs : env) spec+    JStruct env (JsonRef ref) = LookupRef env env ref+    JStruct env (JsonModule m) =+      JsonStructure m+    JStruct env JsonRaw = Value+    JStruct env (JsonAnnotated _annotations spec) =+      JStruct env spec+++{-| Lower 'BindingSpec's to the env-frame representation. -}+type family BindingsToFrame (bs :: [BindingSpec]) :: [(Symbol, Specification)] where+  BindingsToFrame '[] = '[]+  BindingsToFrame (TypeBind n s : more) =+    '(n, s) : BindingsToFrame more+  BindingsToFrame (ModuleBind n s : more) =+    '(n, JsonModule s) : BindingsToFrame more+++{-|+  This is the "Haskell structure" type of 'JsonRef' references.++  The main reason why we need this is because of recursion, as explained+  below:++  Since the specification is at the type level, and type level haskell+  is strict, specifying a recursive definition the "naive" way would+  cause an infinitely sized type.++  For example this won't work:++  > data Foo = Foo [Foo]+  > instance HasJsonEncodingSpec Foo where+  >   type EncodingSpec Foo = JsonArray (EncodingSpec Foo)+  >   toJsonStructure = ... can't be written++  ... because @EncodingSpec Foo@ would expand strictly into an array of+  @EncodingSpec Foo@, which would expand strictly... to infinity.++  Using `JsonLet` prevents the specification type from being infinitely+  sized, but what about the "structure" type which holds real values+  corresponding to the spec? The structure type has to have some way to+  reference itself or else it too would be infinitely sized.++  In order to "reference itself" the structure type has to go through+  a newtype somewhere along the way, and that's what this type is+  for. Whenever you use a 'JsonRef' in the spec, the corresponding+  structural type will have a 'Ref' newtype wrapper around the+  "dereferenced" structure type.++  For example:++  > data Foo = Foo [Foo]+  > instance HasJsonEncodingSpec Foo where+  >   type EncodingSpec Foo =+  >     JsonLet+  >       '[ "Foo" := JsonArray (JsonRef "Foo") ]+  >       (JsonRef "Foo")+  >   toJsonStructure (Foo fs) =+  >     Ref [ toJsonStructure <$> fs ]++  Strictly speaking, we wouldn't /necessarily/ have to translate every+  'JsonRef' into a 'Ref'. In principal we could get away with inserting a+  'Ref' somewhere in every mutually recursive cycle. But the type level+  programming to figure that out a) probably wouldn't do any favors to+  compilation times, b) is beyond what I'm willing to attempted right+  now, and c) requires some kind of deterministic and stable choice+  about where to insert the 'Ref' (which I'm not even certain exists)+  lest arbitrary 'HasJsonEncodingSpec' or 'HasJsonDecodingSpec' instances+  break when the members of the recursive cycle change, causing a new+  choice about where to place the 'Ref'.+-}+newtype Ref env spec = Ref+  { unRef :: JStruct env spec+  }+++{-| Structural representation of 'JsonTag'. (I.e. a constant string value.) -}+data Tag (a :: Symbol) = Tag+++{-| Structural representation of an object field. -}+newtype Field (key :: Symbol) t = Field t+  deriving stock (Show, Eq)+instance {-# overlappable #-} (HasField k more v) => HasField k (Field notIt x, more) v where+  getField (_, more) = getField @k @_ @v more+instance {-# overlappable #-} (HasField k more v) => HasField k (Maybe (Field notIt x), more) v where+  getField (_, more) = getField @k @_ @v more+instance HasField k (Maybe (Field k v), more) (Maybe v) where+  getField (mv, _) =+    case mv of+      Nothing -> Nothing+      Just (Field v) -> Just v+instance HasField k (Field k v, more) v where+  getField (Field v, _) = v+++unField :: Field key t -> t+unField (Field t) = t+++{- |+  Shorthand for demoting type-level strings.+  Use with -XTypeApplication, e.g.:++  > sym @var+-}+sym+  :: forall a b.+     ( IsString b+     , KnownSymbol a+     )+  => b+sym = fromString $ symbolVal (Proxy @a)+++type Env = [[(Symbol, Specification)]]

@@ -1,164 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- | Decoding using specs. -}-module Data.JsonSpec.Decode (-  StructureFromJSON(..),-  HasJsonDecodingSpec(..),-  eitherDecode,-) where--import Control.Applicative (Alternative((<|>)))-import Data.Aeson.Types-  ( FromJSON(parseJSON), Value(Null, Object), Parser, parseEither, withArray-  , withObject, withScientific, withText-  )-import Data.JsonSpec.Spec-  ( Field(Field), Ref(Ref), Tag(Tag), JSONStructure, JStruct, Specification, sym-  )-import Data.Map (Map)-import Data.Proxy (Proxy)-import Data.Scientific (Scientific)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.TypeLits (KnownSymbol)-import Prelude-  ( Applicative(pure), Either(Left, Right), Eq((==)), Functor(fmap)-  , Maybe(Just, Nothing), MonadFail(fail), Semigroup((<>))-  , Traversable(traverse), ($), (.), (<$>), Bool, Int, String-  )-import qualified Data.Aeson.Key as AK-import qualified Data.Aeson.KeyMap as KM-import qualified Data.Map as Map-import qualified Data.Vector as Vector--{- |-  Types of this class can be JSON decoded according to a type-level-  'Specification'.--}-class HasJsonDecodingSpec a where-  {- | The decoding 'Specification'. -}-  type DecodingSpec a :: Specification--  {- |-    Given the structural encoding of the JSON data, parse the structure-    into the final type. The reason this returns a @'Parser' a@ instead of-    just a plain @a@ is because there may still be some invariants of the-    JSON data that the 'Specification' language is not able to express,-    and so you may need to fail parsing in those cases. For instance,-    'Specification' is not powerful enough to express "this field must-    contain only prime numbers".-  -}-  fromJSONStructure :: JSONStructure (DecodingSpec a) -> Parser a---{- |-  Analog of 'Data.Aeson.FromJSON', but specialized for decoding our-  "json representations", and closed to the user because the haskell-  representation scheme is fixed and not extensible by the user.--  We can't just use 'Data.Aeson.FromJSON' because the types we are using-  to represent "json data" (i.e. the 'JSONStructure' type family) already-  have 'ToJSON' instances. Even if we were to make a bunch of newtypes-  or whatever to act as the json representation (and therefor also force-  the user to do a lot of wrapping and unwrapping), that still wouldn't-  be sufficient because someone could always write an overlapping (or-  incoherent) 'ToJSON' instance of our newtype! This way we don't have-  to worry about any of that, and the types that the user must deal with-  when implementing 'fromJSONRepr' can be simple tuples and such.--}-class StructureFromJSON a where-  reprParseJSON :: Value -> Parser a-instance StructureFromJSON Value where-  reprParseJSON = pure-instance StructureFromJSON Text where-  reprParseJSON = withText "string" pure-instance StructureFromJSON Scientific where-  reprParseJSON = withScientific "number" pure-instance StructureFromJSON Int where-  reprParseJSON = parseJSON-instance StructureFromJSON () where-  reprParseJSON =-    withObject "empty object" $ \_ -> pure ()-instance StructureFromJSON Bool where-  reprParseJSON = parseJSON-instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Field key val, more) where-  reprParseJSON =-    withObject "object" $ \o -> do-      more <- reprParseJSON (Object o)-      case KM.lookup (sym @key) o of-        Nothing -> fail $ "could not find key: " <> sym @key-        Just rawVal -> do-          val <- reprParseJSON rawVal-          pure (Field val, more)-instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Maybe (Field key val), more) where-  reprParseJSON =-    withObject "object" $ \o -> do-      more <- reprParseJSON (Object o)-      case KM.lookup (sym @key) o of-        Nothing ->-          pure (Nothing, more)-        Just rawVal -> do-          val <- reprParseJSON rawVal-          pure (Just (Field val), more)-instance (StructureFromJSON left, StructureFromJSON right) => StructureFromJSON (Either left right) where-  reprParseJSON v =-    (Left <$> reprParseJSON v)-    <|> (Right <$> reprParseJSON v)-instance (KnownSymbol const) => StructureFromJSON (Tag const) where-  reprParseJSON =-    withText "constant" $ \c ->-      if c == sym @const then pure Tag-      else fail "unexpected constant value"-instance (StructureFromJSON a) => StructureFromJSON [a] where-  reprParseJSON =-    withArray-      "list"-      (fmap Vector.toList . traverse reprParseJSON)-instance (StructureFromJSON a) => StructureFromJSON (Map Text a) where-  reprParseJSON =-    withObject-      "dict"-      ( fmap Map.fromList-          . traverse-              ( \(key, val) ->-                  (\val_ -> (AK.toText key, val_)) <$> reprParseJSON val-              )-          . KM.toList-      )-instance StructureFromJSON UTCTime where-  reprParseJSON = parseJSON-instance (StructureFromJSON a) => StructureFromJSON (Maybe a) where-  reprParseJSON val = do-    case val of-      Null -> pure Nothing-      _ -> Just <$> reprParseJSON val-instance-    (StructureFromJSON (JStruct env spec))-  =>-    StructureFromJSON (Ref env spec)-  where-  reprParseJSON val =-    Ref <$> reprParseJSON val---{-|-  Directly decode some JSON accoring to a spec without going through-  any To/FromJSON instances.--}-eitherDecode-  :: forall spec.-     (StructureFromJSON (JSONStructure spec))-   => Proxy (spec :: Specification)-  -> Value-  -> Either String (JSONStructure spec)-eitherDecode _spec =-  parseEither reprParseJSON--

@@ -1,146 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.JsonSpec.Encode (-  HasJsonEncodingSpec(..),-  StructureToJSON(..),-  encode,-) where--import Data.Aeson (ToJSON(toJSON), Value)-import Data.JsonSpec.Spec-  ( Field(Field), Ref(unRef), Specification(JsonArray), JSONStructure, JStruct-  , Tag, sym-  )-import Data.Map (Map)-import Data.Proxy (Proxy(Proxy))-import Data.Scientific (Scientific)-import Data.Set (Set)-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.TypeLits (KnownSymbol)-import Prelude-  ( Either(Left, Right), Functor(fmap), Maybe(Just, Nothing), Monoid(mempty)-  , (.), Bool, Int, id, maybe-  )-import qualified Data.Aeson as A-import qualified Data.Aeson.Key as AK-import qualified Data.Aeson.KeyMap as KM-import qualified Data.Map as Map-import qualified Data.Set as Set--{- |-  Types of this class can be encoded to JSON according to a type-level-  'Specification'.--}-class HasJsonEncodingSpec a where-  {- | The encoding specification. -}-  type EncodingSpec a :: Specification--  {- | Encode the value into the structure appropriate for the specification. -}-  toJSONStructure :: a -> JSONStructure (EncodingSpec a)-instance (HasJsonEncodingSpec a) => HasJsonEncodingSpec (Set a) where-  type EncodingSpec (Set a) = JsonArray (EncodingSpec a)-  toJSONStructure = fmap toJSONStructure . Set.toList---{- |-  This is like 'ToJSON', but specialized for our custom "json-  representation" types (i.e. the 'JSONStructure' type family). It is-  also closed (i.e. not exported, so the user can't add instances),-  because our json representation is closed.--  see 'StructureFromJSON' for an explaination about why we don't just use-  'ToJSON'.--}-class StructureToJSON a where-  reprToJSON :: a -> Value-instance StructureToJSON Value where-  reprToJSON = id-instance StructureToJSON () where-  reprToJSON () = A.object []-instance StructureToJSON Bool where-  reprToJSON = toJSON-instance StructureToJSON Text where-  reprToJSON = toJSON-instance StructureToJSON Scientific where-  reprToJSON = toJSON-instance StructureToJSON Int where-  reprToJSON = toJSON-instance (ToJSONObject (a, b)) => StructureToJSON (a, b) where-  reprToJSON = A.Object . toJSONObject-instance (StructureToJSON left, StructureToJSON right) => StructureToJSON (Either left right) where-  reprToJSON = \case-    Left val -> reprToJSON val-    Right val -> reprToJSON val-instance (KnownSymbol const) => StructureToJSON (Tag const) where-  reprToJSON _proxy = toJSON (sym @const @Text)-instance (StructureToJSON a) => StructureToJSON [a] where-  reprToJSON = toJSON . fmap reprToJSON-instance (StructureToJSON a) => StructureToJSON (Map Text a) where-  reprToJSON =-    A.Object-      . KM.fromList-      . fmap (\(key, val) -> (AK.fromText key, reprToJSON val))-      . Map.toList-instance StructureToJSON UTCTime where-  reprToJSON = toJSON-instance (StructureToJSON a) => StructureToJSON (Maybe a) where-  reprToJSON = maybe A.Null reprToJSON-instance-    (StructureToJSON (JStruct env spec))-  =>-    StructureToJSON (Ref env spec)-  where-    reprToJSON = reprToJSON . unRef---{- |-  This class is to help 'StructureToJSON' recursively encode objects, and-  is mutually recursive with 'StructureToJSON'. If we tried to "recurse-  on the rest of the object" directly in 'StructureToJSON' we would end-  up with a partial function, because 'reprToJSON' returns a 'Value'-  not an 'Object'. We would therefore have to pattern match on 'Value'-  to get the 'Object' back out, but we would have to call 'error' if the-  'Value' mysteriously somehow wasn't an 'Object' after all. Instead of-  calling error because "it can't ever happen", we use this helper so-  the compiler can prove it never happens.--}-class ToJSONObject a where-  toJSONObject :: a -> A.Object-instance ToJSONObject () where-  toJSONObject _ = mempty-instance (KnownSymbol key, StructureToJSON val, ToJSONObject more) => ToJSONObject (Field key val, more) where-  toJSONObject (Field val, more) =-    KM.insert-      (sym @key)-      (reprToJSON val)-      (toJSONObject more)-instance (KnownSymbol key, StructureToJSON val, ToJSONObject more) => ToJSONObject (Maybe (Field key val), more) where-  toJSONObject (mval, more) =-    case mval of-      Nothing -> toJSONObject more-      Just (Field val) ->-        KM.insert-          (sym @key)-          (reprToJSON val)-          (toJSONObject more)---{-|-  Given a raw Haskell structure, directly encode it directly into an-  aeson Value without having to go through any To/FromJSON instances.--  See also: `Data.JsonSpec.eitherDecode`.--}-encode :: StructureToJSON (JSONStructure spec) => Proxy spec -> JSONStructure spec -> Value-encode Proxy = reprToJSON--

@@ -0,0 +1,413 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+  Description : Parser for the JsonSpec textual language++  Megaparsec parser for the JsonSpec textual language.++  See @docs\/language-spec.md@. Trailing commas are allowed in+  objects (JSON-familiar). Identifiers accept letters matching+  'isAlpha'. Keyword names may be written as backtick-escaped+  identifiers (e.g. @`string`@).+-}+module Data.JsonSpec.Language.Parser (+  -- * AST+  Program(..),+  Binding(..),+  Spec(..),+  Field(..),++  -- * Parsing+  parseProgram,+  parseSpec,+  program,+  spec,+) where++import Control.Applicative+  ( Alternative((<|>), many), Applicative((<*), pure), (<$>), optional+  )+import Control.Monad (void)+import Data.Char (isAlpha, isAlphaNum)+import Data.Text (Text)+import Data.Void (Void)+import Prelude+  ( Bool(False, True), Either(Left, Right), Enum(fromEnum, toEnum)+  , Eq((/=), (==)), Functor(fmap), Maybe(Just, Nothing), Monad((>>))+  , MonadFail(fail), Num((*), (+), (-)), Ord((<=), (>=)), Semigroup((<>)), ($)+  , (&&), (.), (||), Char, Int, Show, String, otherwise+  )+import Text.Megaparsec+  ( MonadParsec(eof, notFollowedBy, takeWhile1P, try), Parsec, between, choice+  , errorBundlePretty, manyTill, parse, satisfy, sepEndBy+  )+import Text.Megaparsec.Char (char, space1, string)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Text.Megaparsec.Char.Lexer as L++{-| A full program: one top-level closed @module@ binding. -}+data Program = Program+  { programName :: Text+  , programSpec :: Spec+  }+  deriving stock (Eq, Show)+++{-| A @type@ or @module@ binding inside a @let@. -}+data Binding+  = TypeBinding Text Spec+  | ModuleBinding Text Spec+  deriving stock (Eq, Show)+++{-| A specification expression. -}+data Spec+  = LetSpec [Binding] Spec+  | EitherSpec [Spec]+  | DictSpec Spec+  | NullSpec Spec+  | StringSpec+  | NumberSpec+  | IntSpec+  | BoolSpec+  | DateTimeSpec+  | RawSpec+  | TagSpec Text+  | RefSpec Text+  | ObjectSpec [Field]+  | ArraySpec Spec+  deriving stock (Eq, Show)+++{-| An object field. -}+data Field = Field+  { fieldName     :: Text+  , fieldOptional :: Bool+  , fieldSpec     :: Spec+  }+  deriving stock (Eq, Show)+++type Parser = Parsec Void Text+++{-| Parse a full program (@module Name = …@). -}+parseProgram+  :: String+  -> Text+  -> Either String Program+parseProgram name input =+  case parse (sc >> program <* eof) name input of+    Left err ->+      Left (errorBundlePretty err)+    Right p ->+      Right p+++{-| Parse a bare specification expression (not a full program). -}+parseSpec+  :: String+  -> Text+  -> Either String Spec+parseSpec name input =+  case parse (sc >> spec <* eof) name input of+    Left err ->+      Left (errorBundlePretty err)+    Right s ->+      Right s+++sc :: Parser ()+sc =+  L.space+    space1+    (L.skipLineComment "--")+    (L.skipBlockCommentNested "{-" "-}")+++lexeme :: Parser a -> Parser a+lexeme =+  L.lexeme sc+++symbol :: Text -> Parser Text+symbol =+  L.symbol sc+++{-| Top-level @module Name = spec@. -}+program :: Parser Program+program = do+  void (keyword "module")+  name <- ident+  void (symbol "=")+  body <- spec+  pure (Program name body)+++{-| Parse a specification. -}+spec :: Parser Spec+spec =+  choice+    [ letSpec+    , eitherSpec+    , dictSpec+    , nullSpec+    , primary+    ]+++letSpec :: Parser Spec+letSpec = do+  void (keyword "let")+  void (symbol "{")+  binds <- many binding+  void (keyword "in")+  body <- spec+  void (symbol "}")+  checkDuplicateBinds binds+  pure (LetSpec binds body)+++binding :: Parser Binding+binding =+  typeBind <|> moduleBind+++typeBind :: Parser Binding+typeBind = do+  void (keyword "type")+  name <- ident+  void (symbol "=")+  TypeBinding name <$> spec+++moduleBind :: Parser Binding+moduleBind = do+  void (keyword "module")+  name <- ident+  void (symbol "=")+  ModuleBinding name <$> spec+++eitherSpec :: Parser Spec+eitherSpec = do+  void (keyword "either")+  firstBranch <- eitherBranch+  rest <- many (try (symbol "|" >> primary))+  pure (EitherSpec (firstBranch : rest))+++eitherBranch :: Parser Spec+eitherBranch = do+  _ <- optional (symbol "|")+  primary+++dictSpec :: Parser Spec+dictSpec = do+  void (keyword "dict")+  DictSpec <$> primary+++nullSpec :: Parser Spec+nullSpec = do+  void (keyword "null")+  NullSpec <$> primary+++primary :: Parser Spec+primary =+  choice+    [ try (keyword "string")   >> pure StringSpec+    , try (keyword "number")   >> pure NumberSpec+    , try (keyword "int")      >> pure IntSpec+    , try (keyword "bool")     >> pure BoolSpec+    , try (keyword "datetime") >> pure DateTimeSpec+    , try (keyword "raw")      >> pure RawSpec+    , TagSpec <$> stringLit+    , RefSpec <$> ident+    , objectSpec+    , arraySpec+    , between (symbol "(") (symbol ")") spec+    ]+++objectSpec :: Parser Spec+objectSpec = do+  void (symbol "{")+  fields <- field `sepEndBy` symbol ","+  void (symbol "}")+  checkDuplicateFields fields+  pure (ObjectSpec fields)+++field :: Parser Field+field = do+  name <- stringLit+  opt <- optional (symbol "?")+  void (symbol ":")+  s <- spec+  pure Field+    { fieldName = name+    , fieldOptional = case opt of+        Just _ ->+          True+        Nothing ->+          False+    , fieldSpec = s+    }+++arraySpec :: Parser Spec+arraySpec =+  ArraySpec <$> between (symbol "[") (symbol "]") spec+++keywords :: Set.Set Text+keywords =+  Set.fromList+    [ "module", "type", "let", "in", "either", "dict", "null"+    , "string", "number", "int", "bool", "datetime", "raw"+    ]+++keyword :: Text -> Parser ()+keyword w = lexeme . try $ do+  void (string w)+  notFollowedBy (satisfy identChar)+++{-| Binding name or reference: bare non-keyword, or backtick-escaped. -}+ident :: Parser Text+ident =+  escapedIdent <|> bareIdent+++{-| @`name`@ — may be a keyword (e.g. @`string`@, @`type`@). -}+escapedIdent :: Parser Text+escapedIdent = lexeme . try $ do+  void (char '`')+  name <- identBody+  void (char '`')+  pure name+++{-| Bare identifier; keywords are rejected. -}+bareIdent :: Parser Text+bareIdent = lexeme . try $ do+  full <- identBody+  if Set.member full keywords then+    fail ("unexpected keyword " <> T.unpack full)+  else+    pure full+++identBody :: Parser Text+identBody = do+  first <- takeWhile1P (Just "identifier") identCharStart+  rest <- fmap T.pack (many (satisfy identChar))+  pure (first <> rest)+++identCharStart :: Char -> Bool+identCharStart c =+  isAlpha c || c == '_'+++identChar :: Char -> Bool+identChar c =+  isAlphaNum c || c == '_'+++stringLit :: Parser Text+stringLit = lexeme $ do+  void (char '"')+  chars <- manyTill stringChar (char '"')+  pure (T.pack chars)+++stringChar :: Parser Char+stringChar =+  satisfy (\c -> c /= '"' && c /= '\\')+  <|> (char '\\' >> escape)+++escape :: Parser Char+escape =+  choice+    [ char '"'  >> pure '"'+    , char '\\' >> pure '\\'+    , char '/'  >> pure '/'+    , char 'b'  >> pure '\b'+    , char 'f'  >> pure '\f'+    , char 'n'  >> pure '\n'+    , char 'r'  >> pure '\r'+    , char 't'  >> pure '\t'+    , char 'u'  >> unicodeEscape+    ]+++unicodeEscape :: Parser Char+unicodeEscape = do+  d1 <- hexDigit+  d2 <- hexDigit+  d3 <- hexDigit+  d4 <- hexDigit+  pure (toEnum (d1 * 4096 + d2 * 256 + d3 * 16 + d4))+++hexDigit :: Parser Int+hexDigit = do+  c <- satisfy isHex+  pure (hexVal c)+++isHex :: Char -> Bool+isHex c =+  (c >= '0' && c <= '9')+  || (c >= 'a' && c <= 'f')+  || (c >= 'A' && c <= 'F')+++hexVal :: Char -> Int+hexVal c+  | c >= '0' && c <= '9' =+      fromEnum c - fromEnum '0'+  | c >= 'a' && c <= 'f' =+      fromEnum c - fromEnum 'a' + 10+  | otherwise =+      fromEnum c - fromEnum 'A' + 10+++checkDuplicateBinds :: [Binding] -> Parser ()+checkDuplicateBinds binds =+  checkDups "duplicate binding" (fmap bindName binds)+++checkDuplicateFields :: [Field] -> Parser ()+checkDuplicateFields fields =+  checkDups "duplicate field" (fmap fieldName fields)+++bindName :: Binding -> Text+bindName (TypeBinding n _) =+  n+bindName (ModuleBinding n _) =+  n+++checkDups :: String -> [Text] -> Parser ()+checkDups msg names =+  go Set.empty names+  where+    go :: Set.Set Text -> [Text] -> Parser ()+    go _seen [] =+      pure ()+    go seen (n:ns)+      | Set.member n seen =+          fail (msg <> ": " <> T.unpack n)+      | otherwise =+          go (Set.insert n seen) ns

@@ -0,0 +1,140 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+  Description : Quasi-quoters for the JsonSpec language++  Quasi-quoters for the JsonSpec textual language.++  > type Person =+  >   [jsonspec|+  >     module Person = {+  >       "name": string,+  >       "age": int+  >     }+  >   |]++  produces a type of kind 'Module'.++  See @docs\/language-spec.md@.+-}+module Data.JsonSpec.Language.QQ (+  jsonspec,+) where++import Data.JsonSpec.Language.Parser+  ( Binding(ModuleBinding, TypeBinding)+  , Field(Field, fieldName, fieldOptional, fieldSpec)+  , Program(Program, programSpec)+  , Spec+    ( ArraySpec, BoolSpec, DateTimeSpec, DictSpec, EitherSpec, IntSpec, LetSpec+    , NullSpec, NumberSpec, ObjectSpec, RawSpec, RefSpec, StringSpec, TagSpec+    )+  , parseProgram+  )+import Data.JsonSpec.Spec+  ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required)+  , Module(Module)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  )+import Data.Text (Text)+import Language.Haskell.TH (Q, Type, TypeQ, appT, litT, promotedT, strTyLit)+import Language.Haskell.TH.Quote+  ( QuasiQuoter(QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType)+  )+import Prelude+  ( Bool(False, True), Either(Left, Right), Foldable(foldr), Functor(fmap)+  , MonadFail(fail), Semigroup((<>)), String+  )+import qualified Data.Text as T++{-|+  Quasi-quoter for a JsonSpec program.++  The quoted text must be a full program+  (@module Name = \<spec\>@). Use in type context; the result has+  kind 'Module'.+-}+jsonspec :: QuasiQuoter+jsonspec =+  QuasiQuoter+    { quoteExp  = unsupported "expression"+    , quotePat  = unsupported "pattern"+    , quoteType = quoteJsonSpecType+    , quoteDec  = unsupported "declaration"+    }+++unsupported :: String -> String -> Q a+unsupported kind _ =+  fail ("jsonspec: " <> kind <> " contexts are not supported; use as a type")+++quoteJsonSpecType :: String -> Q Type+quoteJsonSpecType input =+  case parseProgram "jsonspec" (T.pack input) of+    Left err ->+      fail err+    Right Program { programSpec = body } ->+      promotedT 'Module `appT` specType body+++specType :: Spec -> TypeQ+specType StringSpec =+  promotedT 'JsonString+specType NumberSpec =+  promotedT 'JsonNum+specType IntSpec =+  promotedT 'JsonInt+specType BoolSpec =+  promotedT 'JsonBool+specType DateTimeSpec =+  promotedT 'JsonDateTime+specType RawSpec =+  promotedT 'JsonRaw+specType (TagSpec t) =+  promotedT 'JsonTag `appT` symbolType t+specType (RefSpec n) =+  promotedT 'JsonRef `appT` symbolType n+specType (DictSpec s) =+  promotedT 'JsonDict `appT` specType s+specType (NullSpec s) =+  promotedT 'JsonNullable `appT` specType s+specType (ArraySpec s) =+  promotedT 'JsonArray `appT` specType s+specType (EitherSpec ss) =+  promotedT 'JsonEither `appT` listType (fmap specType ss)+specType (ObjectSpec fields) =+  promotedT 'JsonObject `appT` listType (fmap fieldType fields)+specType (LetSpec binds body) =+  (promotedT 'JsonLet `appT` listType (fmap bindingType binds))+    `appT` specType body+++fieldType :: Field -> TypeQ+fieldType Field { fieldName = name, fieldOptional = True, fieldSpec = s } =+  (promotedT 'Optional `appT` symbolType name) `appT` specType s+fieldType Field { fieldName = name, fieldOptional = False, fieldSpec = s } =+  (promotedT 'Required `appT` symbolType name) `appT` specType s+++bindingType :: Binding -> TypeQ+bindingType (TypeBinding name s) =+  (promotedT 'TypeBind `appT` symbolType name) `appT` specType s+bindingType (ModuleBinding name s) =+  (promotedT 'ModuleBind `appT` symbolType name)+    `appT` (promotedT 'Module `appT` specType s)+++listType :: [TypeQ] -> TypeQ+listType =+  foldr+    (\t acc -> promotedT '(:) `appT` t `appT` acc)+    (promotedT '[])+++symbolType :: Text -> TypeQ+symbolType t =+  litT (strTyLit (T.unpack t))

@@ -11,71 +11,58 @@  module Data.JsonSpec.Spec (   Specification(..),-  JSONStructure,-  sym,-  Tag(..),-  Field(..),-  unField,-  Ref(..),-  JStruct,+  Module(..),+  BindingSpec(..),   FieldSpec(..),   (:::),   (::?),+  (:=),+  (::=),+  HasJsonEncodingSpec(..),+  HasJsonDecodingSpec(..), ) where -import Data.Aeson (Value)-import Data.Kind (Type)-import Data.Map (Map)-import Data.Proxy (Proxy(Proxy))-import Data.Scientific (Scientific)-import Data.String (IsString(fromString))-import Data.Text (Text)-import Data.Time (UTCTime)-import GHC.Records (HasField(getField))-import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)-import Prelude (Maybe(Just, Nothing), ($), Bool, Either, Eq, Int, Show)-import qualified GHC.TypeError as GE+import GHC.TypeLits (Symbol)+import Prelude ()  {-|-  Simple DSL for defining type level "specifications" for JSON-  data. Similar in spirit to (but not isomorphic with) JSON Schema.+  Type-level AST for JSON structure specifications. -  Intended to be used at the type level using @-XDataKinds@+  Use with @-XDataKinds@. Codecs such as 'Data.JsonSpec.Codec.Tuple'+  interpret these specs into concrete Haskell types and+  encode/decode strategies. -  See 'JSONStructure' for how these map into Haskell representations.+  Similar in spirit to JSON Schema, but not isomorphic with it.+  The matching textual language is documented in+  @docs\/language-spec.md@. -} data Specification where   JsonObject :: [FieldSpec] -> Specification     {-^-      An object with the specified properties, each having its own-      specification. This does not yet support optional properties,-      although a property can be specified as "nullable" using-      `JsonNullable`+      Object with a fixed set of fields. Use 'Required' / 'Optional'+      (or '(:::)' / '(::?)') for each field.     -}   JsonString :: Specification-    {-^ An arbitrary JSON string. -}+    {-^ Any JSON string. -}   JsonNum :: Specification-    {-^ An arbitrary (floating point) JSON number. -}+    {-^ Any JSON number (floating point). -}   JsonInt :: Specification-    {-^ A JSON integer.  -}+    {-^ A JSON integer. -}   JsonArray :: Specification -> Specification-    {-^ A JSON array of values which conform to the given spec. -}+    {-^ Array whose elements all conform to the given spec. -}   JsonDict :: Specification -> Specification     {-^-      A JSON object used as a dictionary: arbitrary string keys, with every-      value conforming to the given specification.+      Object used as a string-keyed map: keys are unrestricted, and+      every value must conform to the given spec. -      This is distinct from 'JsonObject', which represents a record with-      statically known fields.+      Distinct from 'JsonObject', which has statically known field+      names.     -}   JsonBool :: Specification-    {-^ A JSON boolean value. -}+    {-^ A JSON boolean. -}   JsonNullable :: Specification -> Specification     {-^-      A value that can either be `null`, or else a value conforming to-      the specification.--      E.g.:+      Either JSON @null@, or a value conforming to the given spec.        > type SpecWithNullableField =       >   JsonObject '[@@ -84,16 +71,8 @@     -}   JsonEither :: [Specification] -> Specification     {-^-      One of several different specifications. Corresponds to json-schema-      "oneOf". Useful for encoding sum types.--      Takes a type-level list of specs. In the structural representation-      ('JStruct'), `JsonEither` maps to nested `Either`: two or more-      branches become @Either (JStruct env a) (Either (JStruct env b) ...)@;-      a single branch maps to @JStruct env spec@ (no sum wrapper). Use-      `Left`/`Right` for construction and pattern matching.--      Example:+      Exactly one of the given alternatives (json-schema @oneOf@).+      Commonly used for sum types.        > data MyType       >   = Foo Text@@ -101,121 +80,119 @@       >   | Baz UTCTime       > instance HasJsonEncodingSpec MyType where       >   type EncodingSpec MyType =-      >     JsonEither-      >       '[-      >         JsonObject '[-      >           Required "tag" (JsonTag "foo"),-      >           Required "content" JsonString-      >         ],-      >         JsonObject '[-      >           Required "tag" (JsonTag "bar"),-      >           Required "content" JsonInt-      >         ],-      >         JsonObject '[-      >           Required "tag" (JsonTag "baz"),-      >           Required "content" JsonDateTime-      >         ]-      >       ]-      >-      >   toJSONStructure = \case-      >     Foo t ->-      >       Left-      >         ( Field @"tag" (Tag @"foo")-      >         , (Field @"content" t, ())-      >         )-      >     Bar i ->-      >       Right (Left-      >         ( Field @"tag" (Tag @"bar")-      >         , (Field @"content" i, ())-      >         )-      >     Baz dt ->-      >       Right (Right-      >         ( Field @"tag" (Tag @"baz")-      >         , (Field @"content" dt, ())-      >         )+      >     'Module+      >       (JsonEither+      >         '[+      >           JsonObject '[+      >             Required "tag" (JsonTag "foo"),+      >             Required "content" JsonString+      >           ],+      >           JsonObject '[+      >             Required "tag" (JsonTag "bar"),+      >             Required "content" JsonInt+      >           ],+      >           JsonObject '[+      >             Required "tag" (JsonTag "baz"),+      >             Required "content" JsonDateTime+      >           ]+      >         ])     -}   JsonTag :: Symbol -> Specification-    {-^ A constant string value -}+    {-^ A constant string value. -}   JsonDateTime :: Specification     {-^-      A JSON string formatted as an ISO-8601 string. In Haskell this-      corresponds to `Data.Time.UTCTime`, and in json-schema it corresponds-      to the "date-time" format.+      ISO-8601 date-time string. Maps to 'Data.Time.UTCTime' in+      Haskell and to the json-schema @"date-time"@ format.     -}-  JsonLet :: [(Symbol, Specification)] -> Specification -> Specification+  JsonLet :: [BindingSpec] -> Specification -> Specification     {-^-      A "let" expression. This is useful for giving names to types, which can-      then be used in the generated code.--      This is also useful to shorten repetitive type definitions. For example,-      this repetitive definition:+      Bind names, then use them in the body via 'JsonRef'. -      > type Triangle =-      >   JsonObject '[-      >     Required "vertex1" (JsonObject '[-      >       Required "x" JsonInt,-      >       Required "y" JsonInt,-      >       Required "z" JsonInt-      >     ]),-      >     Required "vertex2" (JsonObject '[-      >       Required "x" JsonInt,-      >       Required "y" JsonInt,-      >       Required "z" JsonInt-      >     ]),-      >     Required "vertex3" (JsonObject '[-      >       Required "x" JsonInt),-      >       Required "y" JsonInt),-      >       Required "z" JsonInt)-      >     ])-      >   ]+      'TypeBind' is open: the RHS can refer to sibling bindings and+      outer lets. 'ModuleBind' is closed: the RHS is a 'Module' and+      cannot see outer names. -      Can be written more concisely as:+      Bindings in the same let may refer to each other, including+      recursively.        > type Triangle =       >   JsonLet       >     '[-      >       '("Vertex", JsonObject '[-      >          ('x', JsonInt),-      >          ('y', JsonInt),-      >          ('z', JsonInt)-      >        ])-      >      ]-      >      (JsonObject '[-      >        "vertex1" ::: JsonRef "Vertex",-      >        "vertex2" ::: JsonRef "Vertex",-      >        "vertex3" ::: JsonRef "Vertex"-      >      ])+      >       "Vertex" := JsonObject '[+      >         "x" ::: JsonInt,+      >         "y" ::: JsonInt,+      >         "z" ::: JsonInt+      >       ]+      >     ]+      >     (JsonObject '[+      >       "vertex1" ::: JsonRef "Vertex",+      >       "vertex2" ::: JsonRef "Vertex",+      >       "vertex3" ::: JsonRef "Vertex"+      >     ]) -      Another use is to define recursive types:+      Recursive:        > type LabelledTree =       >   JsonLet       >     '[-      >       '("LabelledTree", JsonObject '[+      >       "LabelledTree" := JsonObject '[       >         "label" ::: JsonString,       >         "children" ::: JsonArray (JsonRef "LabelledTree")-      >        ])-      >      ]+      >       ]+      >     ]       >     (JsonRef "LabelledTree")++      Closed nested binding ('ModuleBind' / '(::=)'):++      > type Invoice =+      >   JsonLet+      >     '[+      >       "Id" := JsonString,+      >       "Tax" ::=+      >         'Module+      >           (JsonLet+      >             '[ "Rate" := JsonNum ]+      >             (JsonObject '[ "rate" ::: JsonRef "Rate" ]))+      >     ]+      >     (JsonObject '[+      >       "id" ::: JsonRef "Id",+      >       "tax" ::: JsonRef "Tax"+      >     ])     -}   JsonRef :: Symbol -> Specification     {-^-      A reference to a specification which has been defined in a surrounding-      'JsonLet'.+      Reference a name bound by an enclosing 'JsonLet'.++      Resolution uses the environment from the binding site, not+      from the reference site.     -}+  JsonModule :: Module -> Specification+    {-^+      Embed a closed 'Module' inside another specification. The+      embedded module cannot see names from any outer 'JsonLet'.++      Typical use: nest another type's 'EncodingSpec' (itself a+      'Module') without exposing the outer environment to it.++      > type EncodingSpec (Wrapper a) =+      >   'Module+      >     (JsonLet+      >       '[ "Unused" := JsonString ]+      >       (JsonObject '[+      >         "payload" ::: JsonModule (EncodingSpec a)+      >       ]))+    -}   JsonRaw :: Specification-    {-^ Some raw, uninterpreted JSON value -}+    {-^ An opaque JSON value; not further interpreted. -}   JsonAnnotated :: forall k. [(Symbol, k)] -> Specification -> Specification     {-^-      An annotation on a specification. This is purely for documentation-      purposes and has no effect on encoding or decoding. The annotations-      are a list of key-value pairs at the type level. Keys are always-      symbols (type-level strings). Values can be any kind @k@: strings-      ('Symbol'), booleans ('Bool'), natural numbers ('Nat'), or any-      custom promoted type the user defines. Within one list, all values-      must have the same kind.+      Attach documentation metadata to a specification. Has no effect+      on encoding or decoding. -      E.g.:+      Annotations are type-level key-value pairs. Keys are always+      'Symbol'. Values share a single kind @k@ within one list —+      commonly 'Symbol', 'Bool', 'Nat', or a user-defined promoted+      type.        > type AnnotatedUser =       >   JsonAnnotated@@ -232,240 +209,89 @@     -}  -{-| Specify a field in an object.  -}-data FieldSpec-  = Required Symbol Specification {-^ The field is required -}-  | Optional Symbol Specification {-^ The field is optionsl -}---{-| Alias for 'Required'. -}-type (:::) = Required---{-| Alias for 'Optional'. -}-type (::?) = Optional---{- |-  @'JSONStructure' spec@ is the Haskell type used to contain the JSON data-  that will be encoded or decoded according to the provided @spec@.--  Basically, we represent JSON objects as "list-like" nested tuples of-  the form:--  > (Field @key1 valueType,-  > (Field @key2 valueType,-  > (Field @key3 valueType,-  > ())))--  Note! "Object structures" of this type have the appropriate 'HasField'-  instances, which allows you to use -XOverloadedRecordDot to extract-  values as an alternative to pattern matching the whole tuple structure-  when building your 'HasJsonDecodingSpec' instances. See @TestHasField@-  in the tests for an example--  Arrays, dicts, booleans, numbers, and strings are just Lists,-  @'Map' 'Text'@, 'Bool's, 'Scientific's, and 'Text's respectively.+{-|+  A closed specification: no free references to an outer+  environment. -  If the user can convert their normal business logic type to/from this-  tuple type, then they get a JSON encoding to/from their type that is-  guaranteed to be compliant with the 'Specification'+  Corresponds to @module@ in the textual language. Also the return+  kind of 'EncodingSpec' / 'DecodingSpec', so associated codecs are+  closed by construction. -}-type family JSONStructure (spec :: Specification) where-  JSONStructure spec = JStruct '[] spec+data Module = Module Specification   {-|-  Make the correct reference type by looking up the symbol, and providing-  the environment in which the symbol was _defined_. We mustn't use the-  environment in which the reference is _used_, or else 'Specification'-  would be a dynamically scoped language, instead of a statically scoped-  language.--}-type family-    LookupRef-      (env :: Env)-      (search :: Env)-      (target :: Symbol)-    :: Type-  where-    LookupRef-        env-        ( ('(target, spec) : moreDefs) : moreStack )-        target-      =-        Ref env spec--    LookupRef-        env-        ( ('(miss, spec) : moreDefs) : moreStack)-        target-      =-        LookupRef env ( moreDefs : moreStack) target--    LookupRef-        env-        ( '[] : moreStack)-        target-      =-        LookupRef moreStack moreStack target---type family PushAll (a :: [k]) (b :: [k]) :: [k] where-  PushAll '[] b = b-  PushAll (e : more) b = PushAll more (e : b)-+  A named binding in a 'JsonLet'. -{-|-  Structural type for `JsonEither`: nested `Either` for two or more branches,-  or the lone branch type for a singleton list. Empty list is disallowed.+  'TypeBind' is open; 'ModuleBind' is closed. Neither introduces a+  namespace — there is no @M.N@ path syntax. -}-type family EitherJStruct (env :: Env) (specs :: [Specification]) :: Type where-  EitherJStruct _env '[] =-    GE.TypeError (GE.Text "JsonEither requires at least one branch")-  EitherJStruct env '[spec] =-    JStruct env spec-  EitherJStruct env (a ': b ': more) =-    Either (JStruct env a) (EitherJStruct env (b ': more))+data BindingSpec+  = TypeBind Symbol Specification+    {-^+      Open binding (@type Name = …@). May refer to siblings in this+      let and to names from outer lets.+    -}+  | ModuleBind Symbol Module+    {-^+      Closed binding (@module Name = …@). The RHS is a 'Module' and+      cannot see outer names. Useful with 'EncodingSpec': +      > "Item" ::= EncodingSpec LineItem+    -} -type family-  JStruct-    (env :: Env)-    (spec :: Specification)-  :: Type-  where-    JStruct env (JsonObject '[]) = ()-    JStruct env (JsonObject ( Required key s : more )) =-      (-        Field key (JStruct env s),-        JStruct env (JsonObject more)-      )-    JStruct env (JsonObject ( Optional key s : more )) =-      (-        Maybe (Field key (JStruct env s)),-        JStruct env (JsonObject more)-      )-    JStruct env JsonString = Text-    JStruct env JsonNum = Scientific-    JStruct env JsonInt = Int-    JStruct env (JsonArray spec) = [JStruct env spec]-    JStruct env (JsonDict spec) = Map Text (JStruct env spec)-    JStruct env JsonBool = Bool-    JStruct env (JsonEither specs) =-      EitherJStruct env specs-    JStruct env (JsonTag tag) = Tag tag-    JStruct env JsonDateTime = UTCTime-    JStruct env (JsonNullable spec) = Maybe (JStruct env spec)-    JStruct env (JsonLet defs spec) =-      JStruct (defs : env) spec-    JStruct env (JsonRef ref) = LookupRef env env ref-    JStruct env JsonRaw = Value-    JStruct env (JsonAnnotated _annotations spec) =-      JStruct env spec +{-| A field in a 'JsonObject'. -}+data FieldSpec+  = Required Symbol Specification {-^ Required field. -}+  | Optional Symbol Specification {-^ Optional field. -} -{-|-  This is the "Haskell structure" type of 'JsonRef' references. -  The main reason why we need this is because of recursion, as explained-  below:+{-| Alias for 'Required'. -}+type (:::) = Required -  Since the specification is at the type level, and type level haskell-  is strict, specifying a recursive definition the "naive" way would-  cause an infinitely sized type. -  For example this won't work:+{-| Alias for 'Optional'. -}+type (::?) = Optional -  > data Foo = Foo [Foo]-  > instance HasJsonEncodingSpec Foo where-  >   type EncodingSpec Foo = JsonArray (EncodingSpec Foo)-  >   toJSONStructure = ... can't be written -  ... because @EncodingSpec Foo@ would expand strictly into an array of-  @EncodingSpec Foo@, which would expand strictly... to infinity.+{-| Alias for 'TypeBind'. -}+type (:=) = TypeBind -  Using `JsonLet` prevents the specification type from being infinitely-  sized, but what about the "structure" type which holds real values-  corresponding to the spec? The structure type has to have some way to-  reference itself or else it too would be infinitely sized. -  In order to "reference itself" the structure type has to go through-  a newtype somewhere along the way, and that's what this type is-  for. Whenever you use a 'JsonRef' in the spec, the corresponding-  structural type will have a 'Ref' newtype wrapper around the-  "dereferenced" structure type.+{-| Alias for 'ModuleBind'. -}+type (::=) = ModuleBind -  For example: -  > data Foo = Foo [Foo]-  > instance HasJsonEncodingSpec Foo where-  >   type EncodingSpec Foo =-  >     JsonLet-  >       '[ '("Foo", JsonArray (JsonRef "Foo")) ]-  >       (JsonRef "Foo")-  >   toJSONStructure (Foo fs) =-  >     Ref [ toJSONStructure <$> fs ]+{-|+  Types that provide a closed encoding 'Module'. -  Strictly speaking, we wouldn't /necessarily/ have to translate every-  'JsonRef' into a 'Ref'. In principal we could get away with inserting a-  'Ref' somewhere in every mutually recursive cycle. But the type level-  programming to figure that out a) probably wouldn't do any favors to-  compilation times, b) is beyond what I'm willing to attempted right-  now, and c) requires some kind of deterministic and stable choice-  about where to insert the 'Ref' (which I'm not even certain exists)-  lest arbitrary 'HasJsonEncodingSpec' or 'HasJsonDecodingSpec' instances-  break when the members of the recursive cycle change, causing a new-  choice about where to place the 'Ref'.+  Closed means the specification is self-contained: it cannot+  reference names from any outer 'JsonLet'. That is why the+  associated type has kind 'Module' rather than 'Specification'. -}-newtype Ref env spec = Ref-  { unRef :: JStruct env spec-  }---{-| Structural representation of 'JsonTag'. (I.e. a constant string value.) -}-data Tag (a :: Symbol) = Tag---{-| Structural representation of an object field. -}-newtype Field (key :: Symbol) t = Field t-  deriving stock (Show, Eq)-instance {-# overlappable #-} (HasField k more v) => HasField k (Field notIt x, more) v where-  getField (_, more) = getField @k @_ @v more-instance {-# overlappable #-} (HasField k more v) => HasField k (Maybe (Field notIt x), more) v where-  getField (_, more) = getField @k @_ @v more-instance HasField k (Maybe (Field k v), more) (Maybe v) where-  getField (mv, _) =-    case mv of-      Nothing -> Nothing-      Just (Field v) -> Just v-instance HasField k (Field k v, more) v where-  getField (Field v, _) = v-+class HasJsonEncodingSpec a where+  {-|+    The encoding specification. -unField :: Field key t -> t-unField (Field t) = t+    Kind 'Module' enforces closedness: no free references to an+    outer environment.+  -}+  type EncodingSpec a :: Module  -{- |-  Shorthand for demoting type-level strings.-  Use with -XTypeApplication, e.g.:--  This function doesn't really "go" in this module, it is only here because-  this module happens to be at the bottom of the dependency tree and so it is-  easy to stuff "reusable" things here, and I don't feel like creating a whole-  new module just for this function (although maybe I should).+{-|+  Types that provide a closed decoding 'Module'. -  > sym @var+  Closed means the specification is self-contained: it cannot+  reference names from any outer 'JsonLet'. That is why the+  associated type has kind 'Module' rather than 'Specification'. -}-sym-  :: forall a b.-     ( IsString b-     , KnownSymbol a-     )-  => b-sym = fromString $ symbolVal (Proxy @a)---type Env = [[(Symbol, Specification)]]+class HasJsonDecodingSpec a where+  {-|+    The decoding specification. +    Kind 'Module' enforces closedness: no free references to an+    outer environment.+  -}+  type DecodingSpec a :: Module

@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main (main) where++import Data.JsonSpec+  ( HasJsonEncodingSpec(EncodingSpec), Module(Module)+  , Specification+    ( JsonArray, JsonInt, JsonLet, JsonModule, JsonNum, JsonObject, JsonRef+    , JsonString+    )+  , type (:::), type (::=), type (:=)+  )+import Data.JsonSpec.Codec.Tuple+  ( Field(Field), Ref(Ref), TupleEncoding(toJsonStructure), encode+  )+import Data.Proxy (Proxy(Proxy))+import Data.Scientific (Scientific)+import Data.Text (Text, empty)+import Prelude ((.), (<$>), IO, Int, print)++data Money = Money+  { currency :: Text+  , amount :: Scientific+  }+instance HasJsonEncodingSpec Money where+  type EncodingSpec Money =+    'Module+      (JsonObject+      '[ "currency" ::: JsonString+       , "amount" ::: JsonNum+       ])+instance TupleEncoding Money where+  toJsonStructure money =+    ( Field money.currency+    , ( Field money.amount+      , ()))++data LineItem = LineItem+  { description :: Text+  , quantity :: Int+  , unitPrice :: Money+  , lineTotal :: Money+  }+instance HasJsonEncodingSpec LineItem where+  type EncodingSpec LineItem =+    'Module+      (JsonLet+      '[ "Money" ::= EncodingSpec Money ]+      ( JsonObject+          '[ "description" ::: JsonString+           , "quantity" ::: JsonInt+           , "unitPrice" ::: JsonRef "Money"+           , "lineTotal" ::: JsonRef "Money"+           ]+      ))+instance TupleEncoding LineItem where+  toJsonStructure li =+    ( Field li.description+    , ( Field li.quantity+      , ( Field (Ref (toJsonStructure li.unitPrice))+        , ( Field (Ref (toJsonStructure li.lineTotal))+          , ()))))++data Invoice = Invoice+  { invoiceNumber :: Text+  , items :: [LineItem]+  , featured :: [LineItem]+  }+instance HasJsonEncodingSpec Invoice where+  type EncodingSpec Invoice =+    'Module+      (JsonLet+      '[ "LineItem" := JsonModule (EncodingSpec LineItem) ]+      (JsonObject+        '[ "invoiceNumber" ::: JsonString+         , "items" ::: JsonArray (JsonRef "LineItem")+         , "featured" ::: JsonArray (JsonRef "LineItem")+         ]))+instance TupleEncoding Invoice where+  toJsonStructure inv =+    ( Field inv.invoiceNumber+    , ( Field @"items" (Ref . toJsonStructure <$> inv.items)+      , ( Field @"featured" (Ref . toJsonStructure <$> inv.featured)+        , ())))+++main :: IO ()+main =+  let+    money :: Money+    money =+      Money+        { currency = empty+        , amount = 0+        }++    lineItem :: LineItem+    lineItem =+      LineItem+        { description = empty+        , quantity = 0+        , unitPrice = money+        , lineTotal = money+        }++    invoice :: Invoice+    invoice =+      Invoice+        { invoiceNumber = empty+        , items = [lineItem]+        , featured = [lineItem]+        }+  in+    print+      (encode+        (Proxy @(EncodingSpec Invoice))+        (toJsonStructure invoice))

@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main (main) where++import Data.JsonSpec+  ( HasJsonEncodingSpec(EncodingSpec), Module(Module)+  , Specification(JsonInt, JsonLet, JsonModule, JsonObject, JsonRef, JsonString)+  , type (:::), type (:=)+  )+import Data.JsonSpec.Codec.Tuple+  ( Field(Field), Ref(Ref), TupleEncoding(toJsonStructure), encode+  )+import Data.Proxy (Proxy(Proxy))+import Prelude (IO, Int, print)++newtype Wrapper a = Wrapper a++instance+    HasJsonEncodingSpec (Wrapper a)+  where+    type EncodingSpec (Wrapper a) =+      'Module+        (JsonLet+        '[ "Unused" := JsonString ]+        (JsonObject '[ "payload" ::: JsonModule (EncodingSpec a)] ))++instance+    (TupleEncoding a)+  =>+    TupleEncoding (Wrapper a)+  where+    toJsonStructure (Wrapper w) = (Field @"payload" (toJsonStructure w), ())++newtype MyInt = MyInt Int+instance HasJsonEncodingSpec MyInt where+  type EncodingSpec MyInt  = 'Module (JsonInt)+instance TupleEncoding MyInt where+  toJsonStructure (MyInt i) = i+++newtype MyInt2 = MyInt2 Int+instance HasJsonEncodingSpec MyInt2 where+  type EncodingSpec MyInt2 =+    'Module+      (JsonLet '[ "Int" := JsonInt ] (JsonRef "Int"))+instance TupleEncoding MyInt2 where+  toJsonStructure (MyInt2 i) = Ref i+++main :: IO ()+main = do+  print+    (+      encode+        (Proxy @(EncodingSpec (Wrapper MyInt)))+        (toJsonStructure (Wrapper (MyInt 1)))+    )+  print+    (+      encode+        (Proxy @(EncodingSpec (Wrapper MyInt2)))+        (toJsonStructure (Wrapper (MyInt2 1)))+    )

@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main (main) where++import Data.JsonSpec+  ( HasJsonEncodingSpec(EncodingSpec), Module(Module)+  , Specification(JsonArray, JsonInt, JsonLet, JsonModule, JsonObject, JsonRef, JsonString)+  , type (:::), type (:=)+  )+import Data.JsonSpec.Codec.Tuple+  ( Field(Field), Ref(Ref), TupleEncoding(toJsonStructure), encode+  )+import Data.Proxy (Proxy(Proxy))+import Data.Text (Text, empty)+import Prelude ((.), (<$>), IO, Int, print)++-- A container polymorphic in its payload spec. Same shape as the library's+-- own Set instance. Compiles.+data LineItem a = LineItem+  { description :: Text+  , quantity :: Int+  , unitPrice :: a+  , lineTotal :: a+  }+instance HasJsonEncodingSpec (LineItem a) where+  type EncodingSpec (LineItem a) =+    'Module+      (JsonObject+      '[ "description" ::: JsonString+       , "quantity" ::: JsonInt+       , "unitPrice" ::: JsonModule (EncodingSpec a)+       , "lineTotal" ::: JsonModule (EncodingSpec a)+       ])+instance (TupleEncoding a) => TupleEncoding (LineItem a) where+  toJsonStructure li =+    ( Field li.description+    , ( Field li.quantity+      , ( Field (toJsonStructure li.unitPrice)+        , ( Field (toJsonStructure li.lineTotal)+          , ()))))++-- Name the LineItem spec in a JsonLet so we can share it within the invoice+-- spec, exactly as the Triangle/Vertex test names Vertex.+-- This will not compile.+data Invoice a = Invoice+  { invoiceNumber :: Text+  , items :: [LineItem a]+  }+instance HasJsonEncodingSpec (Invoice a) where+  type EncodingSpec (Invoice a) =+    'Module+      (JsonLet+      '[ "LineItem" := JsonModule (EncodingSpec (LineItem a)) ]+      (JsonObject+        '[ "invoiceNumber" ::: JsonString+         , "items" ::: JsonArray (JsonRef "LineItem")+         ]))+instance (TupleEncoding a) => TupleEncoding (Invoice a) where+  toJsonStructure inv =+    ( Field inv.invoiceNumber+    , ( Field (Ref . toJsonStructure <$> inv.items)+      , ()))+++newtype Money = Money Int+instance HasJsonEncodingSpec Money where+  type EncodingSpec Money  = 'Module (JsonInt)+instance TupleEncoding Money where+  toJsonStructure (Money i) = i+++main :: IO ()+main =+  let+    lineItem :: LineItem Money+    lineItem =+      LineItem+        { description = empty+        , quantity = 0+        , unitPrice = Money 0+        , lineTotal = Money 0+        }++    invoice :: Invoice Money+    invoice =+      Invoice+        { invoiceNumber = empty+        , items = [lineItem]+        }+  in+    print+      (encode+        (Proxy @(EncodingSpec (Invoice Money)))+        (toJsonStructure invoice))

@@ -28,17 +28,21 @@ import Data.ByteString.Lazy (ByteString) import Data.Either (isLeft) import Data.JsonSpec-  ( Field(Field), FieldSpec(Optional, Required)-  , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure)-  , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Ref(Ref)-  , SpecJSON(SpecJSON)+  ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required)+  , HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec)+  , Module(Module)   , Specification     ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither-    , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef-    , JsonString, JsonTag+    , JsonInt, JsonLet, JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw+    , JsonRef, JsonString, JsonTag     )-  , Tag(Tag), (:::), (::?), eitherDecode, encode, unField+  , type (:::), type (::?)   )+import Data.JsonSpec.Codec.Tuple+  ( Field(Field), Ref(Ref), SpecJson(SpecJson), Tag(Tag)+  , TupleDecoding(fromJsonStructure), TupleEncoding(toJsonStructure)+  , eitherDecode, encode, unField+  ) import Data.Map (Map) import Data.Proxy (Proxy(Proxy)) import Data.Scientific (Scientific)@@ -376,7 +380,7 @@             actual :: A.Value             actual =               encode-                (Proxy @(JsonDict JsonInt))+                (Proxy @('Module (JsonDict JsonInt)))                 Map.empty              expected :: A.Value@@ -396,13 +400,13 @@             decoded :: Either String (Map Text Int)             decoded =               eitherDecode-                (Proxy @(JsonDict JsonInt))+                (Proxy @('Module (JsonDict JsonInt)))                 raw              encoded :: Either String A.Value             encoded =               fmap-                (encode (Proxy @(JsonDict JsonInt)))+                (encode (Proxy @('Module (JsonDict JsonInt))))                 decoded              expected :: Either String A.Value@@ -438,10 +442,10 @@                      ())))             actual =               eitherDecode-                (Proxy @(JsonDict (JsonObject+                (Proxy @('Module (JsonDict (JsonObject                   '[ "foo" ::: JsonString                    , "bar" ::: JsonInt-                   ])))+                   ]))))                 raw              expected@@ -480,7 +484,7 @@             actual :: Either String (Map Text (Maybe Text))             actual =               eitherDecode-                (Proxy @(JsonDict (JsonNullable JsonString)))+                (Proxy @('Module (JsonDict (JsonNullable JsonString))))                 raw              expected :: Either String (Map Text (Maybe Text))@@ -498,7 +502,7 @@             actual :: Either String (Map Text Int)             actual =               eitherDecode-                (Proxy @(JsonDict JsonInt))+                (Proxy @('Module (JsonDict JsonInt)))                 (A.object [("bad", A.String "not an int")])           in             actual `shouldSatisfy` isLeft@@ -508,7 +512,7 @@             actual :: Either String (Map Text Int)             actual =               eitherDecode-                (Proxy @(JsonDict JsonInt))+                (Proxy @('Module (JsonDict JsonInt)))                 (A.String "not an object")           in             actual `shouldSatisfy` isLeft@@ -521,7 +525,7 @@                    (Field "attrs" (Map Text Int), ())             actual =               eitherDecode-                (Proxy @(JsonObject '[ "attrs" ::: JsonDict JsonInt ]))+                (Proxy @('Module (JsonObject '[ "attrs" ::: JsonDict JsonInt ])))                 ( A.object                     [ ( "attrs"                       , A.object@@ -568,7 +572,7 @@               A.eitherDecode                 "{ \"foo\": { \"bar\": \"barval\", \"baz\": [ \"qux\", 1, false ] } }"               >>=-                eitherDecode (Proxy @( JsonObject '[ "foo" ::: JsonRaw ]))+                eitherDecode (Proxy @('Module (JsonObject '[ "foo" ::: JsonRaw ])))           in             actual `shouldBe` expected         it "encodes" $@@ -582,7 +586,7 @@             actual =               Just $                 encode-                  (Proxy @( JsonObject '[ Required "foo" JsonRaw ]))+                  (Proxy @('Module (JsonObject '[ Required "foo" JsonRaw ])))                   (Field @"foo"                     (                       A.object@@ -864,11 +868,12 @@   = TestA Int Text   | TestB   deriving stock (Eq, Show)-  deriving ToJSON via (SpecJSON TestSum)-  deriving FromJSON via (SpecJSON TestSum)+  deriving ToJSON via (SpecJson TestSum)+  deriving FromJSON via (SpecJson TestSum) instance HasJsonEncodingSpec TestSum where   type EncodingSpec TestSum =-    JsonEither+    'Module+      (JsonEither       '[         JsonObject '[           Required "tag" (JsonTag "a"),@@ -880,8 +885,9 @@         JsonObject '[           Required "tag" (JsonTag "b")         ]-      ]-  toJSONStructure = \case+      ])+instance TupleEncoding TestSum where+  toJsonStructure = \case     TestA i t ->       Left         (Field @"tag" (Tag @"a"),@@ -899,7 +905,8 @@         ) instance HasJsonDecodingSpec TestSum where   type DecodingSpec TestSum = EncodingSpec TestSum-  fromJSONStructure = \case+instance TupleDecoding TestSum where+  fromJsonStructure = \case     Left         (Field @"tag" Tag,         (Field @"content"@@ -918,14 +925,16 @@   , bar :: Maybe (Maybe Text)   }   deriving stock (Show, Eq)-  deriving FromJSON via (SpecJSON TestOptionalHasField)+  deriving FromJSON via (SpecJson TestOptionalHasField) instance HasJsonDecodingSpec TestOptionalHasField where   type DecodingSpec TestOptionalHasField =-    JsonObject-     '[ "foo" ::? JsonString-      , "bar" ::? JsonNullable JsonString-      ]-  fromJSONStructure v =+    'Module+      (JsonObject+        '[ "foo" ::? JsonString+         , "bar" ::? JsonNullable JsonString+         ])+instance TupleDecoding TestOptionalHasField where+  fromJsonStructure v =     pure       TestOptionalHasField         { foo = v.foo@@ -941,28 +950,31 @@   , qoo :: Bool   }   deriving stock (Show, Eq)-  deriving ToJSON via (SpecJSON TestObj)-  deriving FromJSON via (SpecJSON TestObj)+  deriving ToJSON via (SpecJson TestObj)+  deriving FromJSON via (SpecJson TestObj) instance HasJsonEncodingSpec TestObj where   type EncodingSpec TestObj =-    JsonObject+    'Module+      (JsonObject       '[         Required "foo" JsonString,         Optional "bar" JsonNum,-        Required "baz" (EncodingSpec TestSubObj),+        Required "baz" (JsonModule (EncodingSpec TestSubObj)),         Required "qux" (JsonNullable JsonInt),         Required "qoo" JsonBool-      ]-  toJSONStructure TestObj { foo , bar , baz, qux, qoo } =+      ])+instance TupleEncoding TestObj where+  toJsonStructure TestObj { foo , bar , baz, qux, qoo } =     (Field @"foo" foo,     (fmap (Field @"bar" . realToFrac) bar,-    (Field @"baz" (toJSONStructure baz),+    (Field @"baz" (toJsonStructure baz),     (Field @"qux" qux,     (Field @"qoo" qoo,     ()))))) instance HasJsonDecodingSpec TestObj where   type DecodingSpec TestObj = EncodingSpec TestObj-  fromJSONStructure+instance TupleDecoding TestObj where+  fromJsonStructure       (Field @"foo" foo,       (fmap (unField @"bar") -> bar,       (Field @"baz" rawBaz,@@ -970,7 +982,7 @@       (Field @"qoo" qoo,       ())))))     = do-      baz <- fromJSONStructure rawBaz+      baz <- fromJsonStructure rawBaz       pure TestObj { foo, bar, baz, qux, qoo }  @@ -981,17 +993,20 @@   deriving stock (Show, Eq) instance HasJsonEncodingSpec TestSubObj where   type EncodingSpec TestSubObj =-    JsonObject+    'Module+      (JsonObject       '[ Required "foo" JsonString        , Required "bar" JsonInt-       ]-  toJSONStructure TestSubObj { foo2 , bar2 } =+       ])+instance TupleEncoding TestSubObj where+  toJsonStructure TestSubObj { foo2 , bar2 } =     (Field @"foo" foo2,     (Field @"bar" bar2,     ())) instance HasJsonDecodingSpec TestSubObj where   type DecodingSpec TestSubObj = EncodingSpec TestSubObj-  fromJSONStructure+instance TupleDecoding TestSubObj where+  fromJsonStructure       (Field @"foo" foo2,       (Field @"bar" bar2,       ()))@@ -1004,20 +1019,23 @@   , lastLogin :: UTCTime   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON User)+  deriving (ToJSON, FromJSON) via (SpecJson User) instance HasJsonEncodingSpec User where   type EncodingSpec User =-    JsonObject+    'Module+      (JsonObject       '[ Required "name" JsonString        , Required "last-login" JsonDateTime-       ]-  toJSONStructure user =+       ])+instance TupleEncoding User where+  toJsonStructure user =     (Field @"name" (name user),     (Field @"last-login" (lastLogin user),     ())) instance HasJsonDecodingSpec User where   type DecodingSpec User = EncodingSpec User-  fromJSONStructure+instance TupleDecoding User where+  fromJsonStructure       (Field @"name" name,       (Field @"last-login" lastLogin,       ()))@@ -1031,22 +1049,25 @@   , z :: Int   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON Vertex)+  deriving (ToJSON, FromJSON) via (SpecJson Vertex) instance HasJsonEncodingSpec Vertex where   type EncodingSpec Vertex =-    JsonObject+    'Module+      (JsonObject       '[ Required "x" JsonInt        , Required "y" JsonInt        , Required "z" JsonInt-       ]-  toJSONStructure Vertex {x, y, z} =+       ])+instance TupleEncoding Vertex where+  toJsonStructure Vertex {x, y, z} =     (Field @"x" x,     (Field @"y" y,     (Field @"z" z,     ()))) instance HasJsonDecodingSpec Vertex where   type DecodingSpec Vertex = EncodingSpec Vertex-  fromJSONStructure+instance TupleDecoding Vertex where+  fromJsonStructure       (Field @"x" x,       (Field @"y" y,       (Field @"z" z,@@ -1061,32 +1082,35 @@   , vertex3 :: Vertex   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON Triangle)+  deriving (ToJSON, FromJSON) via (SpecJson Triangle) instance HasJsonEncodingSpec Triangle where   type EncodingSpec Triangle =-    JsonLet-      '[ '("Vertex", EncodingSpec Vertex) ]+    'Module+      (JsonLet+      '[ ModuleBind "Vertex" (EncodingSpec Vertex) ]       (JsonObject         '[ Required "vertex1" (JsonRef "Vertex")          , Required "vertex2" (JsonRef "Vertex")          , Required "vertex3" (JsonRef "Vertex")-         ])-  toJSONStructure Triangle {vertex1, vertex2, vertex3} =-    (Field @"vertex1" (Ref $ toJSONStructure vertex1),-    (Field @"vertex2" (Ref $ toJSONStructure vertex2),-    (Field @"vertex3" (Ref $ toJSONStructure vertex3),+         ]))+instance TupleEncoding Triangle where+  toJsonStructure Triangle {vertex1, vertex2, vertex3} =+    (Field @"vertex1" (Ref $ toJsonStructure vertex1),+    (Field @"vertex2" (Ref $ toJsonStructure vertex2),+    (Field @"vertex3" (Ref $ toJsonStructure vertex3),     ()))) instance HasJsonDecodingSpec Triangle where   type DecodingSpec Triangle = EncodingSpec Triangle-  fromJSONStructure+instance TupleDecoding Triangle where+  fromJsonStructure       (Field @"vertex1" (Ref rawVertex1),       (Field @"vertex2" (Ref rawVertex2),       (Field @"vertex3" (Ref rawVertex3),       ())))     = do-      vertex1 <- fromJSONStructure rawVertex1-      vertex2 <- fromJSONStructure rawVertex2-      vertex3 <- fromJSONStructure rawVertex3+      vertex1 <- fromJsonStructure rawVertex1+      vertex2 <- fromJsonStructure rawVertex2+      vertex3 <- fromJsonStructure rawVertex3       pure Triangle{vertex1, vertex2, vertex3}  @@ -1095,29 +1119,32 @@   , children :: [LabelledTree]   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON LabelledTree)+  deriving (ToJSON, FromJSON) via (SpecJson LabelledTree) instance HasJsonEncodingSpec LabelledTree where   type EncodingSpec LabelledTree =-      JsonLet-        '[ '("LabelledTree",-               JsonObject-                 '[ Required "label" JsonString-                  , Required "children" (JsonArray (JsonRef "LabelledTree"))-                  ]-            )+    'Module+      (JsonLet+        '[ TypeBind "LabelledTree"+             (JsonObject+               '[ Required "label" JsonString+                , Required "children" (JsonArray (JsonRef "LabelledTree"))+                ]+             )          ]-        (JsonRef "LabelledTree")-  toJSONStructure LabelledTree {label , children } =+        (JsonRef "LabelledTree"))+instance TupleEncoding LabelledTree where+  toJsonStructure LabelledTree {label , children } =     Ref       (Field @"label" label,       (Field @"children"-        [ toJSONStructure child+        [ toJsonStructure child         | child <- children         ],       ())) instance HasJsonDecodingSpec LabelledTree where   type DecodingSpec LabelledTree = EncodingSpec LabelledTree-  fromJSONStructure+instance TupleDecoding LabelledTree where+  fromJsonStructure       (         Ref           (Field @"label" label,@@ -1125,7 +1152,7 @@           ()))       )     = do-      children <- traverse fromJSONStructure children_+      children <- traverse fromJsonStructure children_       pure LabelledTree { label , children }  @@ -1135,19 +1162,20 @@   , toBaz :: Maybe Int   , toQux :: Int   }-  deriving (ToJSON, FromJSON) via (SpecJSON TestOptionality)+  deriving (ToJSON, FromJSON) via (SpecJson TestOptionality)   deriving (Show) via (ShowJ TestOptionality)   deriving stock (Eq) instance HasJsonEncodingSpec TestOptionality where   type EncodingSpec TestOptionality =-    JsonObject+    'Module+      (JsonObject       '[ "foo" ::? JsonInt        , Required "bar" (JsonNullable JsonInt)        , Optional "baz" (JsonNullable JsonInt)        , Required "qux" JsonInt-       ]--  toJSONStructure TestOptionality { toFoo , toBar , toBaz , toQux } =+       ])+instance TupleEncoding TestOptionality where+  toJsonStructure TestOptionality { toFoo , toBar , toBaz , toQux } =     (fmap (Field @"foo") toFoo,     (Field @"bar" toBar,     ((Just . Field @"baz") toBaz, -- when encoding, prefer explicit null for testing.@@ -1155,8 +1183,8 @@     ())))) instance HasJsonDecodingSpec TestOptionality where   type DecodingSpec TestOptionality = EncodingSpec TestOptionality--  fromJSONStructure+instance TupleDecoding TestOptionality where+  fromJsonStructure       (fmap (unField @"foo") -> toFoo,       (Field @"bar" toBar,       (join . fmap (unField @"baz") -> toBaz,@@ -1172,18 +1200,20 @@   , thfBaz :: TestSubObj   }   deriving stock (Show, Eq)-  deriving (FromJSON) via (SpecJSON TestHasField)+  deriving (FromJSON) via (SpecJson TestHasField) instance HasJsonDecodingSpec TestHasField where   type DecodingSpec TestHasField =-    JsonObject-      '[ "foo" ::: JsonString-       , "bar" ::: JsonInt-       , "baz" ::: JsonObject-                    '[ "a_string" ::: JsonString-                     ,   "an_int" ::: JsonInt-                     ]-       ]-  fromJSONStructure val =+    'Module+      (JsonObject+        '[ "foo" ::: JsonString+         , "bar" ::: JsonInt+         , "baz" ::: JsonObject+                       '[ "a_string" ::: JsonString+                        ,   "an_int" ::: JsonInt+                        ]+         ])+instance TupleDecoding TestHasField where+  fromJsonStructure val =     pure       TestHasField         { thfFoo = val.foo@@ -1201,31 +1231,32 @@ {- ========================================================================== -}  newtype MRec1 = MRec1 [MRec2]-  deriving (ToJSON, FromJSON) via (SpecJSON MRec1)+  deriving (ToJSON, FromJSON) via (SpecJson MRec1)   deriving stock (Show, Eq) newtype MRec2 = MRec2 [MRec1]   deriving stock (Show, Eq) instance HasJsonEncodingSpec MRec1 where   type EncodingSpec MRec1 =-    JsonLet-     '[ '("one", JsonArray (JsonRef "two"))-      , '("two", JsonArray (JsonRef "one"))+    'Module+      (JsonLet+     '[ TypeBind "one" (JsonArray (JsonRef "two"))+      , TypeBind "two" (JsonArray (JsonRef "one"))       ]-      (JsonRef "one")--  toJSONStructure (MRec1 m2s) =+      (JsonRef "one"))+instance TupleEncoding MRec1 where+  toJsonStructure (MRec1 m2s) =     Ref-      [ Ref (fmap toJSONStructure m1s)+      [ Ref (fmap toJsonStructure m1s)       | MRec2 m1s <- m2s       ] instance HasJsonDecodingSpec MRec1 where   type DecodingSpec MRec1 = EncodingSpec MRec1--  fromJSONStructure (Ref m2s_) = do+instance TupleDecoding MRec1 where+  fromJsonStructure (Ref m2s_) = do     m2s <-       traverse         (\(Ref m1s_) -> do-          m1s <- traverse fromJSONStructure m1s_+          m1s <- traverse fromJsonStructure m1s_           pure (MRec2 m1s)         )         m2s_@@ -1236,16 +1267,16 @@ {- ========================================================================== -}  type SharedRecSpecs =-  '[ '( "three"-      , JsonObject+  '[ TypeBind "three"+       (JsonObject          '[ "foo" ::: JsonNullable (JsonRef "four")           ]-      )-   , '( "four"-      , JsonObject+       )+   , TypeBind "four"+       (JsonObject          '[ "bar" ::: JsonRef "three"           ]-      )+       )    ]  @@ -1253,20 +1284,22 @@   { foo :: Maybe MRec4   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON MRec3)+  deriving (ToJSON, FromJSON) via (SpecJson MRec3) instance HasJsonEncodingSpec MRec3 where   type EncodingSpec MRec3 =-    JsonLet SharedRecSpecs (JsonRef "three")--  toJSONStructure MRec3 { foo } =+    'Module+      (JsonLet SharedRecSpecs (JsonRef "three"))+instance TupleEncoding MRec3 where+  toJsonStructure MRec3 { foo } =     Ref-      (Field @"foo" (fmap toJSONStructure foo),+      (Field @"foo" (fmap toJsonStructure foo),       ()) instance HasJsonDecodingSpec MRec3 where   type DecodingSpec MRec3 = EncodingSpec MRec3-  fromJSONStructure ( Ref (Field @"foo" rawFoo, ()))+instance TupleDecoding MRec3 where+  fromJsonStructure ( Ref (Field @"foo" rawFoo, ()))     = do-      foo <- traverse fromJSONStructure rawFoo+      foo <- traverse fromJsonStructure rawFoo       pure MRec3 { foo }  @@ -1276,16 +1309,19 @@   deriving stock (Show, Eq) instance HasJsonEncodingSpec MRec4 where   type EncodingSpec MRec4 =-    JsonLet SharedRecSpecs (JsonRef "four")-  toJSONStructure MRec4 { bar } =+    'Module+      (JsonLet SharedRecSpecs (JsonRef "four"))+instance TupleEncoding MRec4 where+  toJsonStructure MRec4 { bar } =     Ref-      (Field @"bar" (toJSONStructure bar),+      (Field @"bar" (toJsonStructure bar),       ()) instance HasJsonDecodingSpec MRec4 where   type DecodingSpec MRec4 = EncodingSpec MRec4-  fromJSONStructure ( Ref (Field @"bar" rawbar, ()))+instance TupleDecoding MRec4 where+  fromJsonStructure ( Ref (Field @"bar" rawbar, ()))     = do-      bar <- fromJSONStructure rawbar+      bar <- fromJsonStructure rawbar       pure MRec4 { bar }  {- ========================================================================== -}@@ -1299,24 +1335,27 @@   ,  auAge :: Int   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser)+  deriving (ToJSON, FromJSON) via (SpecJson AnnotatedUser) instance HasJsonEncodingSpec AnnotatedUser where   type EncodingSpec AnnotatedUser =-    JsonAnnotated+    'Module+      (JsonAnnotated       '[ '("description", "A user with a name and age")        , '("example", "{\"name\": \"alice\", \"age\": 30}")        ]       (JsonObject         '[ Required "name" JsonString          , Required "age" JsonInt-         ])-  toJSONStructure AnnotatedUser { auName, auAge } =+         ]))+instance TupleEncoding AnnotatedUser where+  toJsonStructure AnnotatedUser { auName, auAge } =     (Field @"name" auName,     (Field @"age" auAge,     ())) instance HasJsonDecodingSpec AnnotatedUser where   type DecodingSpec AnnotatedUser = EncodingSpec AnnotatedUser-  fromJSONStructure+instance TupleDecoding AnnotatedUser where+  fromJsonStructure       (Field @"name" auName,       (Field @"age" auAge,       ()))@@ -1330,24 +1369,27 @@   , avZ :: Int   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedVertex)+  deriving (ToJSON, FromJSON) via (SpecJson AnnotatedVertex) instance HasJsonEncodingSpec AnnotatedVertex where   type EncodingSpec AnnotatedVertex =-    JsonAnnotated+    'Module+      (JsonAnnotated       '[ '("description", "A 3D vertex") ]       (JsonObject         '[ Required "x" JsonInt          , Required "y" JsonInt          , Required "z" JsonInt-         ])-  toJSONStructure AnnotatedVertex { avX, avY, avZ } =+         ]))+instance TupleEncoding AnnotatedVertex where+  toJsonStructure AnnotatedVertex { avX, avY, avZ } =     (Field @"x" avX,     (Field @"y" avY,     (Field @"z" avZ,     ()))) instance HasJsonDecodingSpec AnnotatedVertex where   type DecodingSpec AnnotatedVertex = EncodingSpec AnnotatedVertex-  fromJSONStructure+instance TupleDecoding AnnotatedVertex where+  fromJsonStructure       (Field @"x" avX,       (Field @"y" avY,       (Field @"z" avZ,@@ -1362,18 +1404,19 @@   , atVertex3 :: AnnotatedVertex   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedTriangle)+  deriving (ToJSON, FromJSON) via (SpecJson AnnotatedTriangle) instance HasJsonEncodingSpec AnnotatedTriangle where   type EncodingSpec AnnotatedTriangle =-    JsonLet-      '[ '("Vertex",-             JsonAnnotated-               '[ '("description", "A 3D vertex used in shapes") ]-               (JsonObject-                 '[ Required "x" JsonInt-                  , Required "y" JsonInt-                  , Required "z" JsonInt-                  ]))+    'Module+      (JsonLet+      '[ TypeBind "Vertex"+           (JsonAnnotated+             '[ '("description", "A 3D vertex used in shapes") ]+             (JsonObject+               '[ Required "x" JsonInt+                , Required "y" JsonInt+                , Required "z" JsonInt+                ]))        ]       (JsonAnnotated         '[ '("description", "A triangle with three vertices") ]@@ -1381,23 +1424,25 @@           '[ Required "vertex1" (JsonRef "Vertex")            , Required "vertex2" (JsonRef "Vertex")            , Required "vertex3" (JsonRef "Vertex")-           ]))-  toJSONStructure AnnotatedTriangle { atVertex1, atVertex2, atVertex3 } =-    (Field @"vertex1" (Ref $ toJSONStructure atVertex1),-    (Field @"vertex2" (Ref $ toJSONStructure atVertex2),-    (Field @"vertex3" (Ref $ toJSONStructure atVertex3),+           ])))+instance TupleEncoding AnnotatedTriangle where+  toJsonStructure AnnotatedTriangle { atVertex1, atVertex2, atVertex3 } =+    (Field @"vertex1" (Ref $ toJsonStructure atVertex1),+    (Field @"vertex2" (Ref $ toJsonStructure atVertex2),+    (Field @"vertex3" (Ref $ toJsonStructure atVertex3),     ()))) instance HasJsonDecodingSpec AnnotatedTriangle where   type DecodingSpec AnnotatedTriangle = EncodingSpec AnnotatedTriangle-  fromJSONStructure+instance TupleDecoding AnnotatedTriangle where+  fromJsonStructure       (Field @"vertex1" (Ref rawVertex1),       (Field @"vertex2" (Ref rawVertex2),       (Field @"vertex3" (Ref rawVertex3),       ())))     = do-      atVertex1 <- fromJSONStructure rawVertex1-      atVertex2 <- fromJSONStructure rawVertex2-      atVertex3 <- fromJSONStructure rawVertex3+      atVertex1 <- fromJsonStructure rawVertex1+      atVertex2 <- fromJsonStructure rawVertex2+      atVertex3 <- fromJsonStructure rawVertex3       pure AnnotatedTriangle { atVertex1, atVertex2, atVertex3 }  @@ -1405,20 +1450,23 @@   { awbName :: Text   }   deriving stock (Show, Eq)-  deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedWithBool)+  deriving (ToJSON, FromJSON) via (SpecJson AnnotatedWithBool) instance HasJsonEncodingSpec AnnotatedWithBool where   type EncodingSpec AnnotatedWithBool =-    JsonAnnotated+    'Module+      (JsonAnnotated       '[ '("readOnly", 'True)        , '("deprecated", 'False)        ]-      (JsonObject '[ Required "name" JsonString ])-  toJSONStructure AnnotatedWithBool { awbName } =+      (JsonObject '[ Required "name" JsonString ]))+instance TupleEncoding AnnotatedWithBool where+  toJsonStructure AnnotatedWithBool { awbName } =     (Field @"name" awbName,     ()) instance HasJsonDecodingSpec AnnotatedWithBool where   type DecodingSpec AnnotatedWithBool = EncodingSpec AnnotatedWithBool-  fromJSONStructure+instance TupleDecoding AnnotatedWithBool where+  fromJsonStructure       (Field @"name" awbName,       ())     =

@@ -0,0 +1,506 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Werror=missing-import-lists #-}++module Main (main) where++import Data.Either (isLeft)+import Data.JsonSpec+  ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required)+  , Module(Module)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  )+import Data.JsonSpec.Language.Parser+  ( Binding(ModuleBinding, TypeBinding), Field(Field), Program(Program)+  , Spec+    ( ArraySpec, BoolSpec, DateTimeSpec, DictSpec, EitherSpec, IntSpec, LetSpec+    , NullSpec, NumberSpec, ObjectSpec, RawSpec, RefSpec, StringSpec, TagSpec+    )+  , parseProgram+  )+import Data.JsonSpec.Language.QQ (jsonspec)+import Data.Text (Text)+import Prelude (Applicative(pure), Bool(False, True), Either(Right), ($), IO)+import Test.Hspec (describe, hspec, it, shouldBe, shouldSatisfy)+import qualified Test.Hspec as Hspec++{-| Proxy for types of kind 'Module'. -}+data Mod (m :: Module) = Mod+++main :: IO ()+main =+  hspec suite+++suite :: Hspec.Spec+suite = do+  describe "parser" parserTests+  describe "quasi-quoter" qqTests+++parserTests :: Hspec.Spec+parserTests = do+  it "parses a trivial module" $+    parseProgram "trivial" "module Id = string"+      `shouldBe`+        Right (Program "Id" StringSpec)++  it "parses Person from the language spec" $+    parseProgram "Person" personSrc+      `shouldBe`+        Right (Program "Person" personAst)++  it "parses Graphs mutual recursion" $+    parseProgram "Graphs" graphsSrc+      `shouldBe`+        Right (Program "Graphs" graphsAst)++  it "parses Demo with nested closed module" $+    parseProgram "Demo" demoSrc+      `shouldBe`+        Right (Program "Demo" demoAst)++  it "parses either, dict, null, tags, and primitives" $+    parseProgram "Kitchen" kitchenSrc+      `shouldBe`+        Right (Program "Kitchen" kitchenAst)++  it "allows comments and trailing commas" $+    parseProgram "Comments" commentsSrc+      `shouldBe`+        Right+          (Program "Comments"+            (ObjectSpec+              [ Field "a" False IntSpec+              , Field "b" True StringSpec+              ]))++  it "rejects duplicate field names" $+    parseProgram "DupField"+      "module X = { \"a\": int, \"a\": string }"+      `shouldSatisfy` isLeft++  it "rejects duplicate binding names" $+    parseProgram "DupBind"+      "module X = let { type A = int type A = string in A }"+      `shouldSatisfy` isLeft++  it "rejects keyword used as bare identifier" $+    parseProgram "Keyword"+      "module type = string"+      `shouldSatisfy` isLeft++  it "allows backtick-escaped keyword as module name" $+    parseProgram "EscapedMod"+      "module `type` = string"+      `shouldBe`+        Right (Program "type" StringSpec)++  it "allows backtick-escaped keyword bind and ref" $+    parseProgram "EscapedBind"+      "module X = let { type `string` = int in `string` }"+      `shouldBe`+        Right+          (Program "X"+            (LetSpec+              [TypeBinding "string" IntSpec]+              (RefSpec "string")))++  it "keeps bare string as the primitive, not a ref" $+    parseProgram "BarePrim"+      "module X = let { type `string` = int in string }"+      `shouldBe`+        Right+          (Program "X"+            (LetSpec+              [TypeBinding "string" IntSpec]+              StringSpec))+++qqTests :: Hspec.Spec+qqTests = do+  it "quotes a trivial module" $+    sameModule+      (Mod @TrivialQuoted)+      (Mod @('Module 'JsonString))++  it "quotes Person" $+    sameModule+      (Mod @PersonQuoted)+      (Mod @PersonExpected)++  it "quotes the exhaustive Demo program" $+    sameModule+      (Mod @DemoQuoted)+      (Mod @DemoExpected)++  it "quotes either / dict / tags / datetime / raw" $+    sameModule+      (Mod @KitchenQuoted)+      (Mod @KitchenExpected)++  it "quotes backtick-escaped keyword bind and ref" $+    sameModule+      (Mod @EscapedQuoted)+      (Mod @EscapedExpected)+++sameModule+  :: Mod a+  -> Mod a+  -> IO ()+sameModule _ _ =+  pure ()+++type TrivialQuoted =+  [jsonspec| module Id = string |]+++type EscapedQuoted =+  [jsonspec|+    module X = let {+      module `let` = let {+        type `module` = int+        in `module`+      }+      type `string` = int+      in `string`+    }+  |]+++type EscapedExpected =+  'Module+    (JsonLet+      '[ ModuleBind "let" (+           'Module (+             JsonLet+               '[ TypeBind "module" JsonInt ]+               (JsonRef "module")+           )+         )+       , TypeBind "string" JsonInt+       ]+       (JsonRef "string"))+++type PersonQuoted =+  [jsonspec|+    module Person = let {+      type Person = {+        "name": string,+        "age": int,+        "email"?: null string+      }+      in Person+    }+  |]+++type PersonExpected =+  'Module+    (JsonLet+      '[ TypeBind "Person"+          (JsonObject+            '[ Required "name" JsonString+             , Required "age" JsonInt+             , Optional "email" (JsonNullable JsonString)+             ])+       ]+      (JsonRef "Person"))+++type DemoQuoted =+  [jsonspec|+    module Demo = let {+      type Id = string++      type Money = {+        "amount": number,+        "currency": string+      }++      -- Closed: cannot see Id or Money; define what it needs locally.+      module Tax = let {+        type Rate = number+        type Line = {+          "sku": string,+          "qty": int,+          "price": {+            "amount": number,+            "currency": string+          }+        }+        in {+          "rate": Rate,+          "lines": [Line]+        }+      }++      -- Open let: may use Id, Money, Tax from the enclosing frame.+      type Invoice = let {+        type Line = {+          "sku": string,+          "qty": int,+          "price": Money+        }+        in {+          "id": Id,+          "items": [Line],+          "tax": Tax,+          "notes"?: null string+        }+      }++      in Invoice+    }+  |]+++type DemoExpected =+  'Module+    (JsonLet+      '[ TypeBind "Id" JsonString+       , TypeBind "Money"+          (JsonObject+            '[ Required "amount" JsonNum+             , Required "currency" JsonString+             ])+       , ModuleBind "Tax"+          ('Module+            (JsonLet+              '[ TypeBind "Rate" JsonNum+               , TypeBind "Line"+                  (JsonObject+                    '[ Required "sku" JsonString+                     , Required "qty" JsonInt+                     , Required "price"+                        (JsonObject+                          '[ Required "amount" JsonNum+                           , Required "currency" JsonString+                           ])+                     ])+               ]+              (JsonObject+                '[ Required "rate" (JsonRef "Rate")+                 , Required "lines" (JsonArray (JsonRef "Line"))+                 ])))+       , TypeBind "Invoice"+          (JsonLet+            '[ TypeBind "Line"+                (JsonObject+                  '[ Required "sku" JsonString+                   , Required "qty" JsonInt+                   , Required "price" (JsonRef "Money")+                   ])+             ]+            (JsonObject+              '[ Required "id" (JsonRef "Id")+               , Required "items" (JsonArray (JsonRef "Line"))+               , Required "tax" (JsonRef "Tax")+               , Optional "notes" (JsonNullable JsonString)+               ]))+       ]+      (JsonRef "Invoice"))+++type KitchenQuoted =+  [jsonspec|+    module Kitchen = {+      "tag": "ok",+      "choice": either int | string | bool,+      "meta": dict datetime,+      "payload": null raw+    }+  |]+++type KitchenExpected =+  'Module+    (JsonObject+      '[ Required "tag" (JsonTag "ok")+       , Required "choice" (JsonEither '[JsonInt, JsonString, JsonBool])+       , Required "meta" (JsonDict JsonDateTime)+       , Required "payload" (JsonNullable JsonRaw)+       ])+++personSrc :: Text+personSrc =+  "module Person = let {\n\+  \  type Person = {\n\+  \    \"name\": string,\n\+  \    \"age\": int,\n\+  \    \"email\"?: null string\n\+  \  }\n\+  \  in Person\n\+  \}"+++personAst :: Spec+personAst =+  LetSpec+    [ TypeBinding "Person"+        (ObjectSpec+          [ Field "name" False StringSpec+          , Field "age" False IntSpec+          , Field "email" True (NullSpec StringSpec)+          ])+    ]+    (RefSpec "Person")+++graphsSrc :: Text+graphsSrc =+  "module Graphs = let {\n\+  \  type Node = {\n\+  \    \"id\": string,\n\+  \    \"edges\": [Edge]\n\+  \  }\n\+  \  type Edge = {\n\+  \    \"from\": Node,\n\+  \    \"to\": Node\n\+  \  }\n\+  \  in Node\n\+  \}"+++graphsAst :: Spec+graphsAst =+  LetSpec+    [ TypeBinding "Node"+        (ObjectSpec+          [ Field "id" False StringSpec+          , Field "edges" False (ArraySpec (RefSpec "Edge"))+          ])+    , TypeBinding "Edge"+        (ObjectSpec+          [ Field "from" False (RefSpec "Node")+          , Field "to" False (RefSpec "Node")+          ])+    ]+    (RefSpec "Node")+++demoSrc :: Text+demoSrc =+  "module Demo = let {\n\+  \  type Id = string\n\+  \  type Money = {\n\+  \    \"amount\": number,\n\+  \    \"currency\": string\n\+  \  }\n\+  \  module Tax = let {\n\+  \    type Rate = number\n\+  \    type Line = {\n\+  \      \"sku\": string,\n\+  \      \"qty\": int,\n\+  \      \"price\": {\n\+  \        \"amount\": number,\n\+  \        \"currency\": string\n\+  \      }\n\+  \    }\n\+  \    in {\n\+  \      \"rate\": Rate,\n\+  \      \"lines\": [Line]\n\+  \    }\n\+  \  }\n\+  \  type Invoice = let {\n\+  \    type Line = {\n\+  \      \"sku\": string,\n\+  \      \"qty\": int,\n\+  \      \"price\": Money\n\+  \    }\n\+  \    in {\n\+  \      \"id\": Id,\n\+  \      \"items\": [Line],\n\+  \      \"tax\": Tax,\n\+  \      \"notes\"?: null string\n\+  \    }\n\+  \  }\n\+  \  in Invoice\n\+  \}"+++demoAst :: Spec+demoAst =+  LetSpec+    [ TypeBinding "Id" StringSpec+    , TypeBinding "Money"+        (ObjectSpec+          [ Field "amount" False NumberSpec+          , Field "currency" False StringSpec+          ])+    , ModuleBinding "Tax"+        (LetSpec+          [ TypeBinding "Rate" NumberSpec+          , TypeBinding "Line"+              (ObjectSpec+                [ Field "sku" False StringSpec+                , Field "qty" False IntSpec+                , Field "price" False+                    (ObjectSpec+                      [ Field "amount" False NumberSpec+                      , Field "currency" False StringSpec+                      ])+                ])+          ]+          (ObjectSpec+            [ Field "rate" False (RefSpec "Rate")+            , Field "lines" False (ArraySpec (RefSpec "Line"))+            ]))+    , TypeBinding "Invoice"+        (LetSpec+          [ TypeBinding "Line"+              (ObjectSpec+                [ Field "sku" False StringSpec+                , Field "qty" False IntSpec+                , Field "price" False (RefSpec "Money")+                ])+          ]+          (ObjectSpec+            [ Field "id" False (RefSpec "Id")+            , Field "items" False (ArraySpec (RefSpec "Line"))+            , Field "tax" False (RefSpec "Tax")+            , Field "notes" True (NullSpec StringSpec)+            ]))+    ]+    (RefSpec "Invoice")+++kitchenSrc :: Text+kitchenSrc =+  "module Kitchen = {\n\+  \  \"tag\": \"ok\",\n\+  \  \"choice\": either int | string | bool,\n\+  \  \"meta\": dict datetime,\n\+  \  \"payload\": null raw\n\+  \}"+++kitchenAst :: Spec+kitchenAst =+  ObjectSpec+    [ Field "tag" False (TagSpec "ok")+    , Field "choice" False+        (EitherSpec [IntSpec, StringSpec, BoolSpec])+    , Field "meta" False (DictSpec DateTimeSpec)+    , Field "payload" False (NullSpec RawSpec)+    ]+++commentsSrc :: Text+commentsSrc =+  "module Comments = {- block -} {\n\+  \  \"a\": int, -- line comment\n\+  \  \"b\"?: string,\n\+  \}"

@@ -17,9 +17,10 @@ module Main (main) where  import Data.JsonSpec-  ( HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Ref(Ref)-  , Specification(JsonLet, JsonRef, JsonString)+  ( HasJsonEncodingSpec(EncodingSpec), Module(Module)+  , Specification(JsonLet, JsonRef, JsonString), type (:=)   )+import Data.JsonSpec.Codec.Tuple (Ref(Ref), TupleEncoding(toJsonStructure)) import Data.Text (Text) import Prelude (Applicative(pure), ($), (.), Eq, IO, Ord) @@ -46,22 +47,23 @@  {-| Shared specification definitions. -} type TestShared a =-  JsonLet-    '[ '( "Foo"-        , JsonLet '[ '("bar", JsonRef "Baz") ] (JsonRef "bar")-        )-     , '( "Baz" , JsonString)-     ]-    (JsonRef a)+    JsonLet+      '[ "Foo" :=+           (JsonLet '[ "bar" := JsonRef "Baz" ] (JsonRef "bar"))+       , "Baz" := JsonString+       ]+      (JsonRef a)   newtype Foo = Foo Baz   deriving stock (Eq, Ord) instance HasJsonEncodingSpec Foo where   type EncodingSpec Foo =-    TestShared "Foo"-  toJSONStructure (Foo val) =-    Ref . Ref . toJSONStructure $ val+    'Module+      (TestShared "Foo")+instance TupleEncoding Foo where+  toJsonStructure (Foo val) =+    Ref . Ref . toJsonStructure $ val   newtype Baz = Baz Text@@ -71,7 +73,7 @@     ) instance HasJsonEncodingSpec Baz where   type EncodingSpec Baz =-    TestShared "Baz"-  toJSONStructure (Baz val) = Ref val--+    'Module+      (TestShared "Baz")+instance TupleEncoding Baz where+  toJsonStructure (Baz val) = Ref val