Disable 1-field simplification by default (#1321)
* Disable 1-field simplification by default This builds on top of #1315 to minimize disruption by disabling the breaking change by default and instead requiring the user to opt in by setting a new `collapseSingletonRecords` option to `True`. The additional tests added to verify this also caught a bug in the `Interpret` instance for functions, which this change also fixes. * Change to three-valued option ... based on feedback from @sjakobi This change the option to a three-valued option: * `Bare` - 1-field constructor does not include a nested record * `Wrapped` - 1-field constructor always includes a nested record * `Smart` - Named fields that don't begin with `_` include a nested record The default is `Wrapped` (for backwards compatibility), but users will probably want to eventually switch to `Smart` * Don't depend on `fieldModifier` for determining if a field is anonymous ... as suggested by @sjakobi
This commit is contained in:
Gabriel Gonzalez
mergify[bot]
parent
2fcbf84e2f
commit
54241f88c7
|
|
@ -58,6 +58,7 @@ module Dhall
|
|||
, auto
|
||||
, genericAuto
|
||||
, InterpretOptions(..)
|
||||
, SingletonConstructors(..)
|
||||
, defaultInterpretOptions
|
||||
, bool
|
||||
, natural
|
||||
|
|
@ -892,7 +893,7 @@ instance (Inject a, Interpret b) => Interpret (a -> b) where
|
|||
|
||||
expectedOut = Pi "_" declared expectedIn
|
||||
|
||||
InputType {..} = inject
|
||||
InputType {..} = injectWith opts
|
||||
|
||||
Type extractIn expectedIn = autoWith opts
|
||||
|
||||
|
|
@ -967,7 +968,7 @@ instance Interpret (f (Result f)) => Interpret (Result f) where
|
|||
-- > \(Expr : Type)
|
||||
-- > -> let ExprF =
|
||||
-- > < LitF :
|
||||
-- > Natural
|
||||
-- > { _1 : Natural }
|
||||
-- > | AddF :
|
||||
-- > { _1 : Expr, _2 : Expr }
|
||||
-- > | MulF :
|
||||
|
|
@ -975,7 +976,7 @@ instance Interpret (f (Result f)) => Interpret (Result f) where
|
|||
-- > >
|
||||
-- >
|
||||
-- > in \(Fix : ExprF -> Expr)
|
||||
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x)
|
||||
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x })
|
||||
-- >
|
||||
-- > let Add =
|
||||
-- > \(x : Expr)
|
||||
|
|
@ -1031,12 +1032,39 @@ data InterpretOptions = InterpretOptions
|
|||
, constructorModifier :: Text -> Text
|
||||
-- ^ Function used to transform Haskell constructor names into their
|
||||
-- corresponding Dhall alternative names
|
||||
, singletonConstructors :: SingletonConstructors
|
||||
-- ^ Specify how to handle constructors with only one field. The default is
|
||||
-- `Wrapped` for backwards compatibility but will eventually be changed to
|
||||
-- `Smart`
|
||||
, inputNormalizer :: Dhall.Core.ReifiedNormalizer X
|
||||
-- ^ This is only used by the `Interpret` instance for functions in order
|
||||
-- to normalize the function input before marshaling the input into a
|
||||
-- Dhall expression
|
||||
}
|
||||
|
||||
{-| This type specifies how to model a Haskell constructor with 1 field in
|
||||
Dhall
|
||||
|
||||
For example, consider the following Haskell datatype definition:
|
||||
|
||||
> data Example = Foo { x :: Double } | Bar Double
|
||||
|
||||
Depending on which option you pick, the corresponding Dhall type could be:
|
||||
|
||||
> < Foo : Double | Bar : Double > -- Bare
|
||||
|
||||
> < Foo : { x : Double } | Bar : { _1 : Double } > -- Wrapped
|
||||
|
||||
> < Foo : { x : Double } | Bar : Double > -- Smart
|
||||
-}
|
||||
data SingletonConstructors
|
||||
= Bare
|
||||
-- ^ Never wrap the field in a record
|
||||
| Wrapped
|
||||
-- ^ Always wrap the field in a record
|
||||
| Smart
|
||||
-- ^ Only fields in a record if they are named
|
||||
|
||||
{-| Default interpret options, which you can tweak or override, like this:
|
||||
|
||||
> autoWith
|
||||
|
|
@ -1044,9 +1072,14 @@ data InterpretOptions = InterpretOptions
|
|||
-}
|
||||
defaultInterpretOptions :: InterpretOptions
|
||||
defaultInterpretOptions = InterpretOptions
|
||||
{ fieldModifier = id
|
||||
, constructorModifier = id
|
||||
, inputNormalizer = Dhall.Core.ReifiedNormalizer (const (pure Nothing))
|
||||
{ fieldModifier =
|
||||
id
|
||||
, constructorModifier =
|
||||
id
|
||||
, singletonConstructors =
|
||||
Wrapped
|
||||
, inputNormalizer =
|
||||
Dhall.Core.ReifiedNormalizer (const (pure Nothing))
|
||||
}
|
||||
|
||||
{-| This is the underlying class that powers the `Interpret` class's support
|
||||
|
|
@ -1341,11 +1374,45 @@ instance (Selector s1, Selector s2, Interpret a1, Interpret a2) => GenericInterp
|
|||
|
||||
return (Type {..})
|
||||
|
||||
instance Interpret a => GenericInterpret (M1 S s (K1 i a)) where
|
||||
genericAutoWith options = do
|
||||
let Type { extract = extract', ..} = autoWith options
|
||||
instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where
|
||||
genericAutoWith options@InterpretOptions{..} = do
|
||||
let n :: M1 S s (K1 i a) r
|
||||
n = undefined
|
||||
|
||||
let extract expression = fmap (M1 . K1) (extract' expression)
|
||||
name <- fmap fieldModifier (getSelName n)
|
||||
|
||||
let Type { extract = extract', expected = expected'} = autoWith options
|
||||
|
||||
let expected =
|
||||
case singletonConstructors of
|
||||
Bare ->
|
||||
expected'
|
||||
Smart | selName n == "" ->
|
||||
expected'
|
||||
_ ->
|
||||
Record (Dhall.Map.singleton name expected')
|
||||
|
||||
let extract0 expression = fmap (M1 . K1) (extract' expression)
|
||||
|
||||
let extract1 expression = do
|
||||
let die = typeError expected expression
|
||||
|
||||
case expression of
|
||||
RecordLit kvs -> do
|
||||
case Dhall.Map.lookup name kvs of
|
||||
Just subExpression ->
|
||||
fmap (M1 . K1) (extract' subExpression)
|
||||
Nothing ->
|
||||
die
|
||||
_ -> do
|
||||
die
|
||||
|
||||
|
||||
let extract =
|
||||
case singletonConstructors of
|
||||
Bare -> extract0
|
||||
Smart | selName n == "" -> extract0
|
||||
_ -> extract1
|
||||
|
||||
return (Type {..})
|
||||
|
||||
|
|
@ -1546,11 +1613,37 @@ instance GenericInject f => GenericInject (M1 C c f) where
|
|||
res <- genericInjectWith options
|
||||
pure (contramap unM1 res)
|
||||
|
||||
instance Inject a => GenericInject (M1 S s (K1 i a)) where
|
||||
genericInjectWith options = do
|
||||
let res = injectWith options
|
||||
instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where
|
||||
genericInjectWith options@InterpretOptions{..} = do
|
||||
let InputType { embed = embed', declared = declared' } =
|
||||
injectWith options
|
||||
|
||||
pure (contramap (unK1 . unM1) res)
|
||||
let n :: M1 S s (K1 i a) r
|
||||
n = undefined
|
||||
|
||||
name <- fieldModifier <$> getSelName n
|
||||
|
||||
let embed0 (M1 (K1 x)) = embed' x
|
||||
|
||||
let embed1 (M1 (K1 x)) =
|
||||
RecordLit (Dhall.Map.singleton name (embed' x))
|
||||
|
||||
let embed =
|
||||
case singletonConstructors of
|
||||
Bare -> embed0
|
||||
Smart | selName n == "" -> embed0
|
||||
_ -> embed1
|
||||
|
||||
let declared =
|
||||
case singletonConstructors of
|
||||
Bare ->
|
||||
declared'
|
||||
Smart | selName n == "" ->
|
||||
declared'
|
||||
_ ->
|
||||
Record (Dhall.Map.singleton name declared')
|
||||
|
||||
return (InputType {..})
|
||||
|
||||
instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where
|
||||
genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..})
|
||||
|
|
|
|||
|
|
@ -161,7 +161,12 @@ data NonEmptyUnion = N0 Bool | N1 Natural | N2 Text
|
|||
data Enum = E0 | E1 | E2
|
||||
deriving (Eq, Generic, Inject, Interpret, Show)
|
||||
|
||||
data Records = R0 {} | R1 { a :: () } | R2 { x :: Double } | R3 { a :: (), b :: () } | R4 { x :: Double, y :: Double }
|
||||
data Records
|
||||
= R0 {}
|
||||
| R1 { a :: () }
|
||||
| R2 { x :: Double }
|
||||
| R3 { a :: (), b :: () }
|
||||
| R4 { x :: Double, y :: Double }
|
||||
deriving (Eq, Generic, Inject, Interpret, Show)
|
||||
|
||||
data Products = P0 | P1 () | P2 Double | P3 () () | P4 Double Double
|
||||
|
|
@ -172,82 +177,156 @@ deriving instance Interpret ()
|
|||
shouldHandleUnionsCorrectly :: TestTree
|
||||
shouldHandleUnionsCorrectly =
|
||||
testGroup "Handle union literals"
|
||||
[ "λ(x : < N0 : Bool | N1 : Natural | N2 : Text >) → x"
|
||||
[ "λ(x : < N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >) → x"
|
||||
`shouldPassThrough` [ N0 True, N1 5, N2 "ABC" ]
|
||||
, "λ(x : < E0 | E1 | E2 >) → x"
|
||||
`shouldPassThrough` [ E0, E1, E2 ]
|
||||
, "λ(x : < R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >) → x"
|
||||
, "λ(x : < R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >) → x"
|
||||
`shouldPassThrough` [ R0 {}, R1 { a = () }, R2 { x = 1.0 }, R3 { a = (), b = () }, R4 { x = 1.0, y = 2.0 } ]
|
||||
, "λ(x : < P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >) → x"
|
||||
, "λ(x : < P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >) → x"
|
||||
`shouldPassThrough` [ P0 , P1 (), P2 1.0, P3 () (), P4 1.0 2.0 ]
|
||||
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True"
|
||||
, "λ(x : < N0 : Bool | N1 : Natural | N2 : Text >) → x"
|
||||
`shouldPassThroughSmart` [ N0 True, N1 5, N2 "ABC" ]
|
||||
, "λ(x : < R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >) → x"
|
||||
`shouldPassThroughSmart` [ R0 {}, R1 { a = () }, R2 { x = 1.0 }, R3 { a = (), b = () }, R4 { x = 1.0, y = 2.0 } ]
|
||||
, "λ(x : < P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >) → x"
|
||||
`shouldPassThroughSmart` [ P0 , P1 (), P2 1.0, P3 () (), P4 1.0 2.0 ]
|
||||
|
||||
, "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }"
|
||||
`shouldMarshalInto` N0 True
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
|
||||
, "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }"
|
||||
`shouldMarshalInto` N1 5
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\""
|
||||
, "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }"
|
||||
|
||||
`shouldMarshalInto` N2 "ABC"
|
||||
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True"
|
||||
`shouldMarshalIntoSmart` N0 True
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
|
||||
`shouldMarshalIntoSmart` N1 5
|
||||
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\""
|
||||
`shouldMarshalIntoSmart` N2 "ABC"
|
||||
|
||||
, "(< E0 | E1 | E2>).E0" `shouldMarshalInto` E0
|
||||
, "(< E0 | E1 | E2>).E1" `shouldMarshalInto` E1
|
||||
, "(< E0 | E1 | E2>).E2" `shouldMarshalInto` E2
|
||||
|
||||
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
`shouldMarshalInto` R0
|
||||
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }"
|
||||
`shouldMarshalInto` R1 { a = () }
|
||||
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 1.0"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0 }"
|
||||
`shouldMarshalInto` R2 { x = 1.0 }
|
||||
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
`shouldMarshalInto` R3 { a = (), b = () }
|
||||
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
`shouldMarshalInto` R4 { x = 1.0, y = 2.0 }
|
||||
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
`shouldMarshalIntoSmart` R0
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }"
|
||||
`shouldMarshalIntoSmart` R1 { a = () }
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0 }"
|
||||
`shouldMarshalIntoSmart` R2 { x = 1.0 }
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
`shouldMarshalIntoSmart` R3 { a = (), b = () }
|
||||
, "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
`shouldMarshalIntoSmart` R4 { x = 1.0, y = 2.0 }
|
||||
|
||||
, "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
`shouldMarshalInto` P0
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
|
||||
, "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }"
|
||||
`shouldMarshalInto` P1 ()
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
|
||||
, "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }"
|
||||
`shouldMarshalInto` P2 1.0
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
, "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
`shouldMarshalInto` P3 () ()
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
, "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
`shouldMarshalInto` P4 1.0 2.0
|
||||
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
`shouldMarshalIntoSmart` P0
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
|
||||
`shouldMarshalIntoSmart` P1 ()
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
|
||||
`shouldMarshalIntoSmart` P2 1.0
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
`shouldMarshalIntoSmart` P3 () ()
|
||||
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
`shouldMarshalIntoSmart` P4 1.0 2.0
|
||||
|
||||
, N0 True
|
||||
`shouldInjectInto`
|
||||
"(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True"
|
||||
"(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }"
|
||||
, N1 5
|
||||
`shouldInjectInto`
|
||||
"(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
|
||||
"(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }"
|
||||
, N2 "ABC"
|
||||
`shouldInjectInto`
|
||||
"(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }"
|
||||
|
||||
, N0 True
|
||||
`shouldInjectIntoSmart`
|
||||
"(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True"
|
||||
, N1 5
|
||||
`shouldInjectIntoSmart`
|
||||
"(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
|
||||
, N2 "ABC"
|
||||
`shouldInjectIntoSmart`
|
||||
"(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\""
|
||||
|
||||
, E0 `shouldInjectInto` "< E0 | E1 | E2 >.E0"
|
||||
, E1 `shouldInjectInto` "< E0 | E1 | E2 >.E1"
|
||||
, E2 `shouldInjectInto` "< E0 | E1 | E2 >.E2"
|
||||
|
||||
, R0 `shouldInjectInto` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
, R1 { a = () } `shouldInjectInto` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1"
|
||||
, R2 { x = 1.0 } `shouldInjectInto` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 1.0"
|
||||
, R3 { a = (), b = () } `shouldInjectInto` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
, R4 { x = 1.0, y = 2.0 } `shouldInjectInto` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
, R0 `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
, R1 { a = () } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }"
|
||||
, R2 { x = 1.0 } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}"
|
||||
, R3 { a = (), b = () } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
, R4 { x = 1.0, y = 2.0 } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
|
||||
, P0 `shouldInjectInto` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
, P1 () `shouldInjectInto` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
|
||||
, P2 1.0 `shouldInjectInto` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
|
||||
, P3 () () `shouldInjectInto` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
, P4 1.0 2.0 `shouldInjectInto` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
, R0 `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
|
||||
, R1 { a = () } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }"
|
||||
, R2 { x = 1.0 } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}"
|
||||
, R3 { a = (), b = () } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
|
||||
, R4 { x = 1.0, y = 2.0 } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
|
||||
|
||||
, P0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
, P1 () `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }"
|
||||
, P2 1.0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }"
|
||||
, P3 () () `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
, P4 1.0 2.0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
|
||||
, P0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
|
||||
, P1 () `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
|
||||
, P2 1.0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
|
||||
, P3 () () `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
|
||||
, P4 1.0 2.0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
|
||||
]
|
||||
where
|
||||
smartOptions =
|
||||
Dhall.defaultInterpretOptions
|
||||
{ Dhall.singletonConstructors = Dhall.Smart }
|
||||
|
||||
code `shouldPassThrough` values = testCase "Pass through" $ do
|
||||
f <- Dhall.input Dhall.auto code
|
||||
|
||||
values @=? map f values
|
||||
|
||||
code `shouldPassThroughSmart` values = testCase "Pass through" $ do
|
||||
f <- Dhall.input (Dhall.autoWith smartOptions) code
|
||||
|
||||
values @=? map f values
|
||||
|
||||
code `shouldMarshalInto` expectedValue = testCase "Marshal" $ do
|
||||
actualValue <- Dhall.input Dhall.auto code
|
||||
|
||||
expectedValue @=? actualValue
|
||||
|
||||
code `shouldMarshalIntoSmart` expectedValue = testCase "Marshal" $ do
|
||||
actualValue <- Dhall.input (Dhall.autoWith smartOptions) code
|
||||
|
||||
expectedValue @=? actualValue
|
||||
|
||||
value `shouldInjectInto` expectedCode = testCase "Inject" $ do
|
||||
|
|
@ -257,6 +336,13 @@ shouldHandleUnionsCorrectly =
|
|||
|
||||
Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value
|
||||
|
||||
value `shouldInjectIntoSmart` expectedCode = testCase "Inject" $ do
|
||||
parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode)
|
||||
|
||||
resolvedExpression <- Dhall.Import.assertNoImports parsedExpression
|
||||
|
||||
Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.injectWith smartOptions) value
|
||||
|
||||
shouldConvertDhallToHaskellCorrectly :: TestTree
|
||||
shouldConvertDhallToHaskellCorrectly =
|
||||
testGroup
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
λ(Expr : Type)
|
||||
→ let ExprF =
|
||||
< LitF : Natural
|
||||
< LitF :
|
||||
{ _1 : Natural }
|
||||
| AddF :
|
||||
{ _1 : Expr, _2 : Expr }
|
||||
| MulF :
|
||||
|
|
@ -8,7 +9,7 @@
|
|||
>
|
||||
|
||||
in λ(Fix : ExprF → Expr)
|
||||
→ let Lit = λ(x : Natural) → Fix (ExprF.LitF x)
|
||||
→ let Lit = λ(x : Natural) → Fix (ExprF.LitF { _1 = x })
|
||||
|
||||
let Add =
|
||||
λ(x : Expr) → λ(y : Expr) → Fix (ExprF.AddF { _1 = x, _2 = y })
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
λ(a : Type)
|
||||
→ let ExprF =
|
||||
< LitF :
|
||||
Natural
|
||||
{ _1 : Natural }
|
||||
| AddF :
|
||||
{ _1 : a, _2 : a }
|
||||
| MulF :
|
||||
|
|
@ -9,7 +9,7 @@
|
|||
>
|
||||
|
||||
in λ(a : ExprF → a)
|
||||
→ let Lit = λ(x : Natural) → a (ExprF.LitF x)
|
||||
→ let Lit = λ(x : Natural) → a (ExprF.LitF { _1 = x })
|
||||
|
||||
let Add = λ(x : a@1) → λ(y : a@1) → a (ExprF.AddF { _1 = x, _2 = y })
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue