diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ Historically, the trade-off has been: 1. Use Generic instances, and therefore your API is brittle. Changes - to Deeply nested object might unexpectedly change (and break) your + to a deeply nested object might unexpectedly change (and break) your API. You must structure your Haskell types exactly as they are rendered into JSON, which may not always be "natural" and easy to work with. In exchange, you get the ability to auto-derive matching diff --git a/json-spec.cabal b/json-spec.cabal --- a/json-spec.cabal +++ b/json-spec.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec -version: 1.0.1.0 +version: 1.1.0.0 synopsis: Type-level JSON specification maintainer: rick@owensmurray.com description: See the README at: https://github.com/owensmurray/json-spec#json-spec @@ -47,6 +47,19 @@ test-suite jsonspec import: dependencies, warnings main-is: jsonspec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + , json-spec + , bytestring >= 0.11.1.0 && < 0.13 + , hspec >= 2.8.5 && < 2.12 + , om-show >= 0.1.2.9 && < 0.2 + + +test-suite stable-environment + import: dependencies, warnings + main-is: stable-environment.hs type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Data/JsonSpec.hs b/src/Data/JsonSpec.hs --- a/src/Data/JsonSpec.hs +++ b/src/Data/JsonSpec.hs @@ -42,7 +42,7 @@ Historically, the trade-off has been: 1. Use Generic instances, and therefore your API is brittle. Changes - to Deeply nested object might unexpectedly change (and break) your + to a deeply nested object might unexpectedly change (and break) your API. You must structure your Haskell types exactly as they are rendered into JSON, which may not always be "natural" and easy to work with. In exchange, you get the ability to auto-derive matching 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 @@ -153,9 +153,9 @@ > ]) > ] > (JsonObject '[ - > Required "vertex1" JsonRef "Vertex", - > Required "vertex2" JsonRef "Vertex", - > Required "vertex3" JsonRef "Vertex" + > "vertex1" ::: JsonRef "Vertex", + > "vertex2" ::: JsonRef "Vertex", + > "vertex3" ::: JsonRef "Vertex" > ]) Another use is to define recursive types: @@ -164,8 +164,8 @@ > JsonLet > '[ > '("LabelledTree", JsonObject '[ - > Required "label", JsonString, - > Required "children" (JsonArray (JsonRef "LabelledTree")) + > "label" ::: JsonString, + > "children" ::: JsonArray (JsonRef "LabelledTree") > ]) > ] > (JsonRef "LabelledTree") @@ -221,11 +221,42 @@ JSONStructure spec = JStruct '[] spec -type family Lookup env k where - Lookup ('(k, v) : more) k = v - Lookup (_ : more) k = Lookup more k +{-| + 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) @@ -233,7 +264,7 @@ type family JStruct - (env :: [(Symbol, Specification)]) + (env :: Env) (spec :: Specification) :: Type where @@ -259,8 +290,8 @@ JStruct env JsonDateTime = UTCTime JStruct env (JsonNullable spec) = Maybe (JStruct env spec) JStruct env (JsonLet defs spec) = - JStruct (PushAll defs env) spec - JStruct env (JsonRef ref) = Ref env (Lookup env ref) + JStruct (defs : env) spec + JStruct env (JsonRef ref) = LookupRef env env ref JStruct env JsonRaw = Value @@ -357,5 +388,8 @@ ) => b sym = fromString $ symbolVal (Proxy @a) + + +type Env = [[(Symbol, Specification)]] diff --git a/test/stable-environment.hs b/test/stable-environment.hs new file mode 100644 --- /dev/null +++ b/test/stable-environment.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import Data.JsonSpec + ( HasJsonEncodingSpec(EncodingSpec, toJSONStructure), Ref(Ref) + , Specification(JsonLet, JsonRef, JsonString) + ) +import Data.Text (Text) +import Prelude (Applicative(pure), ($), (.), Eq, IO, Ord) + + +main :: IO () +main = + {- + The "test" is that this file compiles at all. It _should_ compile but + the "stable environment" bug this is testing was causing this to fail + to compile because the reference to "Baz" via "bar" did not share + the same environment as the direct reference to Baz in the instance + `HasJsonEncodingSpec Baz`. That is to say, the "structure type" + created by one references was `Ref env1 spec` and `Ref env2 spec` + for the other reference, where env1 and env2 are not identical + even though they are functionally equivalent. This means that + `instance HasJsonEncodingSpec Foo` could not delegate to `instance + HasJsonEncodingSpec Baz`, which is a major usability problem. + + The solution was to have the environment in the `Ref env spec` + structure be fixed at the point where the reference is defined, + not where it is used. + -} + pure () + + +{-| Shared specification definitions. -} +type TestShared 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 + + +newtype Baz = Baz Text + deriving newtype + ( Eq + , Ord + ) +instance HasJsonEncodingSpec Baz where + type EncodingSpec Baz = + TestShared "Baz" + toJSONStructure (Baz val) = Ref val + +