diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,44 @@ +1.29.0 + +* [Supports version 13.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v13.0.0) +* BREAKING CHANGE: [Generate Haskell datatype declarations from Dhall types](https://github.com/dhall-lang/dhall-haskell/commit/b0280826790930d18a5498fb802120478fa11767#diff-a9729dccf50be61ce3d8c68c16f0fd50) + * You can now use the `makeHaskellTypeFromUnion` Template Haskell utility + to generate a Haskell datatype declaration from a Dhall union type + * This helps ensure that your Haskell types and Dhall types stay in sync, + when you want the Dhall type to be the source of truth + * This is a breaking change because the default `InterpretOptions` changed + the default handling of singleton constructors from `Wrapped` to `Smart` + * You can preserve the old behavior using: + `autoWith defaultInterpretOptions{ singletonConstructors = Wrapped }` +* BUG FIX: [Fix `dhall freeze --cache` and `dhall lint` to preserve `let`-related comments](https://github.com/dhall-lang/dhall-haskell/pull/1597) + * Now they match the behavior of `dhall format` with regard to preserving + these comments +* BUG FIX: [Fix escaping of significant leading whitespace when formatting code](https://github.com/dhall-lang/dhall-haskell/pull/1598) + * The formatter would sometimes unnecessarily escape significant leading + whitespace for the final line of multiline string literals, which this + change fixes +* BUG FIX: [Fix `dhall encode --json` for `Double` values](https://github.com/dhall-lang/dhall-haskell/issues/1350) +* NEW FEATURE: [`dhall to-directory-tree` command](https://github.com/dhall-lang/dhall-haskell/pull/1606) + * You can now generate a directory tree from a Dhall expression + * Specifically: + * records are converted to directories + * `Text` fields are converted to files named after the field + * `Optional` values are omitted if `None` + * Everything else is rejected +* NEW FEATURE: [Hexadecimal literals](https://github.com/dhall-lang/dhall-haskell/pull/1607) + * See the [changelog for standard version 13.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v13.0.0) for more details +* NEW FEATURE: [`merge` works on `Optional` values](https://github.com/dhall-lang/dhall-haskell/pull/1608) + * See the [changelog for standard version 13.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v13.0.0) for more details +* [Improve formatter](https://github.com/dhall-lang/dhall-haskell/pull/1609) + * `dhall format` will now render expressions nested inside record fields or + alternatives more compactly, including: + * Records + * Record completion expressions + * Expressions wrapped in `Some` + * Lists +* [Exclude the `using ...` suffix from imports listed by `dhall resolve`](https://github.com/dhall-lang/dhall-haskell/pull/1603) + * Specifically when using the `--{immediate,transitive}-dependencies` flags + 1.28.0 * [Supports version 12.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) diff --git a/dhall-lang/Prelude/Function/identity b/dhall-lang/Prelude/Function/identity new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Function/identity @@ -0,0 +1,12 @@ +{- +The identity function simply returns its input +-} +let identity + : ∀(a : Type) → ∀(x : a) → a + = λ(a : Type) → λ(x : a) → x + +let example0 = assert : identity Natural 1 ≡ 1 + +let example1 = assert : identity Bool ≡ (λ(x : Bool) → x) + +in identity diff --git a/dhall-lang/Prelude/Function/package.dhall b/dhall-lang/Prelude/Function/package.dhall --- a/dhall-lang/Prelude/Function/package.dhall +++ b/dhall-lang/Prelude/Function/package.dhall @@ -1,4 +1,7 @@ { compose = ./compose sha256:65ad8bbea530b3d8968785a7cf4a9a7976b67059aa15e3b61fcba600a40ae013 ? ./compose +, identity = + ./identity sha256:f78b96792b459cb664f41c6119bd8897dd04353a3343521d436cd82ad71cb4d4 + ? ./identity } diff --git a/dhall-lang/Prelude/Integer/add b/dhall-lang/Prelude/Integer/add --- a/dhall-lang/Prelude/Integer/add +++ b/dhall-lang/Prelude/Integer/add @@ -2,7 +2,7 @@ `add m n` computes `m + n`. -} let Integer/subtract = - ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7 + ./subtract sha256:a34d36272fa8ae4f1ec8b56222fe8dc8a2ec55ec6538b840de0cbe207b006fda ? ./subtract let add diff --git a/dhall-lang/Prelude/Integer/equal b/dhall-lang/Prelude/Integer/equal --- a/dhall-lang/Prelude/Integer/equal +++ b/dhall-lang/Prelude/Integer/equal @@ -1,19 +1,18 @@ {- `equal` checks if two Integers are equal. -} -let greaterThan = - ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c - ? ./greaterThan - -let Bool/not = - ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 - ? ../Bool/not +let Natural/equal = + ../Natural/equal sha256:7f108edfa35ddc7cebafb24dc073478e93a802e13b5bc3fd22f4768c9b066e60 + ? ../Natural/equal let equal : Integer → Integer → Bool = λ(a : Integer) → λ(b : Integer) - → Bool/not (greaterThan a b) && Bool/not (greaterThan b a) + → Natural/equal (Integer/clamp a) (Integer/clamp b) + && Natural/equal + (Integer/clamp (Integer/negate a)) + (Integer/clamp (Integer/negate b)) let example0 = assert : equal +5 +5 ≡ True diff --git a/dhall-lang/Prelude/Integer/greaterThan b/dhall-lang/Prelude/Integer/greaterThan --- a/dhall-lang/Prelude/Integer/greaterThan +++ b/dhall-lang/Prelude/Integer/greaterThan @@ -1,19 +1,17 @@ {- `greaterThan` checks if one Integer is greater than another. -} -let Integer/subtract = - ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7 - ? ./subtract - let Bool/not = ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 ? ../Bool/not +let lessThanEqual = + ./lessThanEqual sha256:e3cca9f3942f81fa78a2bea23c0c24519c67cfe438116c38e797e12dcd26f6bc + ? ./lessThanEqual + let greaterThan : Integer → Integer → Bool - = λ(x : Integer) - → λ(y : Integer) - → Bool/not (Natural/isZero (Integer/clamp (Integer/subtract y x))) + = λ(x : Integer) → λ(y : Integer) → Bool/not (lessThanEqual x y) let example0 = assert : greaterThan +5 +6 ≡ False diff --git a/dhall-lang/Prelude/Integer/greaterThanEqual b/dhall-lang/Prelude/Integer/greaterThanEqual --- a/dhall-lang/Prelude/Integer/greaterThanEqual +++ b/dhall-lang/Prelude/Integer/greaterThanEqual @@ -1,17 +1,13 @@ {- `greaterThanEqual` checks if one Integer is greater than or equal to another. -} -let greaterThan = - ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c - ? ./greaterThan - -let Bool/not = - ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 - ? ../Bool/not +let lessThanEqual = + ./lessThanEqual sha256:e3cca9f3942f81fa78a2bea23c0c24519c67cfe438116c38e797e12dcd26f6bc + ? ./lessThanEqual let greaterThanEqual : Integer → Integer → Bool - = λ(x : Integer) → λ(y : Integer) → Bool/not (greaterThan y x) + = λ(x : Integer) → λ(y : Integer) → lessThanEqual y x let example0 = assert : greaterThanEqual +5 +6 ≡ False diff --git a/dhall-lang/Prelude/Integer/lessThan b/dhall-lang/Prelude/Integer/lessThan --- a/dhall-lang/Prelude/Integer/lessThan +++ b/dhall-lang/Prelude/Integer/lessThan @@ -2,7 +2,7 @@ `lessThan` checks if one Integer is less than another. -} let greaterThan = - ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c + ./greaterThan sha256:d23affd73029fc9aaf867c2c7b86510ca2802d3f0d1f3e1d1a93ffd87b7cb64b ? ./greaterThan let lessThan diff --git a/dhall-lang/Prelude/Integer/lessThanEqual b/dhall-lang/Prelude/Integer/lessThanEqual --- a/dhall-lang/Prelude/Integer/lessThanEqual +++ b/dhall-lang/Prelude/Integer/lessThanEqual @@ -1,17 +1,34 @@ {- `lessThanEqual` checks if one Integer is less than or equal to another. -} -let lessThan = - ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d - ? ./lessThan +let Natural/greaterThanEqual = + ../Natural/greaterThanEqual sha256:30ebfab0febd7aa0ccccfdf3dc36ee6d50f0117f35dd4a9b034750b7e885a1a4 + ? ../Natural/greaterThanEqual -let Bool/not = - ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 - ? ../Bool/not +let Natural/lessThanEqual = + ../Natural/lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99 + ? ../Natural/lessThanEqual +let nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive + +let nonNegative = + ./nonNegative sha256:b463373f070df6b1c8c7082051e0810fee38b360bab35256187c8c2b6af5c663 + ? ./nonNegative + let lessThanEqual : Integer → Integer → Bool - = λ(x : Integer) → λ(y : Integer) → Bool/not (lessThan y x) + = λ(x : Integer) + → λ(y : Integer) + → if nonPositive x + + then nonNegative y + || Natural/greaterThanEqual + (Integer/clamp (Integer/negate x)) + (Integer/clamp (Integer/negate y)) + + else Natural/lessThanEqual (Integer/clamp x) (Integer/clamp y) let example0 = assert : lessThanEqual +5 +6 ≡ True diff --git a/dhall-lang/Prelude/Integer/multiply b/dhall-lang/Prelude/Integer/multiply --- a/dhall-lang/Prelude/Integer/multiply +++ b/dhall-lang/Prelude/Integer/multiply @@ -2,27 +2,32 @@ `multiply m n` computes `m * n`. -} -let Integer/abs = - ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 - ? ./abs +let nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive +let multiplyNonNegative = + λ(x : Integer) + → λ(y : Integer) + → Natural/toInteger (Integer/clamp x * Integer/clamp y) + let multiply : Integer → Integer → Integer = λ(m : Integer) → λ(n : Integer) - → let mAbs = Integer/abs m + → if nonPositive m - let nAbs = Integer/abs n + then if nonPositive n - let mNonPos = Natural/isZero (Integer/clamp m) + then multiplyNonNegative (Integer/negate m) (Integer/negate n) - let nNonPos = Natural/isZero (Integer/clamp n) + else Integer/negate (multiplyNonNegative (Integer/negate m) n) - in if mNonPos == nNonPos + else if nonPositive n - then Natural/toInteger (mAbs * nAbs) + then Integer/negate (multiplyNonNegative m (Integer/negate n)) - else Integer/negate (Natural/toInteger (mAbs * nAbs)) + else multiplyNonNegative m n let example0 = assert : multiply +3 +5 ≡ +15 diff --git a/dhall-lang/Prelude/Integer/negative b/dhall-lang/Prelude/Integer/negative new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/negative @@ -0,0 +1,20 @@ +{- +Returns `True` for any `Integer` less than `+0`. + +`negative` is more efficient than `./lessThan +0` or `./lessThanEqual -1`. +-} +let positive = + ./positive sha256:7bdbf50fcdb83d01f74c7e2a92bf5c9104eff5d8c5b4587e9337f0caefcfdbe3 + ? ./positive + +let negative + : Integer → Bool + = λ(n : Integer) → positive (Integer/negate n) + +let example0 = assert : negative +1 ≡ False + +let example1 = assert : negative +0 ≡ False + +let example2 = assert : negative -1 ≡ True + +in negative diff --git a/dhall-lang/Prelude/Integer/nonNegative b/dhall-lang/Prelude/Integer/nonNegative new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/nonNegative @@ -0,0 +1,20 @@ +{- +Returns `True` for `+0` and any positive `Integer`. + +`nonNegative` is more efficient than `./greaterThanEqual +0` or `./greaterThan -1`. +-} +let nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive + +let nonNegative + : Integer → Bool + = λ(n : Integer) → nonPositive (Integer/negate n) + +let example0 = assert : nonNegative +1 ≡ True + +let example1 = assert : nonNegative +0 ≡ True + +let example2 = assert : nonNegative -1 ≡ False + +in nonNegative diff --git a/dhall-lang/Prelude/Integer/nonPositive b/dhall-lang/Prelude/Integer/nonPositive new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/nonPositive @@ -0,0 +1,16 @@ +{- +Returns `True` for `+0` and any negative `Integer`. + +`nonPositive` is more efficient than `./lessThanEqual +0` or `./lessThan +1`. +-} +let nonPositive + : Integer → Bool + = λ(n : Integer) → Natural/isZero (Integer/clamp n) + +let example0 = assert : nonPositive +1 ≡ False + +let example1 = assert : nonPositive +0 ≡ True + +let example2 = assert : nonPositive -1 ≡ True + +in nonPositive diff --git a/dhall-lang/Prelude/Integer/package.dhall b/dhall-lang/Prelude/Integer/package.dhall --- a/dhall-lang/Prelude/Integer/package.dhall +++ b/dhall-lang/Prelude/Integer/package.dhall @@ -2,42 +2,54 @@ ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 ? ./abs , add = - ./add sha256:96f1ae60f958febc911935ac4aa2685394642b116b7bddcec7e1ed201a69ed2c + ./add sha256:7da1306a0bf87c5668beead2a1db1b18861e53d7ce1f38057b2964b649f59c3b ? ./add , clamp = ./clamp sha256:ea42096cf3e024fadfaf910e0b839005b0ea7514fff11e5a3950a77694d9c5d2 ? ./clamp , equal = - ./equal sha256:e4414b9eef4142eed6bb0b52eb6fd0074210b68d210e96dd5161697b0f14426a + ./equal sha256:2d99a205086aa77eea17ae1dab22c275f3eb007bccdc8d9895b93497ebfc39f8 ? ./equal , greaterThan = - ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c + ./greaterThan sha256:d23affd73029fc9aaf867c2c7b86510ca2802d3f0d1f3e1d1a93ffd87b7cb64b ? ./greaterThan , greaterThanEqual = - ./greaterThanEqual sha256:cede1f63b58cb26623148ef741f18e6476ad71d9d541dd54be2b1ec4972a4ad0 + ./greaterThanEqual sha256:a9fa2dc5cd6067a23b39d7fe8d14a63109583b320429fb0e446658a5aae0a958 ? ./greaterThanEqual , lessThan = - ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d + ./lessThan sha256:eeaa0081d10c6c97464ef193c40f1aa5cbb12f0202972ab42f3d310c2fd6a3f0 ? ./lessThan , lessThanEqual = - ./lessThanEqual sha256:a849203a9cd270210588f9db23e02b819117a997df1c8131b6f9a634cb2e5c8d + ./lessThanEqual sha256:e3cca9f3942f81fa78a2bea23c0c24519c67cfe438116c38e797e12dcd26f6bc ? ./lessThanEqual , multiply = - ./multiply sha256:71b2a720976c70f0cd06baba9c213867b9744e655927dc3857fa92c864c3cf86 + ./multiply sha256:dcb1ed7c8475ece8d67db92cd249fc728541778ff82509e28c3760e341880e4d ? ./multiply , negate = ./negate sha256:2373c992e1de93634bc6a8781eb073b2a92a70170133e49762a785f3a136df5d ? ./negate +, negative = + ./negative sha256:23e4b3c61eea9e878a7f83bf25fd0ea2c6a6d60174890d65be885828b690a570 + ? ./negative +, nonNegative = + ./nonNegative sha256:b463373f070df6b1c8c7082051e0810fee38b360bab35256187c8c2b6af5c663 + ? ./nonNegative +, nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive +, positive = + ./positive sha256:7bdbf50fcdb83d01f74c7e2a92bf5c9104eff5d8c5b4587e9337f0caefcfdbe3 + ? ./positive , show = ./show sha256:ecf8b0594cd5181bc45d3b7ea0d44d3ba9ad5dac6ec17bb8968beb65f4b1baa9 ? ./show , subtract = - ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7 + ./subtract sha256:a34d36272fa8ae4f1ec8b56222fe8dc8a2ec55ec6538b840de0cbe207b006fda ? ./subtract , toDouble = ./toDouble sha256:77bc5d635dc4d952f37cc96f2a681d5ac503b4e8b21fc00055b1946adb5beda7 ? ./toDouble , toNatural = - ./toNatural sha256:68dabff205ffdb1ca0df3dabc561ce717b7ae6521c9da9eed893b923ae5a0e1c + ./toNatural sha256:4d128730d74e7f832e53873cb5204aa91b79758be5ce4e1aa991fe1951304a0e ? ./toNatural } diff --git a/dhall-lang/Prelude/Integer/positive b/dhall-lang/Prelude/Integer/positive new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/positive @@ -0,0 +1,24 @@ +{- +Returns `True` for any `Integer` greater than `+0`. + +`positive` is more efficient than `./greaterThan +0` or `./greaterThanEqual +1`. +-} +let not = + ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 + ? ../Bool/not + +let nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive + +let positive + : Integer → Bool + = λ(n : Integer) → not (nonPositive n) + +let example0 = assert : positive +1 ≡ True + +let example1 = assert : positive +0 ≡ False + +let example2 = assert : positive -1 ≡ False + +in positive diff --git a/dhall-lang/Prelude/Integer/subtract b/dhall-lang/Prelude/Integer/subtract --- a/dhall-lang/Prelude/Integer/subtract +++ b/dhall-lang/Prelude/Integer/subtract @@ -1,39 +1,46 @@ {- `subtract m n` computes `n - m`. -} -let Natural/lessThanEqual = - ../Natural/lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99 - ? ../Natural/lessThanEqual +let nonPositive = + ./nonPositive sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b + ? ./nonPositive -let Integer/abs = - ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 - ? ./abs +let subtractNonNegative = + λ(xi : Integer) + → λ(yi : Integer) + → let xn = Integer/clamp xi + let yn = Integer/clamp yi + + let dn = Natural/subtract xn yn + + in if Natural/isZero dn + + then Integer/negate (Natural/toInteger (Natural/subtract yn xn)) + + else Natural/toInteger dn + let subtract : Integer → Integer → Integer = λ(m : Integer) → λ(n : Integer) - → let mAbs = Integer/abs m - - let nAbs = Integer/abs n - - let mNonPos = Natural/isZero (Integer/clamp m) - - let nNonPos = Natural/isZero (Integer/clamp n) + → if nonPositive m - let diff = - if mNonPos == nNonPos + then if nonPositive n - then if Natural/lessThanEqual mAbs nAbs + then subtractNonNegative (Integer/negate n) (Integer/negate m) - then Integer/negate - (Natural/toInteger (Natural/subtract mAbs nAbs)) + else Natural/toInteger + (Integer/clamp (Integer/negate m) + Integer/clamp n) - else Natural/toInteger (Natural/subtract nAbs mAbs) + else if nonPositive n - else Natural/toInteger (mAbs + nAbs) + then Integer/negate + ( Natural/toInteger + (Integer/clamp m + Integer/clamp (Integer/negate n)) + ) - in if mNonPos then diff else Integer/negate diff + else subtractNonNegative m n let example0 = assert : subtract +3 +5 ≡ +2 diff --git a/dhall-lang/Prelude/Integer/toNatural b/dhall-lang/Prelude/Integer/toNatural --- a/dhall-lang/Prelude/Integer/toNatural +++ b/dhall-lang/Prelude/Integer/toNatural @@ -1,14 +1,14 @@ {- Convert an `Integer` to an `Optional Natural`, with negative numbers becoming `None Natural`. -} -let Integer/lessThan = - ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d - ? ./lessThan +let nonNegative = + ./nonNegative sha256:b463373f070df6b1c8c7082051e0810fee38b360bab35256187c8c2b6af5c663 + ? ./nonNegative let toNatural : Integer → Optional Natural = λ(n : Integer) - → if Integer/lessThan n +0 then None Natural else Some (Integer/clamp n) + → if nonNegative n then Some (Integer/clamp n) else None Natural let example0 = assert : toNatural +7 ≡ Some 7 diff --git a/dhall-lang/Prelude/JSON/Type b/dhall-lang/Prelude/JSON/Type --- a/dhall-lang/Prelude/JSON/Type +++ b/dhall-lang/Prelude/JSON/Type @@ -17,8 +17,10 @@ Bool → JSON , null : JSON - , number : + , double : Double → JSON + , integer : + Integer → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : @@ -30,7 +32,7 @@ , { mapKey = "bar" , mapValue = - json.array [ json.number 1.0, json.bool True ] + json.array [ json.double 1.0, json.bool True ] } ] ``` @@ -47,7 +49,7 @@ , { mapKey = "bar" , mapValue = - JSON.array [ JSON.number 1.0, JSON.bool True ] + JSON.array [ JSON.double 1.0, JSON.bool True ] } ] ``` @@ -57,12 +59,13 @@ : Type = ∀(JSON : Type) → ∀ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON diff --git a/dhall-lang/Prelude/JSON/array b/dhall-lang/Prelude/JSON/array --- a/dhall-lang/Prelude/JSON/array +++ b/dhall-lang/Prelude/JSON/array @@ -2,7 +2,7 @@ ``` let JSON = ./package.dhall -in JSON.render (JSON.array [ JSON.number 1.0, JSON.bool True ]) +in JSON.render (JSON.array [ JSON.double 1.0, JSON.bool True ]) = "[ 1.0, true ]" let JSON/Type = ./Type @@ -12,7 +12,7 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type let List/map = @@ -24,12 +24,13 @@ = λ(x : List JSON) → λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → json.array (List/map JSON@1 JSON (λ(j : JSON@1) → j JSON json) x) diff --git a/dhall-lang/Prelude/JSON/bool b/dhall-lang/Prelude/JSON/bool --- a/dhall-lang/Prelude/JSON/bool +++ b/dhall-lang/Prelude/JSON/bool @@ -11,7 +11,7 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type let bool @@ -19,12 +19,13 @@ = λ(x : Bool) → λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → json.bool x diff --git a/dhall-lang/Prelude/JSON/core.dhall b/dhall-lang/Prelude/JSON/core.dhall --- a/dhall-lang/Prelude/JSON/core.dhall +++ b/dhall-lang/Prelude/JSON/core.dhall @@ -9,7 +9,7 @@ cycles. -} { Type = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type , Tagged = ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194 @@ -24,21 +24,33 @@ ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c ? ./keyValue , string = - ./string sha256:7a8ac435d30a96092d72889f3d48eabf7cba47ecf553fd6bc07a79fdf473e8d2 + ./string sha256:7ddb3a3b9f3ed09ed011d621a10ad9825185cd03503be98a81d42f6afb77940e ? ./string , number = - ./number sha256:534745568065ae19d2b0fe1d09eeb071e9717d0f392187eb0bc95f386b018bec + ./number sha256:e70162c73c4978ad0d0d99505f61c7d990f3abadfcc08b34388b29c0934a7a32 ? ./number +, double = + ./double sha256:e70162c73c4978ad0d0d99505f61c7d990f3abadfcc08b34388b29c0934a7a32 + ? ./double +, integer = + ./integer sha256:c81a417397fc6f62155ec71fdd8d2047f981f0881295b307de3dd88747bf7e40 + ? ./integer +, natural = + ./natural sha256:a839dc6789f19f820e9cbf70c60f41f3b057c59ece1d226d04db5aca447eb0e5 + ? ./natural , object = - ./object sha256:a4e047cf157c3971b026b3942a87d474c85950d9b9654f8ebc8631740abf75a9 + ./object sha256:869aede785c34798be9f9fd457ece73e7f683f352ae4555f791516a365faf4ac ? ./object , array = - ./array sha256:3a4c06cf135f4c80619e48c0808f6600d19782705bc59ee7c27cfc2e0f097eb7 + ./array sha256:fb6346a9c63638fe3c59f8108e19eebdbddc51389ec5570bab4c25f890ccccc8 ? ./array , bool = - ./bool sha256:018d29f030b45d642aba6bb81bf2c19a7bf183684612ce7a2c8afd2099783c48 + ./bool sha256:e043d9ed01e5b45899059e128243f3dae7ce65f293f0015ce816fc36d30f7f39 ? ./bool , null = - ./null sha256:52c1d45ab2ca54875b444bfb1afdea497c8c9b0652e5044fafd8b16d97f4b78d + ./null sha256:1eeb9aee38eb8dde0e64efbaf60f24612c8194cc00b510bfb627c2ee2e1877b8 ? ./null +, renderInteger = + ./renderInteger.dhall sha256:15b8d2ae46d5002832741927af787761df49798c911e2bf85db7a7b9cb5c078c + ? ./renderInteger.dhall } diff --git a/dhall-lang/Prelude/JSON/double b/dhall-lang/Prelude/JSON/double new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/double @@ -0,0 +1,33 @@ +{- Create a JSON number from a Dhall `Double` + +``` +let JSON = ./package.dhall +in JSON.render (JSON.double 42.0) += "42.0" + +let JSON = ./package.dhall +in JSON.render (JSON.double -1.5e-10) += "-1.5e-10" +``` +-} +let JSON = + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 + ? ./Type + +let double + : Double → JSON + = λ(x : Double) + → λ(JSON : Type) + → λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → json.double x + +in double diff --git a/dhall-lang/Prelude/JSON/integer b/dhall-lang/Prelude/JSON/integer new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/integer @@ -0,0 +1,33 @@ +{- Create a JSON number from a Dhall `Integer` + +``` +let JSON = ./package.dhall +in JSON.render (JSON.integer -1) += "-1" + +let JSON = ./package.dhall +in JSON.render (JSON.integer +2) += "+2" +``` +-} +let JSON = + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 + ? ./Type + +let integer + : Integer → JSON + = λ(x : Integer) + → λ(JSON : Type) + → λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → json.integer x + +in integer diff --git a/dhall-lang/Prelude/JSON/natural b/dhall-lang/Prelude/JSON/natural new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/natural @@ -0,0 +1,29 @@ +{- Create a JSON number from a Dhall `Natural` + +``` +let JSON = ./package.dhall +in JSON.render (JSON.natural 42) += "42" +``` +-} +let JSON = + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 + ? ./Type + +let natural + : Natural → JSON + = λ(x : Natural) + → λ(JSON : Type) + → λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → json.integer (Natural/toInteger x) + +in natural diff --git a/dhall-lang/Prelude/JSON/null b/dhall-lang/Prelude/JSON/null --- a/dhall-lang/Prelude/JSON/null +++ b/dhall-lang/Prelude/JSON/null @@ -7,19 +7,20 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type let null : JSON = λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → json.null diff --git a/dhall-lang/Prelude/JSON/number b/dhall-lang/Prelude/JSON/number --- a/dhall-lang/Prelude/JSON/number +++ b/dhall-lang/Prelude/JSON/number @@ -11,22 +11,15 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type +let double = + ./double sha256:e70162c73c4978ad0d0d99505f61c7d990f3abadfcc08b34388b29c0934a7a32 + ? ./double + let number : Double → JSON - = λ(x : Double) - → λ(JSON : Type) - → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON - , bool : Bool → JSON - , null : JSON - } - ) - → json.number x + = double in number diff --git a/dhall-lang/Prelude/JSON/object b/dhall-lang/Prelude/JSON/object --- a/dhall-lang/Prelude/JSON/object +++ b/dhall-lang/Prelude/JSON/object @@ -4,7 +4,7 @@ let JSON = ./package.dhall in JSON.render ( JSON.object - [ { mapKey = "foo", mapValue = JSON.number 1.0 } + [ { mapKey = "foo", mapValue = JSON.double 1.0 } , { mapKey = "bar", mapValue = JSON.bool True } ] ) @@ -18,7 +18,7 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type let List/map = @@ -30,12 +30,13 @@ = λ(x : List { mapKey : Text, mapValue : JSON }) → λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → json.object diff --git a/dhall-lang/Prelude/JSON/omitNullFields b/dhall-lang/Prelude/JSON/omitNullFields --- a/dhall-lang/Prelude/JSON/omitNullFields +++ b/dhall-lang/Prelude/JSON/omitNullFields @@ -3,7 +3,7 @@ for a configuration to encode absent fields -} let JSON = - ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall let List/concatMap = @@ -19,12 +19,13 @@ = λ(old : JSON.Type) → λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → let result = @@ -32,8 +33,10 @@ { value : JSON, isNull : Bool } { string = λ(x : Text) → { value = json.string x, isNull = False } - , number = - λ(x : Double) → { value = json.number x, isNull = False } + , double = + λ(x : Double) → { value = json.double x, isNull = False } + , integer = + λ(x : Integer) → { value = json.integer x, isNull = False } , object = λ ( keyValues : List @@ -100,7 +103,7 @@ ( JSON.object ( toMap { string = JSON.string a - , number = JSON.number b + , double = JSON.double b , bool = JSON.bool c , null = JSON.null } @@ -109,7 +112,7 @@ ≡ JSON.object ( toMap { string = JSON.string a - , number = JSON.number b + , double = JSON.double b , bool = JSON.bool c } ) diff --git a/dhall-lang/Prelude/JSON/package.dhall b/dhall-lang/Prelude/JSON/package.dhall --- a/dhall-lang/Prelude/JSON/package.dhall +++ b/dhall-lang/Prelude/JSON/package.dhall @@ -1,11 +1,11 @@ { render = - ./render sha256:81f5a84efbb35211b1556838e86d17ed497912cf765bfa4ab76708b21e5371f1 + ./render sha256:f7c372fcc954bfbbc7f83deec2006608a48efa2b08e8753bfdf73dc0aa7b4faf ? ./render , renderYAML = - ./renderYAML sha256:862b535f6b905f1ce4b83207c58dd53ce5af0026da4c0960a3aec90fdbbb3eb0 + ./renderYAML sha256:0949b834275fb231023ea80831d830352e0b89a15f4081f043cb83e745fdb6e8 ? ./renderYAML , omitNullFields = - ./omitNullFields sha256:c28270c553f48c406bd161c61776963315e278af5dae9331c4a320c3f4ecb4ec + ./omitNullFields sha256:e6850e70094540b75edeb46f4d6038324a62def8d63544a1e9541f79739db6f0 ? ./omitNullFields , tagInline = ./tagInline sha256:49559ac11906ba6cc9eac25753e31e7addb13bc760df108024174c55523984c4 @@ -14,6 +14,6 @@ ./tagNested sha256:93a7415853b7677c832246efadc8e880c1b641a23589286a836a384ca311d26f ? ./tagNested } -∧ ( ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af +∧ ( ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall ) diff --git a/dhall-lang/Prelude/JSON/render b/dhall-lang/Prelude/JSON/render --- a/dhall-lang/Prelude/JSON/render +++ b/dhall-lang/Prelude/JSON/render @@ -4,7 +4,7 @@ more sophisticated you should use `dhall-to-json` or `dhall-to-yaml` -} let JSON = - ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall let Text/concatMapSep = @@ -17,7 +17,8 @@ → j Text { string = λ(x : Text) → Text/show x - , number = λ(x : Double) → Double/show x + , double = λ(x : Double) → Double/show x + , integer = λ(x : Integer) → JSON.renderInteger x , object = λ(x : List { mapKey : Text, mapValue : Text }) → let body = @@ -47,7 +48,7 @@ , JSON.string "Hello" , JSON.object [ { mapKey = "foo", mapValue = JSON.null } - , { mapKey = "bar", mapValue = JSON.number 1.0 } + , { mapKey = "bar", mapValue = JSON.double 1.0 } ] ] ) diff --git a/dhall-lang/Prelude/JSON/renderInteger.dhall b/dhall-lang/Prelude/JSON/renderInteger.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/renderInteger.dhall @@ -0,0 +1,24 @@ +{- Render an `Integer` value as a `JSON number`, according to the JSON + standard, in which a number may not start with a plus sign (`+`). +-} + +let Integer/nonNegative = + ../Integer/nonNegative sha256:b463373f070df6b1c8c7082051e0810fee38b360bab35256187c8c2b6af5c663 + ? ../Integer/nonNegative + +let renderInteger + : Integer → Text + = λ(integer : Integer) + → if Integer/nonNegative integer + + then Natural/show (Integer/clamp integer) + + else Integer/show integer + +let positive = assert : renderInteger +1 ≡ "1" + +let zero = assert : renderInteger +0 ≡ "0" + +let negative = assert : renderInteger -1 ≡ "-1" + +in renderInteger diff --git a/dhall-lang/Prelude/JSON/renderYAML b/dhall-lang/Prelude/JSON/renderYAML --- a/dhall-lang/Prelude/JSON/renderYAML +++ b/dhall-lang/Prelude/JSON/renderYAML @@ -9,7 +9,7 @@ -} let JSON = - ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall let Text/concatSep = @@ -120,7 +120,8 @@ ( json Block { string = λ(x : Text) → singleLine (Text/show x) - , number = λ(x : Double) → singleLine (Double/show x) + , double = λ(x : Double) → singleLine (Double/show x) + , integer = λ(x : Integer) → singleLine (JSON.renderInteger x) , object = λ(fields : List ObjectField) → manyBlocks @@ -161,7 +162,7 @@ , JSON.string "Hello" , JSON.object [ { mapKey = "foo", mapValue = JSON.null } - , { mapKey = "bar", mapValue = JSON.number 1.0 } + , { mapKey = "bar", mapValue = JSON.double 1.0 } ] ] ) diff --git a/dhall-lang/Prelude/JSON/string b/dhall-lang/Prelude/JSON/string --- a/dhall-lang/Prelude/JSON/string +++ b/dhall-lang/Prelude/JSON/string @@ -11,7 +11,7 @@ ``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ./Type sha256:40edbc9371979426df63e064333b02689b969c4cfbbccfa481216d2d1a6e9759 ? ./Type let string @@ -19,12 +19,13 @@ = λ(x : Text) → λ(JSON : Type) → λ ( json - : { string : Text → JSON - , number : Double → JSON - , object : List { mapKey : Text, mapValue : JSON } → JSON - , array : List JSON → JSON + : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → json.string x diff --git a/dhall-lang/Prelude/package.dhall b/dhall-lang/Prelude/package.dhall --- a/dhall-lang/Prelude/package.dhall +++ b/dhall-lang/Prelude/package.dhall @@ -5,10 +5,10 @@ ./Double/package.dhall sha256:b8d20ab3216083622ae371fb42a6732bc67bb2d66e84989c8ddba7556a336cf7 ? ./Double/package.dhall , Function = - ./Function/package.dhall sha256:74c3822b98b9d37f9f820af8e1a7ee790bcfac03050eabd45af4a255fb93e026 + ./Function/package.dhall sha256:6d17cf0fd4fabe1737fb117f87c04b8ff82b299915a5b673c0a543b134b8fffe ? ./Function/package.dhall , Integer = - ./Integer/package.dhall sha256:dbc82e5542a642b9372ce6126967028c0cade2b8ad6923312b086b686ad67e06 + ./Integer/package.dhall sha256:d1a572ca3a764781496847e4921d7d9a881c18ffcfac6ae28d0e5299066938a0 ? ./Integer/package.dhall , List = ./List/package.dhall sha256:f0fdab7ab30415c128d89424589c42a15c835338be116fa14484086e4ba118d7 @@ -29,7 +29,7 @@ ./Optional/package.dhall sha256:7608f2d38dabee8bfe6865b4adc11289059984220f422d2b023b15b3908f7a4c ? ./Optional/package.dhall , JSON = - ./JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7 + ./JSON/package.dhall sha256:7533c6c457353bde410a57a5c1d82c6097c8d4dbf9f55a0d926ab56f4ffce77c ? ./JSON/package.dhall , Text = ./Text/package.dhall sha256:0a0ad9f649aed94c2680491efb384925b5b2bb5b353f1b8a7eb134955c1ffe45 diff --git a/dhall-lang/tests/normalization/success/unit/MergeNoneA.dhall b/dhall-lang/tests/normalization/success/unit/MergeNoneA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/MergeNoneA.dhall @@ -0,0 +1,1 @@ +merge { None = False, Some = \(b : Bool) -> b } (None Bool) diff --git a/dhall-lang/tests/normalization/success/unit/MergeNoneB.dhall b/dhall-lang/tests/normalization/success/unit/MergeNoneB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/MergeNoneB.dhall @@ -0,0 +1,1 @@ +False diff --git a/dhall-lang/tests/normalization/success/unit/MergeSomeA.dhall b/dhall-lang/tests/normalization/success/unit/MergeSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/MergeSomeA.dhall @@ -0,0 +1,1 @@ +merge { None = False, Some = \(b : Bool) -> b } (Some True) diff --git a/dhall-lang/tests/normalization/success/unit/MergeSomeB.dhall b/dhall-lang/tests/normalization/success/unit/MergeSomeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/MergeSomeB.dhall @@ -0,0 +1,1 @@ +True diff --git a/dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall b/dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall --- a/dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall +++ b/dhall-lang/tests/normalization/success/unit/NaturalBuildFoldFusionB.dhall @@ -1,1 +1,1 @@ -λ(x : Natural) → Natural/fold x Natural (λ(n : Natural) → n + 1) 0 +λ(x : Natural) → Natural/fold x Natural (λ(x : Natural) → x + 1) 0 diff --git a/dhall-lang/tests/parser/success/hexadecimalA.dhall b/dhall-lang/tests/parser/success/hexadecimalA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/hexadecimalA.dhall @@ -0,0 +1,6 @@ + λ(x : Bool) +→ λ(x : Bool) +→ { example0 = 0xFF + , example1 = -0x1A10 + , example2 = x@0x01 + } diff --git a/dhall-lang/tests/parser/success/hexadecimalB.dhallb b/dhall-lang/tests/parser/success/hexadecimalB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/hexadecimalB.dhallb @@ -0,0 +1,1 @@ +„axdBool„axdBool‚£hexample0‚ÿhexample1‚9hexample2‚ax diff --git a/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb b/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb Binary files a/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb and b/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitSomeA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitSomeA.dhall @@ -0,0 +1,1 @@ +{ Some = 0 } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitSomeB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitSomeB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/RecordLitSomeB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/SelectionSomeA.dhall b/dhall-lang/tests/parser/success/unit/SelectionSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/SelectionSomeA.dhall @@ -0,0 +1,1 @@ +record.{ Some } diff --git a/dhall-lang/tests/parser/success/unit/SelectionSomeB.dhallb b/dhall-lang/tests/parser/success/unit/SelectionSomeB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/SelectionSomeB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/UnionTypeSomeA.dhall b/dhall-lang/tests/parser/success/unit/UnionTypeSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/UnionTypeSomeA.dhall @@ -0,0 +1,1 @@ +< Some: Natural > diff --git a/dhall-lang/tests/parser/success/unit/UnionTypeSomeB.dhallb b/dhall-lang/tests/parser/success/unit/UnionTypeSomeB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/UnionTypeSomeB.dhallb @@ -0,0 +1,1 @@ +‚ ¡dSomegNatural diff --git a/dhall-lang/tests/type-inference/success/preludeB.dhall b/dhall-lang/tests/type-inference/success/preludeB.dhall --- a/dhall-lang/tests/type-inference/success/preludeB.dhall +++ b/dhall-lang/tests/type-inference/success/preludeB.dhall @@ -20,6 +20,7 @@ → ∀(g : B → C) → ∀(x : A) → C + , identity : ∀(a : Type) → ∀(x : a) → a } , Integer : { abs : ∀(n : Integer) → Natural @@ -32,6 +33,10 @@ , lessThanEqual : ∀(x : Integer) → ∀(y : Integer) → Bool , multiply : ∀(m : Integer) → ∀(n : Integer) → Integer , negate : Integer → Integer + , negative : ∀(n : Integer) → Bool + , nonNegative : ∀(n : Integer) → Bool + , nonPositive : ∀(n : Integer) → Bool + , positive : ∀(n : Integer) → Bool , show : Integer → Text , subtract : ∀(m : Integer) → ∀(n : Integer) → Integer , toDouble : Integer → Double @@ -48,8 +53,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON @@ -62,8 +68,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -75,13 +82,42 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } ) → JSON + , double : + ∀(x : Double) + → ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON + , integer : + ∀(x : Integer) + → ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON , keyText : ∀(key : Text) → ∀(value : Text) → { mapKey : Text, mapValue : Text } , keyValue : @@ -89,13 +125,28 @@ → ∀(key : Text) → ∀(value : v) → { mapKey : Text, mapValue : v } + , natural : + ∀(x : Natural) + → ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON , null : ∀(JSON : Type) → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -107,8 +158,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -123,8 +175,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON @@ -137,8 +190,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -150,8 +204,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -162,8 +217,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -175,8 +231,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -184,14 +241,16 @@ → JSON ) → Text + , renderInteger : ∀(integer : Integer) → Text , renderYAML : ∀ ( json : ∀(JSON : Type) → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } @@ -205,8 +264,9 @@ → ∀ ( json : { array : List JSON → JSON , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON , null : JSON - , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON , string : Text → JSON } diff --git a/dhall-lang/tests/type-inference/success/unit/MergeNoneA.dhall b/dhall-lang/tests/type-inference/success/unit/MergeNoneA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeNoneA.dhall @@ -0,0 +1,1 @@ +merge { None = False, Some = \(b : Bool) -> b } (None Bool) diff --git a/dhall-lang/tests/type-inference/success/unit/MergeNoneB.dhall b/dhall-lang/tests/type-inference/success/unit/MergeNoneB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeNoneB.dhall @@ -0,0 +1,1 @@ +Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeSomeA.dhall b/dhall-lang/tests/type-inference/success/unit/MergeSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeSomeA.dhall @@ -0,0 +1,1 @@ +merge { None = False, Some = \(b : Bool) -> b } (Some True) diff --git a/dhall-lang/tests/type-inference/success/unit/MergeSomeB.dhall b/dhall-lang/tests/type-inference/success/unit/MergeSomeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeSomeB.dhall @@ -0,0 +1,1 @@ +Bool diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.28.0 +Version: 1.29.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 @@ -39,6 +39,7 @@ dhall-lang/Prelude/Double/package.dhall dhall-lang/Prelude/Double/show dhall-lang/Prelude/Function/compose + dhall-lang/Prelude/Function/identity dhall-lang/Prelude/Function/package.dhall dhall-lang/Prelude/Integer/abs dhall-lang/Prelude/Integer/add @@ -50,7 +51,11 @@ dhall-lang/Prelude/Integer/lessThanEqual dhall-lang/Prelude/Integer/multiply dhall-lang/Prelude/Integer/negate + dhall-lang/Prelude/Integer/negative + dhall-lang/Prelude/Integer/nonNegative + dhall-lang/Prelude/Integer/nonPositive dhall-lang/Prelude/Integer/package.dhall + dhall-lang/Prelude/Integer/positive dhall-lang/Prelude/Integer/show dhall-lang/Prelude/Integer/subtract dhall-lang/Prelude/Integer/toDouble @@ -61,14 +66,18 @@ dhall-lang/Prelude/JSON/array dhall-lang/Prelude/JSON/bool dhall-lang/Prelude/JSON/core.dhall + dhall-lang/Prelude/JSON/double + dhall-lang/Prelude/JSON/integer dhall-lang/Prelude/JSON/keyText dhall-lang/Prelude/JSON/keyValue + dhall-lang/Prelude/JSON/natural dhall-lang/Prelude/JSON/null dhall-lang/Prelude/JSON/number dhall-lang/Prelude/JSON/object dhall-lang/Prelude/JSON/omitNullFields dhall-lang/Prelude/JSON/package.dhall dhall-lang/Prelude/JSON/render + dhall-lang/Prelude/JSON/renderInteger.dhall dhall-lang/Prelude/JSON/renderYAML dhall-lang/Prelude/JSON/string dhall-lang/Prelude/JSON/tagInline @@ -165,12 +174,13 @@ dhall-lang/Prelude/XML/render dhall-lang/Prelude/XML/text dhall-lang/Prelude/package.dhall + dhall-lang/tests/alpha-normalization/success/unit/*.dhall dhall-lang/tests/binary-decode/failure/unit/*.dhallb dhall-lang/tests/binary-decode/success/unit/*.dhall dhall-lang/tests/binary-decode/success/unit/*.dhallb dhall-lang/tests/import/cache/dhall/1220efc43103e49b56c5bf089db8e0365bbfc455b8a2f0dc6ee5727a3586f85969fd - dhall-lang/tests/import/data/*.txt dhall-lang/tests/import/data/*.dhall + dhall-lang/tests/import/data/*.txt dhall-lang/tests/import/data/fieldOrder/*.dhall dhall-lang/tests/import/failure/*.dhall dhall-lang/tests/import/success/*.dhall @@ -182,18 +192,17 @@ dhall-lang/tests/normalization/success/simple/*.dhall dhall-lang/tests/normalization/success/simplifications/*.dhall dhall-lang/tests/normalization/success/unit/*.dhall - dhall-lang/tests/alpha-normalization/success/unit/*.dhall dhall-lang/tests/parser/failure/*.dhall dhall-lang/tests/parser/success/*.dhall dhall-lang/tests/parser/success/*.dhallb + dhall-lang/tests/parser/success/text/*.dhall + dhall-lang/tests/parser/success/text/*.dhallb dhall-lang/tests/parser/success/unit/*.dhall dhall-lang/tests/parser/success/unit/*.dhallb dhall-lang/tests/parser/success/unit/import/*.dhall dhall-lang/tests/parser/success/unit/import/*.dhallb dhall-lang/tests/parser/success/unit/import/urls/*.dhall dhall-lang/tests/parser/success/unit/import/urls/*.dhallb - dhall-lang/tests/parser/success/text/*.dhall - dhall-lang/tests/parser/success/text/*.dhallb dhall-lang/tests/semantic-hash/success/*.dhall dhall-lang/tests/semantic-hash/success/*.hash dhall-lang/tests/semantic-hash/success/haskell-tutorial/access/*.dhall @@ -387,17 +396,18 @@ dhall-lang/tests/type-inference/success/prelude/Text/concatMap/*.dhall dhall-lang/tests/type-inference/success/prelude/Text/concatMapSep/*.dhall dhall-lang/tests/type-inference/success/prelude/Text/concatSep/*.dhall - dhall-lang/tests/type-inference/success/simple/access/*.dhall dhall-lang/tests/type-inference/success/simple/*.dhall + dhall-lang/tests/type-inference/success/simple/access/*.dhall dhall-lang/tests/type-inference/success/unit/*.dhall - tests/format/*.dhall - tests/lint/success/*.dhall tests/diff/*.dhall tests/diff/*.txt + tests/format/*.dhall + tests/lint/success/*.dhall tests/recursive/*.dhall tests/regression/*.dhall tests/tags/*.dhall tests/tags/*.tags + tests/th/*.dhall tests/tutorial/*.dhall Source-Repository head @@ -425,7 +435,7 @@ bytestring < 0.11, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , - cborg-json < 0.3 , + cborg-json >= 0.2.2.0 && < 0.3 , containers >= 0.5.0.0 && < 0.7 , contravariant < 1.6 , data-fix < 0.3 , @@ -517,6 +527,7 @@ Dhall.Core Dhall.Crypto Dhall.Diff + Dhall.DirectoryTree Dhall.Format Dhall.Freeze Dhall.Import @@ -582,6 +593,7 @@ Dhall.Test.QuickCheck Dhall.Test.Regression Dhall.Test.SemanticHash + Dhall.Test.TH Dhall.Test.Tutorial Dhall.Test.TypeInference Dhall.Test.Util diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -1225,7 +1225,7 @@ -- > \(Expr : Type) -- > -> let ExprF = -- > < LitF : --- > { _1 : Natural } +-- > Natural -- > | AddF : -- > { _1 : Expr, _2 : Expr } -- > | MulF : @@ -1233,7 +1233,7 @@ -- > > -- > -- > in \(Fix : ExprF -> Expr) --- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x }) +-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF x) -- > -- > let Add = -- > \(x : Expr) @@ -1291,7 +1291,6 @@ -- 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 Void -- ^ This is only used by the `FromDhall` instance for functions in order @@ -1334,7 +1333,7 @@ , constructorModifier = id , singletonConstructors = - Wrapped + Smart , inputNormalizer = Dhall.Core.ReifiedNormalizer (const (pure Nothing)) } diff --git a/src/Dhall/DirectoryTree.hs b/src/Dhall/DirectoryTree.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/DirectoryTree.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Implementation of the @dhall to-directory-tree@ subcommand +module Dhall.DirectoryTree + ( -- * Filesystem + toDirectoryTree + , FilesystemError(..) + ) where + +import Control.Exception (Exception) +import Data.Monoid ((<>)) +import Data.Void (Void) +import Dhall.Syntax (Chunks(..), Expr(..)) +import System.FilePath (()) + +import qualified Control.Exception as Exception +import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty +import qualified Dhall.Util as Util +import qualified Dhall.Map as Map +import qualified Dhall.Pretty +import qualified System.Directory as Directory +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO + +{-| Attempt to transform a Dhall record into a directory tree where: + + * Records are translated into directories + + * @Text@ values or fields are translated into files + + * @Optional@ values are omitted if @None@ + + For example, the following Dhall record: + + > { dir = { `hello.txt` = "Hello\n" } + > , `goodbye.txt`= Some "Goodbye\n" + > , `missing.txt` = None Text + > } + + ... should translate to this directory tree: + + > $ tree result + > result + > ├── dir + > │ └── hello.txt + > └── goodbye.txt + > + > $ cat result/dir/hello.txt + > Hello + > + > $ cat result/goodbye.txt + > Goodbye + + Use this in conjunction with the Prelude's support for rendering JSON/YAML + in "pure Dhall" so that you can generate files containing JSON. For + example: + + > let JSON = + > https://prelude.dhall-lang.org/v12.0.0/JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7 + > + > in { `example.json` = + > JSON.render (JSON.array [ JSON.number 1.0, JSON.bool True ]) + > , `example.yaml` = + > JSON.renderYAML + > (JSON.object (toMap { foo = JSON.string "Hello", bar = JSON.null })) + > } + + ... which would generate: + + > $ cat result/example.json + > [ 1.0, true ] + > + > $ cat result/example.yaml + > ! "bar": null + > ! "foo": "Hello" + + This utility does not take care of type-checking and normalizing the + provided expression. This will raise a `FilesystemError` exception upon + encountering an expression that is not a `TextLit` or `RecordLit`. +-} +toDirectoryTree :: FilePath -> Expr Void Void -> IO () +toDirectoryTree path expression = case expression of + RecordLit keyValues -> do + let process key value = do + Directory.createDirectoryIfMissing False path + + toDirectoryTree (path Text.unpack key) value + + Map.unorderedTraverseWithKey_ process keyValues + + TextLit (Chunks [] text) -> do + Text.IO.writeFile path text + + Some value -> do + toDirectoryTree path value + + App None _ -> do + return () + + _ -> do + let unexpectedExpression = expression + + Exception.throwIO FilesystemError{..} + +{- | This error indicates that you supplied an invalid Dhall expression to the + `directoryTree` function. The Dhall expression could not be translated to + a directory tree. +-} +newtype FilesystemError = + FilesystemError { unexpectedExpression :: Expr Void Void } + +instance Show FilesystemError where + show FilesystemError{..} = + Pretty.renderString (Dhall.Pretty.layout message) + where + message = + Util._ERROR <> ": Not a valid directory tree expression\n\ + \ \n\ + \Explanation: Only a subset of Dhall expressions can be converted to a directory \n\ + \tree. Specifically, record literals can be converted to directories, ❰Text❱ \n\ + \literals can be converted to files, and ❰Optional❱ values are included if ❰Some❱\n\ + \and omitted if ❰None❱. No other type of value can be translated to a directory \n\ + \tree. \n\ + \ \n\ + \For example, this is a valid expression that can be translated to a directory \n\ + \tree: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ { `example.json` = \"[1, true]\" } │ \n\ + \ └──────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \In contrast, the following expression is not allowed due to containing a \n\ + \❰Natural❱ field, which cannot be translated in this way: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ { `example.txt` = 1 } │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \You tried to translate the following expression to a directory tree: \n\ + \ \n\ + \" <> Util.insert unexpectedExpression <> "\n\ + \ \n\ + \... which is neither a ❰Text❱ literal, a record literal, nor an ❰Optional❱ \n\ + \value. \n" + +instance Exception FilesystemError diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -697,6 +697,12 @@ (VRecordLit m, VInject _ k mt, _) | Just f <- Map.lookup k m -> maybe f (vApp f) mt | otherwise -> error errorMsg + (VRecordLit m, VSome t, _) + | Just f <- Map.lookup "Some" m -> vApp f t + | otherwise -> error errorMsg + (VRecordLit m, VNone _, _) + | Just t <- Map.lookup "None" m -> t + | otherwise -> error errorMsg (x', y', ma') -> VMerge x' y' ma' ToMap x ma -> case (eval env x, fmap (eval env) ma) of diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | This module contains the implementation of the @dhall freeze@ subcommand @@ -27,7 +28,7 @@ import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text -import qualified Dhall.Core +import qualified Dhall.Core as Core import qualified Dhall.Import import qualified Dhall.Optics import qualified Dhall.Pretty @@ -60,11 +61,10 @@ Left exception -> Control.Exception.throwIO exception Right _ -> return () - let normalizedExpression = - Dhall.Core.alphaNormalize (Dhall.Core.normalize expression) + let normalizedExpression = Core.alphaNormalize (Core.normalize expression) -- make sure the frozen import is present in the semantic cache - Dhall.Import.writeExpressionToSemanticCache (Dhall.Core.denote expression) + Dhall.Import.writeExpressionToSemanticCache (Core.denote expression) let expressionHash = Dhall.Import.hashExpression normalizedExpression @@ -152,10 +152,10 @@ let cache (ImportAlt - (Embed + (Core.shallowDenote -> Embed (Import { importHashed = ImportHashed { hash = Just _expectedHash } }) ) - import_@(ImportAlt + import_@(Core.shallowDenote -> ImportAlt (Embed (Import { importHashed = ImportHashed { hash = Just _actualHash } }) ) @@ -190,9 +190,9 @@ traverse freezeFunction expression Cache -> Dhall.Optics.transformMOf - Dhall.Core.subExpressions + Core.subExpressions cache - (Dhall.Core.denote expression) + expression frozenExpression <- rewrite parsedExpression diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | This module contains the implementation of the @dhall lint@ command @@ -29,7 +30,7 @@ ) import qualified Data.List.NonEmpty as NonEmpty -import qualified Dhall.Core +import qualified Dhall.Core as Core import qualified Dhall.Optics import qualified Lens.Family @@ -42,12 +43,14 @@ * consolidates nested @let@ bindings to use a multiple-@let@ binding with 'removeLetInLet' * fixes paths of the form @.\/..\/foo@ to @..\/foo@ -} -lint :: Expr s Import -> Expr t Import -lint = - Dhall.Optics.rewriteOf - subExpressions - (\e -> fixAssert e <|> removeUnusedBindings e <|> fixParentPath e) - . removeLetInLet +lint :: Expr s Import -> Expr s Import +lint = Dhall.Optics.rewriteOf subExpressions rewrite + where + rewrite e = + fixAssert e + <|> removeUnusedBindings e + <|> fixParentPath e + <|> removeLetInLet e -- | Remove unused `Let` bindings. removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a) @@ -55,16 +58,16 @@ removeUnusedBindings (Let (Binding _ _ _ _ _ e) _) | isOrContainsAssert e = Nothing removeUnusedBindings (Let (Binding _ a _ _ _ _) d) - | not (V a 0 `Dhall.Core.freeIn` d) = - Just (Dhall.Core.shift (-1) (V a 0) d) + | not (V a 0 `Core.freeIn` d) = + Just (Core.shift (-1) (V a 0) d) removeUnusedBindings _ = Nothing -- | Fix `Let` bindings that the user probably meant to be `assert`s fixAssert :: Expr s a -> Maybe (Expr s a) -fixAssert (Let (Binding { value = Equivalent x y, ..}) body) = - Just (Let (Binding { value = Assert (Equivalent x y), .. }) body) -fixAssert (Let binding (Equivalent x y)) = - Just (Let binding (Assert (Equivalent x y))) +fixAssert (Let (Binding { value = v@(Core.shallowDenote -> Equivalent {}), ..}) body) = + Just (Let (Binding { value = Assert v, .. }) body) +fixAssert (Let binding body@(Core.shallowDenote -> Equivalent {})) = + Just (Let binding (Assert body)) fixAssert _ = Nothing @@ -109,6 +112,8 @@ -- -- is that in the second expression, the inner 'Let' is wrapped by a 'Note'. -- --- Denoting removes that distinction. -removeLetInLet :: Expr s a -> Expr t a -removeLetInLet = Dhall.Core.denote +-- We remove such a 'Note' in order to consolidate nested let-blocks into a +-- single one. +removeLetInLet :: Expr s a -> Maybe (Expr s a) +removeLetInLet (Let binding (Note _ l@Let{})) = Just (Let binding l) +removeLetInLet _ = Nothing diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -28,7 +28,14 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void) -import Dhall.Core (Expr(Annot), Import, pretty) +import Dhall.Core + ( Expr(Annot) + , Import(..) + , ImportHashed(..) + , ImportType(..) + , URL(..) + , pretty + ) import Dhall.Freeze (Intent(..), Scope(..)) import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode) import Dhall.Parser (Src) @@ -60,6 +67,7 @@ import qualified Dhall.Binary import qualified Dhall.Core import qualified Dhall.Diff +import qualified Dhall.DirectoryTree as DirectoryTree import qualified Dhall.Format import qualified Dhall.Freeze import qualified Dhall.Import @@ -133,6 +141,7 @@ | Encode { file :: Input, json :: Bool } | Decode { file :: Input, json :: Bool } | Text { file :: Input } + | DirectoryTree { file :: Input, path :: FilePath } | SyntaxTree { file :: Input } data ResolveMode @@ -240,6 +249,10 @@ "text" "Render a Dhall expression that evaluates to a Text literal" (Text <$> parseFile) + <|> subcommand + "to-directory-tree" + "Convert nested records of Text literals into a directory tree" + (DirectoryTree <$> parseFile <*> parseDirectoryTreeOutput) <|> internalSubcommand "haskell-syntax-tree" "Output the parsed syntax tree (for debugging)" @@ -408,6 +421,13 @@ <> Options.Applicative.help "Only check if the input is formatted" ) + parseDirectoryTreeOutput = + Options.Applicative.strOption + ( Options.Applicative.long "output" + <> Options.Applicative.help "The destination path to create" + <> Options.Applicative.metavar "PATH" + ) + parseFormatMode = adapt <$> parseCheck <*> parseInplace where adapt True path = Dhall.Format.Check {..} @@ -422,6 +442,13 @@ <> Options.Applicative.fullDesc ) +noHeaders :: Import -> Import +noHeaders + (Import { importHashed = ImportHashed { importType = Remote URL{ .. }, ..}, .. }) = + Import { importHashed = ImportHashed { importType = Remote URL{ headers = Nothing, .. }, .. }, .. } +noHeaders i = + i + -- | Run the command specified by the `Options` type command :: Options -> IO () command (Options {..}) = do @@ -561,10 +588,12 @@ let dotNode (i, nodeId) = Text.Dot.userNode nodeId - [ ("label", Data.Text.unpack $ pretty i) + [ ("label", Data.Text.unpack $ pretty (convert i)) , ("shape", "box") , ("style", "rounded") ] + where + convert = noHeaders . Dhall.Import.chainedImport let dotEdge (Depends parent child) = case (Data.Map.lookup parent importIds, Data.Map.lookup child importIds) of @@ -580,9 +609,7 @@ Resolve { resolveMode = Just ListImmediateDependencies, ..} -> do expression <- getExpression file - mapM_ (print - . Pretty.pretty - . Dhall.Core.importHashed) expression + mapM_ (print . Pretty.pretty . noHeaders) expression Resolve { resolveMode = Just ListTransitiveDependencies, ..} -> do expression <- getExpression file @@ -591,10 +618,10 @@ State.execStateT (Dhall.Import.loadWith expression) (toStatus file) { _semanticCacheMode = semanticCacheMode } mapM_ print - . fmap ( Pretty.pretty - . Dhall.Core.importType - . Dhall.Core.importHashed - . Dhall.Import.chainedImport ) + . fmap ( Pretty.pretty + . noHeaders + . Dhall.Import.chainedImport + ) . reverse . Dhall.Map.keys $ _cache @@ -761,6 +788,18 @@ System.IO.withFile file System.IO.WriteMode (`Data.Text.IO.hPutStr` tags) StandardOutput -> Data.Text.IO.putStrLn tags + + DirectoryTree {..} -> do + expression <- getExpression file + + resolvedExpression <- + Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression + + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) + + let normalizedExpression = Dhall.Core.normalize resolvedExpression + + DirectoryTree.toDirectoryTree path normalizedExpression SyntaxTree {..} -> do expression <- getExpression file diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -920,6 +920,14 @@ Nothing -> Merge x' y' <$> t' _ -> Merge x' y' <$> t' + Some a -> + case Dhall.Map.lookup "Some" kvsX of + Just vX -> loop (App vX a) + Nothing -> Merge x' y' <$> t' + App None _ -> + case Dhall.Map.lookup "None" kvsX of + Just vX -> return vX + Nothing -> Merge x' y' <$> t' _ -> Merge x' y' <$> t' _ -> Merge x' y' <$> t' where @@ -1191,7 +1199,14 @@ decide (RecordLit _) (RecordLit _) = False decide l r = not (Eval.judgmentallyEqual l r) RecordCompletion _ _ -> False - Merge x y t -> loop x && loop y && all loop t + Merge x y t -> loop x && loop y && all loop t && case x of + RecordLit _ -> case y of + Field (Union _) _ -> False + App (Field (Union _) _) _ -> False + Some _ -> False + App None _ -> False + _ -> True + _ -> True ToMap x t -> case x of RecordLit _ -> False _ -> loop x && all loop t diff --git a/src/Dhall/Parser/Expression.hs b/src/Dhall/Parser/Expression.hs --- a/src/Dhall/Parser/Expression.hs +++ b/src/Dhall/Parser/Expression.hs @@ -12,7 +12,6 @@ import Data.ByteArray.Encoding (Base(..)) import Data.Foldable (foldl') import Data.Functor (void) -import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Dhall.Syntax @@ -24,7 +23,6 @@ import qualified Data.ByteArray.Encoding import qualified Data.ByteString import qualified Data.Char as Char -import qualified Data.Foldable import qualified Data.List import qualified Data.List.NonEmpty import qualified Data.Sequence @@ -673,7 +671,7 @@ _ <- endOfLine a <- singleQuoteContinue - return (toDoubleQuoted a) + return (Dhall.Syntax.toDoubleQuoted a) where endOfLine = (void (char '\n') <|> void (text "\r\n")) "newline" @@ -935,89 +933,3 @@ try (whitespace *> _as *> nonemptyWhitespace) (_Text >> pure RawText) <|> (_Location >> pure Location) - --- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result -splitOn :: Text -> Text -> NonEmpty Text -splitOn needle haystack = - case Data.Text.splitOn needle haystack of - [] -> "" :| [] - t : ts -> t :| ts - --- | Split `Chunks` by lines -linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) -linesLiteral (Chunks [] suffix) = - fmap (Chunks []) (splitOn "\n" suffix) -linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = - foldr - Data.List.NonEmpty.cons - (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) - (fmap (Chunks []) initLines) - where - splitLines = splitOn "\n" prefix - - initLines = Data.List.NonEmpty.init splitLines - lastLine = Data.List.NonEmpty.last splitLines - - Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) - --- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines -unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a -unlinesLiteral chunks = - Data.Foldable.fold (Data.List.NonEmpty.intersperse "\n" chunks) - --- | Returns `True` if the `Chunks` represents a blank line -emptyLine :: Chunks s a -> Bool -emptyLine (Chunks [] "" ) = True -emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line -emptyLine _ = False - --- | Return the leading whitespace for a `Chunks` literal -leadingSpaces :: Chunks s a -> Text -leadingSpaces chunks = Data.Text.takeWhile isSpace firstText - where - isSpace c = c == '\x20' || c == '\x09' - - firstText = - case chunks of - Chunks [] suffix -> suffix - Chunks ((prefix, _) : _ ) _ -> prefix - --- | Drop the first @n@ characters for a `Chunks` literal -dropLiteral :: Int -> Chunks s a -> Chunks s a -dropLiteral n (Chunks [] suffix) = - Chunks [] (Data.Text.drop n suffix) -dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = - Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix - -{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted - `Chunks` literal --} -toDoubleQuoted :: Chunks Src a -> Chunks Src a -toDoubleQuoted literal = - unlinesLiteral (fmap (dropLiteral indent) literals) - where - literals = linesLiteral literal - - sharedPrefix ab ac = - case Data.Text.commonPrefixes ab ac of - Just (a, _b, _c) -> a - Nothing -> "" - - -- The standard specifies to filter out blank lines for all lines *except* - -- for the last line - filteredLines = newInit <> pure oldLast - where - oldInit = Data.List.NonEmpty.init literals - - oldLast = Data.List.NonEmpty.last literals - - newInit = filter (not . emptyLine) oldInit - - longestSharedPrefix = - case filteredLines of - l : ls -> - Data.Foldable.foldl' sharedPrefix (leadingSpaces l) (fmap leadingSpaces ls) - [] -> - "" - - indent = Data.Text.length longestSharedPrefix diff --git a/src/Dhall/Parser/Token.hs b/src/Dhall/Parser/Token.hs --- a/src/Dhall/Parser/Token.hs +++ b/src/Dhall/Parser/Token.hs @@ -213,8 +213,8 @@ integerLiteral :: Parser Integer integerLiteral = (do sign <- signPrefix - a <- Text.Megaparsec.Char.Lexer.decimal - return (sign a) ) "literal" + a <- naturalLiteral + return (sign (fromIntegral a)) ) "literal" {-| Parse a `Natural` literal @@ -222,7 +222,8 @@ -} naturalLiteral :: Parser Natural naturalLiteral = (do - a <- Text.Megaparsec.Char.Lexer.decimal + a <- try (char '0' >> char 'x' >> Text.Megaparsec.Char.Lexer.hexadecimal) + <|> Text.Megaparsec.Char.Lexer.decimal return a ) "literal" {-| Parse an identifier (i.e. a variable or built-in) @@ -239,8 +240,8 @@ whitespace _at whitespace - n <- Text.Megaparsec.Char.Lexer.decimal - return n + n <- naturalLiteral + return (fromIntegral n) n <- indexed <|> pure 0 return (V x n) @@ -339,10 +340,13 @@ Control.Monad.guard (allowReserved || not (Data.HashSet.member t reservedIdentifiers)) return t ) where - headCharacter c = alpha c || c == '_' - tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/' +headCharacter :: Char -> Bool +headCharacter c = alpha c || c == '_' +tailCharacter :: Char -> Bool +tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/' + backtickLabel :: Parser Text backtickLabel = do _ <- char '`' @@ -1119,7 +1123,9 @@ -- | Parse the @missing@ keyword _missing :: Parser () -_missing = keyword "missing" +_missing = + keyword "missing" + *> Text.Megaparsec.notFollowedBy (Text.Parser.Char.satisfy tailCharacter) -- | Parse the @?@ symbol _importAlt :: Parser () diff --git a/src/Dhall/Pretty.hs b/src/Dhall/Pretty.hs --- a/src/Dhall/Pretty.hs +++ b/src/Dhall/Pretty.hs @@ -12,6 +12,9 @@ , Dhall.Pretty.Internal.layout , Dhall.Pretty.Internal.layoutOpts + + , escapeEnvironmentVariable + , escapeLabel ) where import Dhall.Pretty.Internal diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -21,9 +21,11 @@ , prettyVar , pretty_ , escapeText_ + , escapeEnvironmentVariable , prettyEnvironmentVariable , prettyConst + , escapeLabel , prettyLabel , prettyAnyLabel , prettyLabels @@ -211,7 +213,7 @@ builtin = Pretty.annotate Builtin operator = Pretty.annotate Operator -comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, backtick, dollar, colon, equals, dot :: Doc Ann +comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, dollar, colon, equals, dot :: Doc Ann comma = syntax Pretty.comma lbracket = syntax Pretty.lbracket rbracket = syntax Pretty.rbracket @@ -222,7 +224,6 @@ lparen = syntax Pretty.lparen rparen = syntax Pretty.rparen pipe = syntax Pretty.pipe -backtick = syntax "`" dollar = syntax "$" colon = syntax ":" equals = syntax "=" @@ -282,16 +283,18 @@ rbrace docs -hangingBraces :: [(Doc Ann, Doc Ann)] -> Doc Ann -hangingBraces [] = +hangingBraces :: Int -> [(Doc Ann, Doc Ann)] -> Doc Ann +hangingBraces _ [] = lbrace <> rbrace -hangingBraces docs = +hangingBraces n docs = Pretty.group (Pretty.flatAlt ( lbrace <> Pretty.hardline - <> mconcat (zipWith combineLong (repeat separator) docsLong) - <> rbrace + <> Pretty.indent n + ( mconcat (zipWith combineLong (repeat separator) docsLong) + <> rbrace + ) ) (mconcat (zipWith (<>) (beginShort : repeat separator) docsShort) <> space <> rbrace) ) @@ -420,15 +423,17 @@ tailCharacter :: Char -> Bool tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/' +-- | Escape a label if it is not valid when unquoted +escapeLabel :: Bool -> Text -> Text +escapeLabel allowReserved l = + case Text.uncons l of + Just (h, t) + | headCharacter h && Text.all tailCharacter t && (allowReserved || not (Data.HashSet.member l reservedIdentifiers)) + -> l + _ -> "`" <> l <> "`" + prettyLabelShared :: Bool -> Text -> Doc Ann -prettyLabelShared allowReserved a = label doc - where - doc = - case Text.uncons a of - Just (h, t) - | headCharacter h && Text.all tailCharacter t && (allowReserved || not (Data.HashSet.member a reservedIdentifiers)) - -> Pretty.pretty a - _ -> backtick <> Pretty.pretty a <> backtick +prettyLabelShared b l = label (Pretty.pretty (escapeLabel b l)) prettyLabel :: Text -> Doc Ann prettyLabel = prettyLabelShared False @@ -465,9 +470,13 @@ prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyInt n)) prettyEnvironmentVariable :: Text -> Doc ann -prettyEnvironmentVariable t - | validBashEnvVar t = Pretty.pretty t - | otherwise = Pretty.pretty ("\"" <> escapeText_ t <> "\"") +prettyEnvironmentVariable t = Pretty.pretty (escapeEnvironmentVariable t) + +-- | Escape an environment variable if not a valid Bash environment variable +escapeEnvironmentVariable :: Text -> Text +escapeEnvironmentVariable t + | validBashEnvVar t = t + | otherwise = "\"" <> escapeText_ t <> "\"" where validBashEnvVar v = case Text.uncons v of Nothing -> False @@ -918,7 +927,7 @@ Pretty.align ( prettySelectorExpression a <> doubleColon - <> prettyCompletionLit kvs + <> prettyCompletionLit 0 kvs ) _ -> prettySelectorExpression a <> doubleColon @@ -1048,18 +1057,46 @@ prettyKeyValue separator (key, val) = duplicate (Pretty.group (Pretty.flatAlt long short)) where + completion _T r = + " " + <> prettySelectorExpression _T + <> doubleColon + <> case shallowDenote r of + RecordLit kvs -> + prettyCompletionLit 2 kvs + _ -> + prettySelectorExpression r + short = prettyAnyLabel key <> " " <> separator <> " " <> prettyExpression val - long = prettyAnyLabel key + long = + prettyAnyLabel key <> " " <> separator - <> Pretty.hardline - <> " " - <> prettyExpression val + <> case shallowDenote val of + Some val' -> + " Some" + <> case shallowDenote val' of + RecordCompletion _T r -> + completion _T r + _ -> Pretty.hardline + <> " " + <> prettyImportExpression val' + RecordCompletion _T r -> + completion _T r + ListLit _ xs + | not (null xs) -> + Pretty.hardline + <> " " + <> prettyExpression val + _ -> + Pretty.hardline + <> " " + <> prettyExpression val prettyRecord :: Pretty a => Map Text (Expr Src a) -> Doc Ann prettyRecord = @@ -1073,12 +1110,12 @@ braces (map (prettyKeyValue equals) (Dhall.Map.toList a)) prettyCompletionLit - :: Pretty a => Map Text (Expr Src a) -> Doc Ann - prettyCompletionLit a + :: Pretty a => Int -> Map Text (Expr Src a) -> Doc Ann + prettyCompletionLit n a | Data.Foldable.null a = lbrace <> equals <> rbrace | otherwise = - hangingBraces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + hangingBraces n (map (prettyKeyValue equals) (Dhall.Map.toList a)) prettyAlternative (key, Just val) = prettyKeyValue colon (key, val) prettyAlternative (key, Nothing ) = duplicate (prettyAnyLabel key) @@ -1151,53 +1188,46 @@ multilineChunks = escapeTrailingSingleQuote . escapeControlCharacters - . escapeLastLineLeadingWhitespace + . escapeSharedWhitespacePrefix --- | Escape leading whitespace on the last line by moving it into a string --- interpolation +-- | Escape any leading whitespace shared by all lines -- --- This ensures that the parser can find the correct indentation level, no matter --- what the other lines contain.- +-- This ensures that significant shared leading whitespace is not stripped -- --- >>> escapeLastLineLeadingWhitespace (Chunks [] "\n \tx") +-- >>> escapeSharedWhitespacePrefix (Chunks [] "\n \tx") -- Chunks [("\n",TextLit (Chunks [] " \t"))] "x" --- >>> escapeLastLineLeadingWhitespace (Chunks [("\n",Var (V "x" 0))] " ") +-- >>> escapeSharedWhitespacePrefix (Chunks [("\n",Var (V "x" 0))] " ") -- Chunks [("\n",Var (V "x" 0))] " " --- >>> escapeLastLineLeadingWhitespace (Chunks [("\n ",Var (V "x" 0))] "") +-- >>> escapeSharedWhitespacePrefix (Chunks [("\n ",Var (V "x" 0))] "") -- Chunks [("\n",TextLit (Chunks [] " ")),("",Var (V "x" 0))] "" --- >>> escapeLastLineLeadingWhitespace (Chunks [("\n ",Var (V "x" 0))] "\n") +-- >>> escapeSharedWhitespacePrefix (Chunks [("\n ",Var (V "x" 0))] "\n") -- Chunks [("\n ",Var (V "x" 0))] "\n" --- --- We assume that there's at least one newline and may therefore ignore leading --- whitespace on the first line: --- --- >>> escapeLastLineLeadingWhitespace (Chunks [] " ") --- Chunks [] " " -escapeLastLineLeadingWhitespace :: Chunks s a -> Chunks s a -escapeLastLineLeadingWhitespace (Chunks as0 b0) = - case escape1 b0 of - Nothing -> Chunks (escapeChunks as0) b0 - Just (Chunks cs b1) -> Chunks (as0 ++ cs) b1 +-- >>> escapeSharedWhitespacePrefix (Chunks [] " ") +-- Chunks [("",TextLit (Chunks [] " "))] "" +escapeSharedWhitespacePrefix :: Chunks s a -> Chunks s a +escapeSharedWhitespacePrefix literal_ = unlinesLiteral literals₁ where - -- Nothing: No newline found - -- Just chunks: Newline was found! - escape1 :: Text -> Maybe (Chunks s a) - escape1 t = case Text.breakOnEnd "\n" t of - ("", _) -> Nothing - (a , b) -> Just $ case Text.span predicate b of - ("", _) -> Chunks [] t - (c , d) -> Chunks [(a, TextLit (Chunks [] c))] d + literals₀ = linesLiteral literal_ - predicate c = c == ' ' || c == '\t' + sharedPrefix = longestSharedWhitespacePrefix literals₀ - escapeChunks = snd . foldr f (NotDone, []) + stripPrefix = Text.drop (Text.length sharedPrefix) - f chunk (Done , chunks) = (Done, chunk : chunks) - f (t, e) (NotDone, chunks) = case escape1 t of - Nothing -> (NotDone, (t, e) : chunks) - Just (Chunks as b) -> (Done, as ++ (b, e) : chunks) + escapeSharedPrefix (Chunks [] prefix₀) + | Text.isPrefixOf sharedPrefix prefix₀ = + Chunks [ ("", TextLit (Chunks [] sharedPrefix)) ] prefix₁ + where + prefix₁ = stripPrefix prefix₀ + escapeSharedPrefix (Chunks ((prefix₀, y) : xys) z) + | Text.isPrefixOf sharedPrefix prefix₀ = + Chunks (("", TextLit (Chunks [] sharedPrefix)) : (prefix₁, y) : xys) z + where + prefix₁ = stripPrefix prefix₀ + escapeSharedPrefix line = line -data Done = NotDone | Done + literals₁ + | not (Text.null sharedPrefix) = fmap escapeSharedPrefix literals₀ + | otherwise = literals₀ -- | Escape control characters by moving them into string interpolations -- @@ -1320,7 +1350,6 @@ layoutOpts = Pretty.defaultLayoutOptions { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } - {- $setup >>> import Test.QuickCheck (Fun(..)) diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -56,6 +56,12 @@ -- * Reserved identifiers , reservedIdentifiers + + -- * `Text` manipulation + , toDoubleQuoted + , longestSharedWhitespacePrefix + , linesLiteral + , unlinesLiteral ) where import Control.DeepSeq (NFData) @@ -1204,3 +1210,93 @@ , "Kind" , "Sort" ] + +-- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result +splitOn :: Text -> Text -> NonEmpty Text +splitOn needle haystack = + case Data.Text.splitOn needle haystack of + [] -> "" :| [] + t : ts -> t :| ts + +-- | Split `Chunks` by lines +linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) +linesLiteral (Chunks [] suffix) = + fmap (Chunks []) (splitOn "\n" suffix) +linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = + foldr + Data.List.NonEmpty.cons + (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) + (fmap (Chunks []) initLines) + where + splitLines = splitOn "\n" prefix + + initLines = Data.List.NonEmpty.init splitLines + lastLine = Data.List.NonEmpty.last splitLines + + Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) + +-- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines +unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a +unlinesLiteral chunks = + Data.Foldable.fold (Data.List.NonEmpty.intersperse "\n" chunks) + +-- | Returns `True` if the `Chunks` represents a blank line +emptyLine :: Chunks s a -> Bool +emptyLine (Chunks [] "" ) = True +emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line +emptyLine _ = False + +-- | Return the leading whitespace for a `Chunks` literal +leadingSpaces :: Chunks s a -> Text +leadingSpaces chunks = Data.Text.takeWhile isSpace firstText + where + isSpace c = c == ' ' || c == '\t' + + firstText = + case chunks of + Chunks [] suffix -> suffix + Chunks ((prefix, _) : _ ) _ -> prefix + +{-| Compute the longest shared whitespace prefix for the purposes of stripping + leading indentation +-} +longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text +longestSharedWhitespacePrefix literals = + case fmap leadingSpaces filteredLines of + l : ls -> Data.Foldable.foldl' sharedPrefix l ls + [] -> "" + where + sharedPrefix ab ac = + case Data.Text.commonPrefixes ab ac of + Just (a, _b, _c) -> a + Nothing -> "" + + -- The standard specifies to filter out blank lines for all lines *except* + -- for the last line + filteredLines = newInit <> pure oldLast + where + oldInit = Data.List.NonEmpty.init literals + + oldLast = Data.List.NonEmpty.last literals + + newInit = filter (not . emptyLine) oldInit + +-- | Drop the first @n@ characters for a `Chunks` literal +dropLiteral :: Int -> Chunks s a -> Chunks s a +dropLiteral n (Chunks [] suffix) = + Chunks [] (Data.Text.drop n suffix) +dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = + Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix + +{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted + `Chunks` literal +-} +toDoubleQuoted :: Chunks Src a -> Chunks Src a +toDoubleQuoted literal = + unlinesLiteral (fmap (dropLiteral indent) literals) + where + literals = linesLiteral literal + + longestSharedPrefix = longestSharedWhitespacePrefix literals + + indent = Data.Text.length longestSharedPrefix diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -1,10 +1,54 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -{-| This module provides `staticDhallExpression` which can be used to resolve - all of an expression’s imports at compile time, allowing one to reference - Dhall expressions from Haskell without having a runtime dependency on the - location of Dhall files. +-- | Template Haskell utilities +module Dhall.TH + ( -- * Template Haskell + staticDhallExpression + , makeHaskellTypeFromUnion + ) where +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty) +import Dhall.Syntax (Expr(..)) +import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility. + +import Language.Haskell.TH.Syntax + ( Con(..) + , Dec(..) + , Exp(..) + , Q + , Type(..) +#if MIN_VERSION_template_haskell(2,11,0) + , Bang(..) + , SourceStrictness(..) + , SourceUnpackedness(..) +#else + , Strict(..) +#endif + ) + +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty +import qualified Data.Typeable as Typeable +import qualified Dhall +import qualified Dhall.Map +import qualified Dhall.Pretty +import qualified Dhall.Util +import qualified GHC.IO.Encoding +import qualified Numeric.Natural +import qualified System.IO +import qualified Language.Haskell.TH.Syntax as Syntax + +{-| This fully resolves, type checks, and normalizes the expression, so the + resulting AST is self-contained. + + This can be used to resolve all of an expression’s imports at compile time, + allowing one to reference Dhall expressions from Haskell without having a + runtime dependency on the location of Dhall files. + For example, given a file @".\/Some\/Type.dhall"@ containing > < This : Natural | Other : ../Other/Type.dhall > @@ -22,28 +66,217 @@ at compile time with all imports resolved, making it easy to keep your Dhall configs and Haskell interpreters in sync. -} -module Dhall.TH - ( -- * Template Haskell - staticDhallExpression - ) where - -import Data.Typeable -import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility. -import Language.Haskell.TH.Syntax +staticDhallExpression :: Text -> Q Exp +staticDhallExpression text = do + Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) -import qualified Data.Text as Text -import qualified Dhall -import qualified GHC.IO.Encoding -import qualified System.IO + expression <- Syntax.runIO (Dhall.inputExpr text) --- | This fully resolves, type checks, and normalizes the expression, so the --- resulting AST is self-contained. -staticDhallExpression :: Text.Text -> Q Exp -staticDhallExpression text = do - runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) - expression <- runIO (Dhall.inputExpr text) - dataToExpQ (\a -> liftText <$> cast a) expression + dataToExpQ (\a -> liftText <$> Typeable.cast a) expression where -- A workaround for a problem in TemplateHaskell (see -- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable) - liftText = fmap (AppE (VarE 'Text.pack)) . lift . Text.unpack + liftText = fmap (AppE (VarE 'Text.pack)) . Syntax.lift . Text.unpack + +{-| Convert a Dhall type to a Haskell type that does not require any new + data declarations +-} +toSimpleHaskellType :: Pretty a => Expr s a -> Q Type +toSimpleHaskellType dhallType = + case dhallType of + Bool -> do + return (ConT ''Bool) + + Double -> do + return (ConT ''Double) + + Integer -> do + return (ConT ''Integer) + + Natural -> do + return (ConT ''Numeric.Natural.Natural) + + Text -> do + return (ConT ''Text) + + App List dhallElementType -> do + haskellElementType <- toSimpleHaskellType dhallElementType + + return (AppT (ConT ''[]) haskellElementType) + + App Optional dhallElementType -> do + haskellElementType <- toSimpleHaskellType dhallElementType + + return (AppT (ConT ''Maybe) haskellElementType) + + _ -> do + let document = + mconcat + [ "Unsupported simple type\n" + , " \n" + , "Explanation: Not all Dhall alternative types can be converted to Haskell \n" + , "constructor types. Specifically, only the following simple Dhall types are \n" + , "supported as an alternative type or a field of an alternative type: \n" + , " \n" + , "• ❰Bool❱ \n" + , "• ❰Double❱ \n" + , "• ❰Integer❱ \n" + , "• ❰Natural❱ \n" + , "• ❰Text❱ \n" + , "• ❰List a❱ (where ❰a❱ is also a simple type) \n" + , "• ❰Optional a❱ (where ❰a❱ is also a simple type) \n" + , " \n" + , "The Haskell datatype generation logic encountered the following complex \n" + , "Dhall type: \n" + , " \n" + , " " <> Dhall.Util.insert dhallType <> "\n" + , " \n" + , "... where a simpler type was expected." + ] + + let message = Pretty.renderString (Dhall.Pretty.layout document) + + fail message + +-- | Convert a Dhall type to the corresponding Haskell constructor type +toConstructor :: Pretty a => (Text, Maybe (Expr s a)) -> Q Con +toConstructor (constructorName, maybeAlternativeType) = do + let name = Syntax.mkName (Text.unpack constructorName) + +#if MIN_VERSION_template_haskell(2,11,0) + let bang = Bang NoSourceUnpackedness NoSourceStrictness +#else + let bang = NotStrict +#endif + + case maybeAlternativeType of + Just (Record kts) -> do + let process (key, dhallFieldType) = do + haskellFieldType <- toSimpleHaskellType dhallFieldType + + return (Syntax.mkName (Text.unpack key), bang, haskellFieldType) + + varBangTypes <- traverse process (Dhall.Map.toList kts) + + return (RecC name varBangTypes) + + Just dhallAlternativeType -> do + haskellAlternativeType <- toSimpleHaskellType dhallAlternativeType + + return (NormalC name [ (bang, haskellAlternativeType) ]) + + Nothing -> do + return (NormalC name []) + +-- | Generate a Haskell datatype declaration from a Dhall union type where +-- each union alternative corresponds to a Haskell constructor +-- +-- This comes in handy if you need to keep a Dhall type and Haskell type in +-- sync. You make the Dhall type the source of truth and use Template Haskell +-- to generate the matching Haskell type declaration from the Dhall type. +-- +-- For example, this Template Haskell splice: +-- +-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >" +-- +-- ... generates this Haskell code: +-- +-- > data T = A {x :: GHC.Types.Bool} | B +-- +-- If you are starting from an existing record type that you want to convert to +-- a Haskell type, wrap the record type in a union with one alternative, like +-- this: +-- +-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : ./recordType.dhall >" +-- +-- To add any desired instances (such as `Dhall.FromDhall`/`Dhall.ToDhall`), +-- you can use the `StandaloneDeriving` language extension, like this: +-- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE StandaloneDeriving #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > +-- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >" +-- > +-- > deriving instance Generic T +-- > deriving instance FromDhall T +makeHaskellTypeFromUnion + :: Text + -- ^ Name of the generated Haskell type + -> Text + -- ^ Dhall code that evaluates to a union type + -> Q [Dec] +makeHaskellTypeFromUnion typeName text = do + Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) + + expression <- Syntax.runIO (Dhall.inputExpr text) + + case expression of + Union kts -> do + let name = Syntax.mkName (Text.unpack typeName) + + constructors <- traverse toConstructor (Dhall.Map.toList kts ) + + let declaration = DataD [] name [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#else +#endif + constructors [] + + return [ declaration ] + + _ -> do + let document = + mconcat + [ "Dhall.TH.makeHaskellTypeFromUnion: Unsupported Dhall type\n" + , " \n" + , "Explanation: This function only coverts Dhall union types to Haskell datatype \n" + , "declarations. \n" + , " \n" + , "For example, this is a valid Dhall union type that this function would accept: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────────────────────────────────┐ \n" + , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : { x : Bool } | B >\" │ \n" + , " └──────────────────────────────────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "... which corresponds to this Haskell type declaration: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────┐ \n" + , " │ data T = A {x :: GHC.Types.Bool} | B │ \n" + , " └──────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "... but the following Dhall type is rejected due to being a bare record type: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────────────────────┐ \n" + , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"{ x : Bool }\" │ Not valid \n" + , " └──────────────────────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "If you are starting from a file containing only a record type and you want to \n" + , "generate a Haskell type from that, then wrap the record type in a union with one\n" + , "alternative, like this: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────────────────────────────────┐ \n" + , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : ./recordType.dhall >\" │ \n" + , " └──────────────────────────────────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "The Haskell datatype generation logic encountered the following Dhall type: \n" + , " \n" + , " " <> Dhall.Util.insert expression <> "\n" + , " \n" + , "... which is not a union type." + ] + + let message = Pretty.renderString (Dhall.Pretty.layout document) + + fail message diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -1880,7 +1880,7 @@ -- > let inputSettings = transform Dhall.defaultInputSettings -- > where -- > transform = --- > Lens.set Dhall.normalizer (ReifiedNormalizer (pure . normalizer)) +-- > Lens.set Dhall.normalizer (Just (ReifiedNormalizer (pure . normalizer))) -- > . Lens.set Dhall.startingContext startingContext -- > -- > x <- Dhall.inputWithSettings inputSettings Dhall.auto text diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -24,6 +24,8 @@ , DetailedTypeError(..) , Censored(..) , TypeMessage(..) + , prettyTypeMessage + , ErrorMessages(..) ) where import Control.Exception (Exception) @@ -933,10 +935,15 @@ VUnion yUs' -> do return yUs' + VOptional _O' -> + -- This is a bit of hack, but it allows us to reuse the + -- rather complex type-matching logic for Optionals. + return (Dhall.Map.unorderedFromList [("None", Nothing), ("Some", Just _O')]) + _ -> do let _U'' = quote names _U' - die (MustMergeUnion u _U'') + die (MustMergeUnionOrOptional u _U'') let ysT = Dhall.Map.keysSet yTs' let ysU = Dhall.Map.keysSet yUs' @@ -1307,7 +1314,7 @@ | RecordTypeMismatch Const Const (Expr s a) (Expr s a) | FieldCollision Text | MustMergeARecord (Expr s a) (Expr s a) - | MustMergeUnion (Expr s a) (Expr s a) + | MustMergeUnionOrOptional (Expr s a) (Expr s a) | MustMapARecord (Expr s a) (Expr s a) | InvalidToMapRecordKind (Expr s a) (Expr s a) | HeterogenousRecordToMap (Expr s a) (Expr s a) (Expr s a) @@ -1357,6 +1364,9 @@ where ErrorMessages {..} = prettyTypeMessage msg +{-| Output of `prettyTypeMessage`, containing short- and long-form error + messages +-} data ErrorMessages = ErrorMessages { short :: Doc Ann -- ^ Default succinct 1-line explanation of what went wrong @@ -1370,6 +1380,7 @@ insert :: Pretty a => a -> Doc Ann insert = Dhall.Util.insert +-- | Convert a `TypeMessage` to short- and long-form `ErrorMessages` prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages prettyTypeMessage (UnboundVariable x) = ErrorMessages {..} -- We do not need to print variable name here. For the discussion see: @@ -2969,14 +2980,14 @@ short = "❰merge❱ expects a record of handlers" long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ in let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -2985,10 +2996,10 @@ \For example, the following expression is " <> _NOT <> " valid: \n\ \ \n\ \ \n\ - \ ┌────────────────────────────────────────────────────┐ \n\ - \ │ let handler = λ(x : Bool) → x │ \n\ - \ │ in merge handler (< Foo : Bool >.Foo True) : Bool │ \n\ - \ └────────────────────────────────────────────────────┘ \n\ + \ ┌─────────────────────────────────────────────┐ \n\ + \ │ let handler = λ(x : Bool) → x │ \n\ + \ │ in merge handler (< Foo : Bool >.Foo True) │ \n\ + \ └─────────────────────────────────────────────┘ \n\ \ ⇧ \n\ \ Invalid: ❰handler❱ isn't a record \n\ \ \n\ @@ -3019,40 +3030,50 @@ txt0 = insert expr0 txt1 = insert expr1 -prettyTypeMessage (MustMergeUnion expr0 expr1) = ErrorMessages {..} +prettyTypeMessage (MustMergeUnionOrOptional expr0 expr1) = ErrorMessages {..} where - short = "❰merge❱ expects a union" + short = "❰merge❱ expects a union or an ❰Optional❱" long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ - \... but the second argument to ❰merge❱ must be a union and not some other type. \n\ + \... or this: \n\ \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────┐ \n\ + \ │ let optional = None Bool │ \n\ + \ │ let handlers = { None = False, Some = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers optional │ \n\ + \ └─────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but the second argument to ❰merge❱ must not be some other type. \n\ + \ \n\ \For example, the following expression is " <> _NOT <> " valid: \n\ \ \n\ \ \n\ \ ┌──────────────────────────────────────────┐ \n\ \ │ let handlers = { Foo = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers True : True │ \n\ + \ │ in merge handlers True │ \n\ \ └──────────────────────────────────────────┘ \n\ \ ⇧ \n\ - \ Invalid: ❰True❱ isn't a union \n\ + \ Invalid: ❰True❱ isn't a union or an ❰Optional❱ \n\ \ \n\ \ \n\ \You tried to ❰merge❱ this expression: \n\ \ \n\ \" <> txt0 <> "\n\ \ \n\ - \... which is not a union, but is actually a value of type: \n\ + \... which is not a union or an ❰Optional❱, but is actually a value of type: \n\ \ \n\ \" <> txt1 <> "\n" where @@ -3064,14 +3085,14 @@ short = "Unused handler" long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3087,7 +3108,7 @@ \ │ { Left = Natural/even │ \n\ \ │ , Right = λ(x : Bool) → x │ Invalid: ❰Right❱ handler isn't\n\ \ │ } │ used \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └──────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3107,14 +3128,14 @@ . map Dhall.Pretty.Internal.prettyLabel $ exemplar:xs) long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3129,7 +3150,7 @@ \ ┌──────────────────────────────────────────────────────────────┐ \n\ \ │ let handlers = { Left = Natural/even } │ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └──────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3155,7 +3176,7 @@ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3180,14 +3201,14 @@ <> Dhall.Diff.doc (Dhall.Diff.diffNormalized expr1 expr2) long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3214,7 +3235,7 @@ \ ┌──────────────────────────────────────────────────────────────────┐ \n\ \ │ let handlers = { Left = Natural/even | Right = λ(x : Text) → x } │ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └──────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3240,14 +3261,14 @@ short = "Disallowed handler type" long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3288,8 +3309,8 @@ <> Dhall.Diff.doc (Dhall.Diff.diffNormalized expr1 expr2) long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ @@ -3352,14 +3373,14 @@ <> Dhall.Diff.doc (Dhall.Diff.diffNormalized expr0 expr1) long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3406,14 +3427,14 @@ short = "Handler for "<> Dhall.Pretty.Internal.prettyLabel k <> " is not a function" long = - "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ - \handler per alternative, like this: \n\ + "Explanation: You can ❰merge❱ the alternatives of a union or an ❰Optional❱ using \n\ + \a record with one handler per alternative, like this: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────────────────────────────┐ \n\ \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ - \ │ in merge handlers union : Bool │ \n\ + \ │ in merge handlers union │ \n\ \ └─────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3422,9 +3443,9 @@ \For example, the following expression is " <> _NOT <> " valid: \n\ \ \n\ \ \n\ - \ ┌───────────────────────────────────────────────────────┐ \n\ - \ │ merge { Foo = True } (< Foo : Natural >.Foo 1) : Bool │ \n\ - \ └───────────────────────────────────────────────────────┘ \n\ + \ ┌────────────────────────────────────────────────┐ \n\ + \ │ merge { Foo = True } (< Foo : Natural >.Foo 1) │ \n\ + \ └────────────────────────────────────────────────┘ \n\ \ ⇧ \n\ \ Invalid: Not a function \n\ \ \n\ @@ -4422,8 +4443,8 @@ FieldCollision <$> pure a MustMergeARecord a b -> MustMergeARecord <$> f a <*> f b - MustMergeUnion a b -> - MustMergeUnion <$> f a <*> f b + MustMergeUnionOrOptional a b -> + MustMergeUnionOrOptional <$> f a <*> f b MustMapARecord a b -> MustMapARecord <$> f a <*> f b InvalidToMapRecordKind a b -> diff --git a/tests/Dhall/Test/Dhall.hs b/tests/Dhall/Test/Dhall.hs --- a/tests/Dhall/Test/Dhall.hs +++ b/tests/Dhall/Test/Dhall.hs @@ -92,7 +92,7 @@ case inputEx of Left ex -> assertEqual assertMsg expectedMsg (show ex) - Right _ -> fail "The extraction using a wrong type succeded" + Right _ -> fail "The extraction using a wrong type succeeded" -- https://github.com/dhall-lang/dhall-haskell/issues/915 shouldHandleUnionLiteral :: TestTree @@ -176,13 +176,13 @@ shouldHandleUnionsCorrectly = testGroup "Handle union literals" [ "λ(x : < N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >) → x" - `shouldPassThrough` [ N0 True, N1 5, N2 "ABC" ] + `shouldPassThroughWrapped` [ N0 True, N1 5, N2 "ABC" ] , "λ(x : < E0 | E1 | E2 >) → x" - `shouldPassThrough` [ E0, E1, E2 ] + `shouldPassThroughWrapped` [ E0, E1, E2 ] , "λ(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 } ] + `shouldPassThroughWrapped` [ R0 {}, R1 { a = () }, R2 { x = 1.0 }, R3 { a = (), b = () }, R4 { x = 1.0, y = 2.0 } ] , "λ(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 ] + `shouldPassThroughWrapped` [ P0 , P1 (), P2 1.0, P3 () (), P4 1.0 2.0 ] , "λ(x : < N0 : Bool | N1 : Natural | N2 : Text >) → x" `shouldPassThroughSmart` [ N0 True, N1 5, N2 "ABC" ] @@ -192,12 +192,12 @@ `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 + `shouldMarshalIntoWrapped` N0 True , "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }" - `shouldMarshalInto` N1 5 + `shouldMarshalIntoWrapped` N1 5 , "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }" - `shouldMarshalInto` N2 "ABC" + `shouldMarshalIntoWrapped` N2 "ABC" , "(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True" `shouldMarshalIntoSmart` N0 True @@ -206,20 +206,20 @@ , "(< 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 + , "(< E0 | E1 | E2>).E0" `shouldMarshalIntoWrapped` E0 + , "(< E0 | E1 | E2>).E1" `shouldMarshalIntoWrapped` E1 + , "(< E0 | E1 | E2>).E2" `shouldMarshalIntoWrapped` E2 , "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" - `shouldMarshalInto` R0 + `shouldMarshalIntoWrapped` R0 , "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" - `shouldMarshalInto` R1 { a = () } + `shouldMarshalIntoWrapped` R1 { a = () } , "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0 }" - `shouldMarshalInto` R2 { x = 1.0 } + `shouldMarshalIntoWrapped` R2 { x = 1.0 } , "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" - `shouldMarshalInto` R3 { a = (), b = () } + `shouldMarshalIntoWrapped` R3 { a = (), b = () } , "< 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 } + `shouldMarshalIntoWrapped` R4 { x = 1.0, y = 2.0 } , "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" `shouldMarshalIntoSmart` R0 @@ -233,15 +233,15 @@ `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 + `shouldMarshalIntoWrapped` P0 , "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }" - `shouldMarshalInto` P1 () + `shouldMarshalIntoWrapped` P1 () , "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }" - `shouldMarshalInto` P2 1.0 + `shouldMarshalIntoWrapped` P2 1.0 , "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" - `shouldMarshalInto` P3 () () + `shouldMarshalIntoWrapped` P3 () () , "< 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 + `shouldMarshalIntoWrapped` P4 1.0 2.0 , "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" `shouldMarshalIntoSmart` P0 @@ -255,13 +255,13 @@ `shouldMarshalIntoSmart` P4 1.0 2.0 , N0 True - `shouldEmbedAs` + `shouldEmbedAsWrapped` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }" , N1 5 - `shouldEmbedAs` + `shouldEmbedAsWrapped` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }" , N2 "ABC" - `shouldEmbedAs` + `shouldEmbedAsWrapped` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }" , N0 True @@ -274,15 +274,15 @@ `shouldEmbedAsSmart` "(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\"" - , E0 `shouldEmbedAs` "< E0 | E1 | E2 >.E0" - , E1 `shouldEmbedAs` "< E0 | E1 | E2 >.E1" - , E2 `shouldEmbedAs` "< E0 | E1 | E2 >.E2" + , E0 `shouldEmbedAsWrapped` "< E0 | E1 | E2 >.E0" + , E1 `shouldEmbedAsWrapped` "< E0 | E1 | E2 >.E1" + , E2 `shouldEmbedAsWrapped` "< E0 | E1 | E2 >.E2" - , R0 `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" - , R1 { a = () } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" - , R2 { x = 1.0 } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" - , R3 { a = (), b = () } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" - , R4 { x = 1.0, y = 2.0 } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" + , R0 `shouldEmbedAsWrapped` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" + , R1 { a = () } `shouldEmbedAsWrapped` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" + , R2 { x = 1.0 } `shouldEmbedAsWrapped` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" + , R3 { a = (), b = () } `shouldEmbedAsWrapped` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" + , R4 { x = 1.0, y = 2.0 } `shouldEmbedAsWrapped` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" , R0 `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" , R1 { a = () } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" @@ -290,11 +290,11 @@ , R3 { a = (), b = () } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" , R4 { x = 1.0, y = 2.0 } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" - , P0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" - , P1 () `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }" - , P2 1.0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }" - , P3 () () `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" - , P4 1.0 2.0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" + , P0 `shouldEmbedAsWrapped` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" + , P1 () `shouldEmbedAsWrapped` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }" + , P2 1.0 `shouldEmbedAsWrapped` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }" + , P3 () () `shouldEmbedAsWrapped` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" + , P4 1.0 2.0 `shouldEmbedAsWrapped` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" , P0 `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" , P1 () `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1" @@ -307,9 +307,13 @@ Dhall.defaultInterpretOptions { Dhall.singletonConstructors = Dhall.Smart } - code `shouldPassThrough` values = testCase "Pass through" $ do - f <- Dhall.input Dhall.auto code + wrappedOptions = + Dhall.defaultInterpretOptions + { Dhall.singletonConstructors = Dhall.Wrapped } + code `shouldPassThroughWrapped` values = testCase "Pass through" $ do + f <- Dhall.input (Dhall.autoWith wrappedOptions) code + values @=? map f values code `shouldPassThroughSmart` values = testCase "Pass through" $ do @@ -317,8 +321,8 @@ values @=? map f values - code `shouldMarshalInto` expectedValue = testCase "Marshal" $ do - actualValue <- Dhall.input Dhall.auto code + code `shouldMarshalIntoWrapped` expectedValue = testCase "Marshal" $ do + actualValue <- Dhall.input (Dhall.autoWith wrappedOptions) code expectedValue @=? actualValue @@ -327,12 +331,12 @@ expectedValue @=? actualValue - value `shouldEmbedAs` expectedCode = testCase "ToDhall" $ do + value `shouldEmbedAsWrapped` expectedCode = testCase "ToDhall" $ do parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) resolvedExpression <- Dhall.Import.assertNoImports parsedExpression - Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value + Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.injectWith wrappedOptions) value value `shouldEmbedAsSmart` expectedCode = testCase "ToDhall" $ do parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -11,6 +11,7 @@ import Turtle (FilePath, ()) import qualified Control.Exception as Exception +import qualified Control.Monad as Monad import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO @@ -28,7 +29,21 @@ getTests :: IO TestTree getTests = do - successTests <- Test.Util.discover (Turtle.chars <> "A.dhall") successTest (Turtle.lstree (importDirectory "success")) + let flakyTests = + [ -- This test is flaky, occasionally failing with: + -- + -- Error: Remote host not found + -- + -- URL: https://test.dhall-lang.org/Bool/package.dhall + importDirectory "success/headerForwardingA.dhall" + ] + + successTests <- Test.Util.discover (Turtle.chars <> "A.dhall") successTest (do + path <- Turtle.lstree (importDirectory "success") + + Monad.guard (path `notElem` flakyTests) + + return path ) failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest (Turtle.lstree (importDirectory "failure")) diff --git a/tests/Dhall/Test/Lint.hs b/tests/Dhall/Test/Lint.hs --- a/tests/Dhall/Test/Lint.hs +++ b/tests/Dhall/Test/Lint.hs @@ -4,17 +4,19 @@ import Data.Monoid (mempty, (<>)) import Data.Text (Text) -import Data.Void (Void) -import Dhall.Core (Expr, Import) +import Dhall.Parser (Header(..)) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Prettyprint.Doc as Doc +import qualified Data.Text.Prettyprint.Doc.Render.Text as Doc.Render.Text import qualified Dhall.Core as Core import qualified Dhall.Lint as Lint import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty as Pretty import qualified Dhall.Test.Util as Test.Util import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit @@ -31,6 +33,16 @@ return testTree +format :: Header -> Core.Expr Parser.Src Core.Import -> Text +format (Header header) expr = + let doc = Doc.pretty header + <> Pretty.prettyCharacterSet Pretty.Unicode expr + <> "\n" + + docStream = Pretty.layout doc + in + Doc.Render.Text.renderStrict docStream + lintTest :: Text -> TestTree lintTest prefix = Tasty.HUnit.testCase (Text.unpack prefix) $ do @@ -39,18 +51,14 @@ inputText <- Text.IO.readFile inputFile - parsedInput <- Core.throws (Parser.exprFromText mempty inputText) - - let actualExpression :: Expr Void Import - actualExpression = Core.denote (Lint.lint parsedInput) + (header, parsedInput) <- Core.throws (Parser.exprAndHeaderFromText mempty inputText) - outputText <- Text.IO.readFile outputFile + let actualExpression = Lint.lint parsedInput - parsedOutput <- Core.throws (Parser.exprFromText mempty outputText) + let actualText = format header actualExpression - let expectedExpression :: Expr Void Import - expectedExpression = Core.denote parsedOutput + expectedText <- Text.IO.readFile outputFile let message = "The linted expression did not match the expected output" - Tasty.HUnit.assertEqual message expectedExpression actualExpression + Tasty.HUnit.assertEqual message expectedText actualText diff --git a/tests/Dhall/Test/Main.hs b/tests/Dhall/Test/Main.hs --- a/tests/Dhall/Test/Main.hs +++ b/tests/Dhall/Test/Main.hs @@ -14,6 +14,7 @@ import qualified Dhall.Test.Parser import qualified Dhall.Test.QuickCheck import qualified Dhall.Test.Regression +import qualified Dhall.Test.TH import qualified Dhall.Test.Tutorial import qualified Dhall.Test.TypeInference import qualified GHC.IO.Encoding @@ -57,6 +58,7 @@ , Dhall.Test.Tutorial.tests , Dhall.Test.QuickCheck.tests , Dhall.Test.Dhall.tests + , Dhall.Test.TH.tests ] return testTree diff --git a/tests/Dhall/Test/Parser.hs b/tests/Dhall/Test/Parser.hs --- a/tests/Dhall/Test/Parser.hs +++ b/tests/Dhall/Test/Parser.hs @@ -128,10 +128,6 @@ -- This is a bug created by a parsing performance -- improvement [ parseDirectory "success/unit/MergeParenAnnotation" - - -- https://github.com/dhall-lang/dhall-haskell/issues/1454 - , parseDirectory "success/missingFoo" - , parseDirectory "success/missingSlash" ] let pathString = Text.unpack path diff --git a/tests/Dhall/Test/Regression.hs b/tests/Dhall/Test/Regression.hs --- a/tests/Dhall/Test/Regression.hs +++ b/tests/Dhall/Test/Regression.hs @@ -193,7 +193,7 @@ -- Verify that parsing should not fail -- -- In 267093f8cddf1c2f909f2d997c31fd0a7cb2440a I broke the parser when left - -- factoring the grammer by failing to handle the source tested by this + -- factoring the grammar by failing to handle the source tested by this -- regression test. The root of the problem was that the parser was trying -- to parse `List ./Node` as `Field List "/Node"` instead of -- `App List (Embed (Path (File Homeless "./Node") Code))`. The latter is diff --git a/tests/Dhall/Test/TH.hs b/tests/Dhall/Test/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Dhall/Test/TH.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dhall.Test.TH where + +import Dhall (FromDhall(..)) +import GHC.Generics +import Test.Tasty (TestTree) + +import qualified Dhall +import qualified Dhall.TH +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit + +Dhall.TH.makeHaskellTypeFromUnion "T" "./tests/th/example.dhall" + +deriving instance Eq T +deriving instance Show T +deriving instance Generic T +deriving instance FromDhall T + +tests :: TestTree +tests = Tasty.testGroup "Template Haskell" [ makeHaskellTypeFromUnion ] + +makeHaskellTypeFromUnion :: TestTree +makeHaskellTypeFromUnion = Tasty.HUnit.testCase "makeHaskellTypeFromUnion" $ do + t0 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.A { x = True, y = [ \"ABC\" ] }" + + Tasty.HUnit.assertEqual "" t0 A{ x = True, y = [ "ABC" ] } + + t1 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.B (Some [ 1 ])" + + Tasty.HUnit.assertEqual "" t1 (B (Just [ 1 ])) + + t2 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.C" + + Tasty.HUnit.assertEqual "" t2 C diff --git a/tests/format/applicationMultilineB.dhall b/tests/format/applicationMultilineB.dhall --- a/tests/format/applicationMultilineB.dhall +++ b/tests/format/applicationMultilineB.dhall @@ -12,9 +12,8 @@ b c dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd -, some = - Some - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, some = Some + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa , merge = merge aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/tests/format/ipfsA.dhall b/tests/format/ipfsA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/ipfsA.dhall @@ -0,0 +1,163 @@ +let name = "ipfs" + +let labels = + { `app.kubernetes.io/name` = name + , `app.kubernetes.io/instance` = "wintering-rodent" + , `app.kubernetes.io/version` = "0.4.0" + , `app.kubernetes.io/managed-by` = "dhall" + } + +let matchLabels = + labels.{ `app.kubernetes.io/name`, `app.kubernetes.io/instance` } + +let k8s = + https://raw.githubusercontent.com/dhall-lang/dhall-kubernetes/4ab28225a150498aef67c226d3c5f026c95b5a1e/package.dhall sha256:2c7ac35494f16b1f39afcf3467b2f3b0ab579edb0c711cddd2c93f1cbed358bd + +let serviceName = "ipfs" + +let apiPort = k8s.IntOrString.Int 5001 + +let gatewayPort = k8s.IntOrString.Int 8080 + +let toRule = + λ ( args + : { host : Text + , path : Text + , serviceName : Text + , servicePort : k8s.IntOrString + } + ) + → k8s.IngressRule::{ + , host = Some args.host + , http = + Some + k8s.HTTPIngressRuleValue::{ + , paths = + [ k8s.HTTPIngressPath::{ + , path = Some args.path + , backend = + k8s.IngressBackend::args.{ serviceName, servicePort } + } + ] + } + } + +in [ k8s.Resource.Ingress + k8s.Ingress::{ + , metadata = + k8s.ObjectMeta::{ labels = toMap labels, name = "${name}-api" } + , spec = + Some + k8s.IngressSpec::{ + , rules = + [ toRule + { host = "localhost" + , path = "/" + , serviceName = serviceName + , servicePort = gatewayPort + } + , toRule + { host = "localhost" + , path = "/" + , serviceName = serviceName + , servicePort = apiPort + } + ] + } + } + , k8s.Resource.Service + k8s.Service::{ + , metadata = + k8s.ObjectMeta::{ name = serviceName, labels = toMap labels } + , spec = + Some + k8s.ServiceSpec::{ + , ports = + [ k8s.ServicePort::{ + , port = 5001 + , targetPort = Some apiPort + , name = Some "api" + } + , k8s.ServicePort::{ + , port = 8080 + , targetPort = Some gatewayPort + , name = Some "api" + } + ] + , selector = toMap matchLabels + } + } + , k8s.Resource.StatefulSet + k8s.StatefulSet::{ + , metadata = k8s.ObjectMeta::{ name = name, labels = toMap labels } + , spec = + Some + k8s.StatefulSetSpec::{ + , serviceName = serviceName + , selector = + k8s.LabelSelector::{ matchLabels = toMap matchLabels } + , template = + k8s.PodTemplateSpec::{ + , metadata = + k8s.ObjectMeta::{ name = name, labels = toMap labels } + , spec = + Some + k8s.PodSpec::{ + , securityContext = + Some + k8s.PodSecurityContext::{ + , runAsUser = Some 1000 + , runAsGroup = Some 1000 + , fsGroup = Some 1000 + } + , containers = + [ k8s.Container::{ + , name = name + , image = Some "ipfs/go-ipfs:v0.4.22" + , livenessProbe = + k8s.Probe::{ + , httpGet = + Some + k8s.HTTPGetAction::{ + , path = + Some "/debug/metrics/prometheus" + , port = k8s.IntOrString.String "api" + } + , initialDelaySeconds = Some 15 + , periodSeconds = Some 3 + } + , readinessProbe = + k8s.Probe::{ + , httpGet = + Some + k8s.HTTPGetAction::{ + , path = + Some "/debug/metrics/prometheus" + , port = k8s.IntOrString.String "api" + } + , initialDelaySeconds = Some 15 + , periodSeconds = Some 3 + } + , ports = + [ k8s.ContainerPort::{ + , containerPort = 5001 + , name = Some "api" + } + , k8s.ContainerPort::{ + , containerPort = 8080 + , name = Some "gateway" + } + ] + , volumeMounts = + [ k8s.VolumeMount::{ + , name = "ipfs-storage" + , mountPath = "/data/ipfs" + } + ] + } + ] + } + } + } + } + ] diff --git a/tests/format/ipfsB.dhall b/tests/format/ipfsB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/ipfsB.dhall @@ -0,0 +1,143 @@ +let name = "ipfs" + +let labels = + { `app.kubernetes.io/name` = name + , `app.kubernetes.io/instance` = "wintering-rodent" + , `app.kubernetes.io/version` = "0.4.0" + , `app.kubernetes.io/managed-by` = "dhall" + } + +let matchLabels = + labels.{ `app.kubernetes.io/name`, `app.kubernetes.io/instance` } + +let k8s = + https://raw.githubusercontent.com/dhall-lang/dhall-kubernetes/4ab28225a150498aef67c226d3c5f026c95b5a1e/package.dhall sha256:2c7ac35494f16b1f39afcf3467b2f3b0ab579edb0c711cddd2c93f1cbed358bd + +let serviceName = "ipfs" + +let apiPort = k8s.IntOrString.Int 5001 + +let gatewayPort = k8s.IntOrString.Int 8080 + +let toRule = + λ ( args + : { host : Text + , path : Text + , serviceName : Text + , servicePort : k8s.IntOrString + } + ) + → k8s.IngressRule::{ + , host = Some args.host + , http = Some k8s.HTTPIngressRuleValue::{ + , paths = + [ k8s.HTTPIngressPath::{ + , path = Some args.path + , backend = k8s.IngressBackend::args.{ serviceName, servicePort } + } + ] + } + } + +in [ k8s.Resource.Ingress + k8s.Ingress::{ + , metadata = k8s.ObjectMeta::{ + , labels = toMap labels + , name = "${name}-api" + } + , spec = Some k8s.IngressSpec::{ + , rules = + [ toRule + { host = "localhost" + , path = "/" + , serviceName = serviceName + , servicePort = gatewayPort + } + , toRule + { host = "localhost" + , path = "/" + , serviceName = serviceName + , servicePort = apiPort + } + ] + } + } + , k8s.Resource.Service + k8s.Service::{ + , metadata = k8s.ObjectMeta::{ + , name = serviceName + , labels = toMap labels + } + , spec = Some k8s.ServiceSpec::{ + , ports = + [ k8s.ServicePort::{ + , port = 5001 + , targetPort = Some apiPort + , name = Some "api" + } + , k8s.ServicePort::{ + , port = 8080 + , targetPort = Some gatewayPort + , name = Some "api" + } + ] + , selector = toMap matchLabels + } + } + , k8s.Resource.StatefulSet + k8s.StatefulSet::{ + , metadata = k8s.ObjectMeta::{ name = name, labels = toMap labels } + , spec = Some k8s.StatefulSetSpec::{ + , serviceName = serviceName + , selector = k8s.LabelSelector::{ matchLabels = toMap matchLabels } + , template = k8s.PodTemplateSpec::{ + , metadata = k8s.ObjectMeta::{ name = name, labels = toMap labels } + , spec = Some k8s.PodSpec::{ + , securityContext = Some k8s.PodSecurityContext::{ + , runAsUser = Some 1000 + , runAsGroup = Some 1000 + , fsGroup = Some 1000 + } + , containers = + [ k8s.Container::{ + , name = name + , image = Some "ipfs/go-ipfs:v0.4.22" + , livenessProbe = k8s.Probe::{ + , httpGet = Some k8s.HTTPGetAction::{ + , path = Some "/debug/metrics/prometheus" + , port = k8s.IntOrString.String "api" + } + , initialDelaySeconds = Some 15 + , periodSeconds = Some 3 + } + , readinessProbe = k8s.Probe::{ + , httpGet = Some k8s.HTTPGetAction::{ + , path = Some "/debug/metrics/prometheus" + , port = k8s.IntOrString.String "api" + } + , initialDelaySeconds = Some 15 + , periodSeconds = Some 3 + } + , ports = + [ k8s.ContainerPort::{ + , containerPort = 5001 + , name = Some "api" + } + , k8s.ContainerPort::{ + , containerPort = 8080 + , name = Some "gateway" + } + ] + , volumeMounts = + [ k8s.VolumeMount::{ + , name = "ipfs-storage" + , mountPath = "/data/ipfs" + } + ] + } + ] + } + } + } + } + ] diff --git a/tests/format/issue1400-1A.dhall b/tests/format/issue1400-1A.dhall --- a/tests/format/issue1400-1A.dhall +++ b/tests/format/issue1400-1A.dhall @@ -6,7 +6,7 @@ , content = [ text '' - any line going past the 80 characters boundary (e.g. this one is 82) + any line going past the 80 characters boundary (e.g. this one is 82) '' ] } diff --git a/tests/format/issue1400-1B.dhall b/tests/format/issue1400-1B.dhall --- a/tests/format/issue1400-1B.dhall +++ b/tests/format/issue1400-1B.dhall @@ -1,13 +1,13 @@ { conversation = - [ { author = "robert", content = [] } - , { author = "robert", content = [] } - , { author = "bob" - , content = - [ text - '' - any line going past the 80 characters boundary (e.g. this one is 82) - '' - ] - } - ] + [ { author = "robert", content = [] } + , { author = "robert", content = [] } + , { author = "bob" + , content = + [ text + '' + any line going past the 80 characters boundary (e.g. this one is 82) + '' + ] + } + ] } diff --git a/tests/format/largeRecordB.dhall b/tests/format/largeRecordB.dhall --- a/tests/format/largeRecordB.dhall +++ b/tests/format/largeRecordB.dhall @@ -9,22 +9,22 @@ in defaults.Config ⫽ { AUTOCOMPLETE = - [ { enable = True, value = "zap" } - , { enable = False, value = "annotate" } - ] + [ { enable = True, value = "zap" } + , { enable = False, value = "annotate" } + ] , acoustics = Some True , align = Some { enable = True, value = types.Alignment.chaotic } , autodescribe = Some False , autodig = Some False , AUTOPICKUP_EXCEPTION = - [ { pickup = False, name = "chest" } - , { pickup = True, name = "dagger" } - ] + [ { pickup = False, name = "chest" } + , { pickup = True, name = "dagger" } + ] , BIND = - [ { keybinding = "!", command = "loot" } - , { keybinding = "^v", command = "untrap" } - , { keybinding = "M-x", command = "terrain" } - ] + [ { keybinding = "!", command = "loot" } + , { keybinding = "^v", command = "untrap" } + , { keybinding = "M-x", command = "terrain" } + ] , catname = Some "Mirri" , checkpoint = Some True , checkspace = Some True @@ -32,17 +32,16 @@ , cmdassist = Some True , confirm = Some True , dark_room = Some False - , disclose = - Some - ( defaults.Disclose - ⫽ { inventory = Some { prompt = True, default = True } - , attributes = Some { prompt = True, default = False } - , monsters_killed = Some { prompt = False, default = True } - , monsters_genocided = Some { prompt = False, default = False } - , conduct = Some { prompt = False, default = False } - , dungeon_overview = Some { prompt = False, default = False } - } - ) + , disclose = Some + ( defaults.Disclose + ⫽ { inventory = Some { prompt = True, default = True } + , attributes = Some { prompt = True, default = False } + , monsters_killed = Some { prompt = False, default = True } + , monsters_genocided = Some { prompt = False, default = False } + , conduct = Some { prompt = False, default = False } + , dungeon_overview = Some { prompt = False, default = False } + } + ) , dogname = Some "Cujo" , extmenu = Some False , fixinv = Some True @@ -56,11 +55,11 @@ , hilite_status = defaults.HiliteStatus ⫽ { gold = - [ { color = types.Color.yellow - , trigger = Some types.Numeric.always - , attributes = None types.Attributes - } - ] + [ { color = types.Color.yellow + , trigger = Some types.Numeric.always + , attributes = None types.Attributes + } + ] } , hitpointbar = Some True , horsename = Some "Erhir" @@ -72,11 +71,11 @@ , mail = Some True , mention_walls = Some False , menucolors = - [ { regex = "blessed" - , color = Some types.Color.cyan - , attributes = defaults.Attributes ⫽ { bold = Some True } - } - ] + [ { regex = "blessed" + , color = Some types.Color.cyan + , attributes = defaults.Attributes ⫽ { bold = Some True } + } + ] , menustyle = Some types.MenuStyle.traditional , menu_deselect_all = Some "-" , menu_deselect_page = Some "\\" diff --git a/tests/format/recordCompletionB.dhall b/tests/format/recordCompletionB.dhall --- a/tests/format/recordCompletionB.dhall +++ b/tests/format/recordCompletionB.dhall @@ -1,25 +1,24 @@ -{ field0 = - T::{ - , a = 1 - , b = 1 - , c = 1 - , d = 1 - , e = 1 - , f = 1 - , g = 1 - , h = 1 - , i = 1 - , j = 1 - , k = 1 - , l = 1 - , m = 1 - , n = 1 - , o = 1 - , p = 1 - , q = 1 - , r = 1 - , s = 1 - , t = 1 - } +{ field0 = T::{ + , a = 1 + , b = 1 + , c = 1 + , d = 1 + , e = 1 + , f = 1 + , g = 1 + , h = 1 + , i = 1 + , j = 1 + , k = 1 + , l = 1 + , m = 1 + , n = 1 + , o = 1 + , p = 1 + , q = 1 + , r = 1 + , s = 1 + , t = 1 + } , field1 = T::{ a = 1 } } diff --git a/tests/format/significantLeadingSpacesA.dhall b/tests/format/significantLeadingSpacesA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/significantLeadingSpacesA.dhall @@ -0,0 +1,1 @@ +" x\n\n y\n " diff --git a/tests/format/significantLeadingSpacesB.dhall b/tests/format/significantLeadingSpacesB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/significantLeadingSpacesB.dhall @@ -0,0 +1,5 @@ +'' +${" "} x + +${" "} y +${" "}'' diff --git a/tests/format/stringWithNullB.dhall b/tests/format/stringWithNullB.dhall --- a/tests/format/stringWithNullB.dhall +++ b/tests/format/stringWithNullB.dhall @@ -1,3 +1,3 @@ '' ${"\u0000"} $ \ -${" "}☺'' + ☺'' diff --git a/tests/lint/success/fixAssertA.dhall b/tests/lint/success/fixAssertA.dhall --- a/tests/lint/success/fixAssertA.dhall +++ b/tests/lint/success/fixAssertA.dhall @@ -1,1 +1,5 @@ -let example = 1 ≡ 1 in 1 +let example0 = 1 ≡ 1 + +let example1 = let x = 1 in x ≡ 1 + +in 1 diff --git a/tests/lint/success/fixAssertB.dhall b/tests/lint/success/fixAssertB.dhall --- a/tests/lint/success/fixAssertB.dhall +++ b/tests/lint/success/fixAssertB.dhall @@ -1,1 +1,1 @@ -let example = assert : 1 ≡ 1 in 1 +let example0 = assert : 1 ≡ 1 let example1 = let x = 1 in assert : x ≡ 1 in 1 diff --git a/tests/lint/success/issue1586A.dhall b/tests/lint/success/issue1586A.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/issue1586A.dhall @@ -0,0 +1,1 @@ +let {- 1 -} x {- 2 -} : {- 3 -} Natural = {- 4 -} 1 {- 5 -} in x diff --git a/tests/lint/success/issue1586B.dhall b/tests/lint/success/issue1586B.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/issue1586B.dhall @@ -0,0 +1,5 @@ +let {- 1 -} x + {- 2 -} : {- 3 -} Natural + = {- 4 -} 1 + +in x diff --git a/tests/lint/success/multiletB.dhall b/tests/lint/success/multiletB.dhall --- a/tests/lint/success/multiletB.dhall +++ b/tests/lint/success/multiletB.dhall @@ -11,25 +11,26 @@ = λ(Person : Type) → λ(MakePerson : { children : List Person, name : Text } → Person) → MakePerson - { children = + { children = [ MakePerson { children = [] : List Person, name = "Mary" } , MakePerson { children = [] : List Person, name = "Jane" } ] - , name = - "John" - } + , name = "John" + } let everybody : Person → List Text = let concat = http://prelude.dhall-lang.org/List/concat - + in λ(x : Person) → x - (List Text) - ( λ(p : { children : List (List Text), name : Text }) - → [ p.name ] # concat Text p.children - ) + (List Text) + ( λ(p : { children : List (List Text), name : Text }) + → [ p.name ] # concat Text p.children + ) -let result : List Text = everybody example +let result + : List Text + = everybody example in result diff --git a/tests/recursive/expr0.dhall b/tests/recursive/expr0.dhall --- a/tests/recursive/expr0.dhall +++ b/tests/recursive/expr0.dhall @@ -1,20 +1,17 @@ λ(Expr : Type) → let ExprF = - < LitF : - { _1 : Natural } - | AddF : - { _1 : Expr, _2 : Expr } - | MulF : - { _1 : Expr, _2 : Expr } + < LitF : Natural + | AddF : { _1 : Expr, _2 : Expr } + | MulF : { _1 : Expr, _2 : Expr } > - + in λ(Fix : ExprF → Expr) - → let Lit = λ(x : Natural) → Fix (ExprF.LitF { _1 = x }) - + → let Lit = λ(x : Natural) → Fix (ExprF.LitF x) + let Add = λ(x : Expr) → λ(y : Expr) → Fix (ExprF.AddF { _1 = x, _2 = y }) - + let Mul = λ(x : Expr) → λ(y : Expr) → Fix (ExprF.MulF { _1 = x, _2 = y }) - + in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2)) diff --git a/tests/recursive/expr1.dhall b/tests/recursive/expr1.dhall --- a/tests/recursive/expr1.dhall +++ b/tests/recursive/expr1.dhall @@ -1,18 +1,15 @@ λ(a : Type) → let ExprF = - < LitF : - { _1 : Natural } - | AddF : - { _1 : a, _2 : a } - | MulF : - { _1 : a, _2 : a } + < LitF : Natural + | AddF : { _1 : a, _2 : a } + | MulF : { _1 : a, _2 : a } > - + in λ(a : ExprF → a) - → let Lit = λ(x : Natural) → a (ExprF.LitF { _1 = x }) - + → let Lit = λ(x : Natural) → a (ExprF.LitF x) + let Add = λ(x : a@1) → λ(y : a@1) → a (ExprF.AddF { _1 = x, _2 = y }) - + let Mul = λ(x : a@1) → λ(y : a@1) → a (ExprF.MulF { _1 = x, _2 = y }) - + in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2)) diff --git a/tests/th/example.dhall b/tests/th/example.dhall new file mode 100644 --- /dev/null +++ b/tests/th/example.dhall @@ -0,0 +1,1 @@ +< A : { x : Bool, y : List Text } | B : Optional (List Natural) | C >