diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index 5e17516..c72e7ba 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -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 {..}) diff --git a/dhall/tests/Dhall/Test/Dhall.hs b/dhall/tests/Dhall/Test/Dhall.hs index fdc6654..a214049 100644 --- a/dhall/tests/Dhall/Test/Dhall.hs +++ b/dhall/tests/Dhall/Test/Dhall.hs @@ -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 diff --git a/dhall/tests/recursive/expr0.dhall b/dhall/tests/recursive/expr0.dhall index 34e507b..06d4428 100644 --- a/dhall/tests/recursive/expr0.dhall +++ b/dhall/tests/recursive/expr0.dhall @@ -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 }) diff --git a/dhall/tests/recursive/expr1.dhall b/dhall/tests/recursive/expr1.dhall index 89ad5c0..8f6fa04 100644 --- a/dhall/tests/recursive/expr1.dhall +++ b/dhall/tests/recursive/expr1.dhall @@ -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 })