Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Disable 1-field simplification by default #1321

Merged
merged 4 commits into from
Sep 19, 2019
Merged

Disable 1-field simplification by default #1321

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
4c34c80
Disable 1-field simplification by default
Gabriella439 Sep 17, 2019
c04511c
Change to three-valued option
Gabriella439 Sep 18, 2019
6ac3c2d
Don't depend on `fieldModifier` for determining if a field is anonymous
Gabriella439 Sep 19, 2019
b4f69df
Merge branch 'master' into gabriel/collapse_option
mergify[bot] Sep 19, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
87 changes: 73 additions & 14 deletions dhall/src/Dhall.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -892,7 +892,7 @@ instance (Inject a, Interpret b) => Interpret (a -> b) where

expectedOut = Pi "_" declared expectedIn

InputType {..} = inject
InputType {..} = injectWith opts

Type extractIn expectedIn = autoWith opts

Expand Down Expand Up @@ -967,15 +967,15 @@ instance Interpret (f (Result f)) => Interpret (Result f) where
-- > \(Expr : Type)
-- > -> let ExprF =
-- > < LitF :
-- > Natural
-- > { _1 : Natural }
-- > | AddF :
-- > { _1 : Expr, _2 : Expr }
-- > | MulF :
-- > { _1 : Expr, _2 : Expr }
-- > >
-- >
-- > 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)
Expand Down Expand Up @@ -1031,6 +1031,10 @@ data InterpretOptions = InterpretOptions
, constructorModifier :: Text -> Text
-- ^ Function used to transform Haskell constructor names into their
-- corresponding Dhall alternative names
, collapseSingletonRecords :: Bool
-- ^ Set this to `True` if you want the corresponding Dhall type to collapse
-- records with one field by replacing the record with the underlying
-- field
Gabriella439 marked this conversation as resolved.
Show resolved Hide resolved
, 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
Expand All @@ -1044,9 +1048,14 @@ data InterpretOptions = InterpretOptions
-}
defaultInterpretOptions :: InterpretOptions
defaultInterpretOptions = InterpretOptions
{ fieldModifier = id
, constructorModifier = id
, inputNormalizer = Dhall.Core.ReifiedNormalizer (const (pure Nothing))
{ fieldModifier =
id
, constructorModifier =
id
, collapseSingletonRecords =
False
Gabriella439 marked this conversation as resolved.
Show resolved Hide resolved
, inputNormalizer =
Dhall.Core.ReifiedNormalizer (const (pure Nothing))
}

{-| This is the underlying class that powers the `Interpret` class's support
Expand Down Expand Up @@ -1341,11 +1350,40 @@ 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
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm a little concerned about all these undefineds. Would Proxy be a safer alternative?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@rprije: The undefineds are necessary. It's a limitation of the GHC generics API, since it doesn't support a Proxy-based selName.


name <- fmap fieldModifier (getSelName n)
Gabriella439 marked this conversation as resolved.
Show resolved Hide resolved

let Type { extract = extract', expected = expected'} = autoWith options

let expected =
if collapseSingletonRecords
then expected'
else 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 expression = fmap (M1 . K1) (extract' expression)

let extract =
if collapseSingletonRecords
then extract0
else extract1

return (Type {..})

Expand Down Expand Up @@ -1546,11 +1584,32 @@ 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

let n :: M1 S s (K1 i a) r
n = undefined

name <- fieldModifier <$> getSelName n

let embed0 (M1 (K1 x)) = embed' x

pure (contramap (unK1 . unM1) res)
let embed1 (M1 (K1 x)) =
RecordLit (Dhall.Map.singleton name (embed' x))

let embed =
if collapseSingletonRecords
then embed0
else embed1

let declared =
if collapseSingletonRecords
then declared'
else 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 {..})
Expand Down
146 changes: 116 additions & 30 deletions dhall/tests/Dhall/Test/Dhall.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 {}
sjakobi marked this conversation as resolved.
Show resolved Hide resolved
| R1 { a :: () }
| R2 { x :: Double }
| R3 { a :: (), b :: () }
| R4 { x :: Double, y :: Double }
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

BTW I don't see any tests for simple record types like data D = D { a :: Bool, … } and newtypes – I assume they would be translated to records and also be influenced by the collapseSingletonRecords setting?!

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Did you see my comment above, @Gabriel439?

I'm mostly wondering whether these types are marshalled differently with the new default setting.

deriving (Eq, Generic, Inject, Interpret, Show)

data Products = P0 | P1 () | P2 Double | P3 () () | P4 Double Double
Expand All @@ -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"
`shouldPassThroughCollapse` [ N0 True, N1 5, N2 "ABC" ]
, "λ(x : < R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >) → x"
`shouldPassThroughCollapse` [ 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"
`shouldPassThroughCollapse` [ 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"
`shouldMarshalIntoCollapse` N0 True
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
`shouldMarshalIntoCollapse` N1 5
, "(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\""
`shouldMarshalIntoCollapse` 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 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
`shouldMarshalIntoCollapse` R0
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1"
`shouldMarshalIntoCollapse` R1 { a = () }
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 1.0"
`shouldMarshalIntoCollapse` R2 { x = 1.0 }
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
`shouldMarshalIntoCollapse` R3 { a = (), b = () }
, "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }"
`shouldMarshalIntoCollapse` 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"
`shouldMarshalIntoCollapse` P0
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
`shouldMarshalIntoCollapse` P1 ()
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
`shouldMarshalIntoCollapse` P2 1.0
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
`shouldMarshalIntoCollapse` P3 () ()
, "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
`shouldMarshalIntoCollapse` 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
`shouldInjectIntoCollapse`
"(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True"
, N1 5
`shouldInjectIntoCollapse`
"(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5"
, N2 "ABC"
`shouldInjectIntoCollapse`
"(< 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 }"

, 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 `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 }"

, R0 `shouldInjectIntoCollapse` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0"
, R1 { a = () } `shouldInjectIntoCollapse` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1"
, R2 { x = 1.0 } `shouldInjectIntoCollapse` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 1.0"
, R3 { a = (), b = () } `shouldInjectIntoCollapse` "< R0 | R1 | R2 : Double | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }"
, R4 { x = 1.0, y = 2.0 } `shouldInjectIntoCollapse` "< R0 | R1 | R2 : 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 `shouldInjectIntoCollapse` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0"
, P1 () `shouldInjectIntoCollapse` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1"
, P2 1.0 `shouldInjectIntoCollapse` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0"
, P3 () () `shouldInjectIntoCollapse` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }"
, P4 1.0 2.0 `shouldInjectIntoCollapse` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }"
]
where
collapseOptions =
Dhall.defaultInterpretOptions
{ Dhall.collapseSingletonRecords = True }

code `shouldPassThrough` values = testCase "Pass through" $ do
f <- Dhall.input Dhall.auto code

values @=? map f values

code `shouldPassThroughCollapse` values = testCase "Pass through" $ do
f <- Dhall.input (Dhall.autoWith collapseOptions) code

values @=? map f values

code `shouldMarshalInto` expectedValue = testCase "Marshal" $ do
actualValue <- Dhall.input Dhall.auto code

expectedValue @=? actualValue

code `shouldMarshalIntoCollapse` expectedValue = testCase "Marshal" $ do
actualValue <- Dhall.input (Dhall.autoWith collapseOptions) code

expectedValue @=? actualValue

value `shouldInjectInto` expectedCode = testCase "Inject" $ do
Expand All @@ -257,6 +336,13 @@ shouldHandleUnionsCorrectly =

Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value

value `shouldInjectIntoCollapse` 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 collapseOptions) value

shouldConvertDhallToHaskellCorrectly :: TestTree
shouldConvertDhallToHaskellCorrectly =
testGroup
Expand Down
Loading