diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/json-spec.cabal b/json-spec.cabal --- a/json-spec.cabal +++ b/json-spec.cabal @@ -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 diff --git a/src/Data/JsonSpec.hs b/src/Data/JsonSpec.hs --- a/src/Data/JsonSpec.hs +++ b/src/Data/JsonSpec.hs @@ -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) - diff --git a/src/Data/JsonSpec/Codec/Tuple.hs b/src/Data/JsonSpec/Codec/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Codec/Tuple.hs @@ -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) diff --git a/src/Data/JsonSpec/Codec/Tuple/Decode.hs b/src/Data/JsonSpec/Codec/Tuple/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Codec/Tuple/Decode.hs @@ -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 diff --git a/src/Data/JsonSpec/Codec/Tuple/Encode.hs b/src/Data/JsonSpec/Codec/Tuple/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Codec/Tuple/Encode.hs @@ -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 diff --git a/src/Data/JsonSpec/Codec/Tuple/Internal.hs b/src/Data/JsonSpec/Codec/Tuple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Codec/Tuple/Internal.hs @@ -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)]] diff --git a/src/Data/JsonSpec/Decode.hs b/src/Data/JsonSpec/Decode.hs deleted file mode 100644 --- a/src/Data/JsonSpec/Decode.hs +++ /dev/null @@ -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 - - diff --git a/src/Data/JsonSpec/Encode.hs b/src/Data/JsonSpec/Encode.hs deleted file mode 100644 --- a/src/Data/JsonSpec/Encode.hs +++ /dev/null @@ -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 - - diff --git a/src/Data/JsonSpec/Language/Parser.hs b/src/Data/JsonSpec/Language/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Language/Parser.hs @@ -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 diff --git a/src/Data/JsonSpec/Language/QQ.hs b/src/Data/JsonSpec/Language/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Language/QQ.hs @@ -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 = \@). 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)) diff --git a/src/Data/JsonSpec/Spec.hs b/src/Data/JsonSpec/Spec.hs --- a/src/Data/JsonSpec/Spec.hs +++ b/src/Data/JsonSpec/Spec.hs @@ -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 diff --git a/test/jsonlet.hs b/test/jsonlet.hs new file mode 100644 --- /dev/null +++ b/test/jsonlet.hs @@ -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)) diff --git a/test/jsonlet2.hs b/test/jsonlet2.hs new file mode 100644 --- /dev/null +++ b/test/jsonlet2.hs @@ -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))) + ) diff --git a/test/jsonlet3.hs b/test/jsonlet3.hs new file mode 100644 --- /dev/null +++ b/test/jsonlet3.hs @@ -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)) diff --git a/test/jsonspec.hs b/test/jsonspec.hs --- a/test/jsonspec.hs +++ b/test/jsonspec.hs @@ -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, ()) = diff --git a/test/language.hs b/test/language.hs new file mode 100644 --- /dev/null +++ b/test/language.hs @@ -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\ + \}" diff --git a/test/stable-environment.hs b/test/stable-environment.hs --- a/test/stable-environment.hs +++ b/test/stable-environment.hs @@ -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