diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,89 @@ +1.28.0 + +* [Supports version 12.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) +* BREAKING CHANGE: [Add `Integer/{clamp,negate}` built-ins](https://github.com/dhall-lang/dhall-haskell/pull/1486) + * This is a technically breaking change API since this adds a new + constructor to the `Expr` type + * This is also a technically breaking change to the language. See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details +* BREAKING CHANGE: [Remove support for fusion](https://github.com/dhall-lang/dhall-haskell/pull/1478) + * This is also a technically breaking change to the language. See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details +* BREAKING CHANGE: [Parse whitespace more precisely](https://github.com/dhall-lang/dhall-haskell/pull/1483) + * The Haskell implementation now matches the official grammar much more + closely, but as a result will now reject some programs that it used to + accept + * For example, `1:Natural` used to be valid and now is no longer valid as + the standard requires mandatory whitespace after the `:` + * Consult the [standard grammar](https://github.com/dhall-lang/dhall-lang/blob/master/standard/dhall.abnf) if you run into a new parsing error as a result of this change + * This is also a parsing performance regression (specifically for parsing + comments), but should not be noticeable in practice. See [#1512](https://github.com/dhall-lang/dhall-haskell/pull/1512) for more details +* BREAKING CHANGE: Rename `Type` to `Decoder` and `InputType` to `Encoder` [#1483](https://github.com/dhall-lang/dhall-haskell/pull/1485) / [#1489](https://github.com/dhall-lang/dhall-haskell/pull/1489) +* BUG FIX: [Fix `dhall format --check`](https://github.com/dhall-lang/dhall-haskell/pull/1462) + * Before this change `dhall format --check` would fail due to attempting to + read all of standard input in twice +* BUG FIX: [Fix `dhall freeze` to always re-freeze an import](https://github.com/dhall-lang/dhall-haskell/pull/1471) + * Before this fix, `dhall freeze` would not attempt to refreeze an already + frozen import +* [Permit spaces around completion operator](https://github.com/dhall-lang/dhall-haskell/pull/1532) + * See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details +* [Make `missing` referentially transparent](https://github.com/dhall-lang/dhall-haskell/pull/1509) + * `missing` can now be imported transitively via a remote import + * Normally resolving `missing` would still still fail, except for + `missing as Location`, which is now a valid transitive import + * See the [changelog for standard version 12.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v12.0.0) for more details +* [Write cache files atomically](https://github.com/dhall-lang/dhall-haskell/pull/1544) + * This is a resilience improvement so that the cache is not left in a + corrupt state in the event of a power outage or exhausting disk/memory +* [New `Dhall.function` utility](https://github.com/dhall-lang/dhall-haskell/pull/1507) + * This is provides the same functionality as the `Interpret` instance for + `(->)`, except without the use of typeclasses +* [New `dhall haskell-syntax-tree` command](https://github.com/dhall-lang/dhall-haskell/pull/1553) + * This command displays the Haskell syntax tree of an expression + (primarily for debugging purposes) + * Note that this is highly-volatile and subject to change, so don't depend + on this programmatically. We may break the output of this command without + any notice. +* [Add `instance Show Ann`](https://github.com/dhall-lang/dhall-haskell/pull/1567) +* [Move normalization code from `Dhall.Core` to `Dhall.Normalize`](https://github.com/dhall-lang/dhall-haskell/pull/1452) + * Note that this is not a breaking change. The relocated utilities are + still re-exported from `Dhall.Core` +* [Fix `dhall resolve --transitive-dependencies` to list dependencies in "post-order"](https://github.com/dhall-lang/dhall-haskell/pull/1539) +* Performance improvements + * [#1500](https://github.com/dhall-lang/dhall-haskell/pull/1500) + * [#1522](https://github.com/dhall-lang/dhall-haskell/pull/1522) + * [#1568](https://github.com/dhall-lang/dhall-haskell/pull/1568) + * [#1580](https://github.com/dhall-lang/dhall-haskell/pull/1578) +* Fixes and improvements to code formatting + * [#1460](https://github.com/dhall-lang/dhall-haskell/pull/1460) + * [#1466](https://github.com/dhall-lang/dhall-haskell/pull/1466) + * [#1508](https://github.com/dhall-lang/dhall-haskell/pull/1508) + * [#1527](https://github.com/dhall-lang/dhall-haskell/pull/1527) + * [#1422](https://github.com/dhall-lang/dhall-haskell/pull/1422) + * [#1552](https://github.com/dhall-lang/dhall-haskell/pull/1552) + * [#1543](https://github.com/dhall-lang/dhall-haskell/pull/1543) + * [#1554](https://github.com/dhall-lang/dhall-haskell/pull/1554) + * [#1569](https://github.com/dhall-lang/dhall-haskell/pull/1569) +* Fixes and improvements to code linting + * [#1518](https://github.com/dhall-lang/dhall-haskell/pull/1518) + * [#1531](https://github.com/dhall-lang/dhall-haskell/pull/1531) +* Fixes and improvements to error messages + * [#1443](https://github.com/dhall-lang/dhall-haskell/pull/1443) + * [#1448](https://github.com/dhall-lang/dhall-haskell/pull/1448) + * [#1482](https://github.com/dhall-lang/dhall-haskell/pull/1482) + * [#1519](https://github.com/dhall-lang/dhall-haskell/pull/1519) + * [#1556](https://github.com/dhall-lang/dhall-haskell/pull/1556) + * [#1528](https://github.com/dhall-lang/dhall-haskell/pull/1528) +* Fixes and improvements to the parser + * [#1473](https://github.com/dhall-lang/dhall-haskell/pull/1473) + * [#1549](https://github.com/dhall-lang/dhall-haskell/pull/1549) + * [#1563](https://github.com/dhall-lang/dhall-haskell/pull/1563) + * [#1584](https://github.com/dhall-lang/dhall-haskell/pull/1584) +* Fixes and improvements to diffs + * [#1585](https://github.com/dhall-lang/dhall-haskell/pull/1585) +* Fixes and improvements to the REPL + * [#1573](https://github.com/dhall-lang/dhall-haskell/pull/1573) +* Fixes and improvements to documentation + * [#1530](https://github.com/dhall-lang/dhall-haskell/pull/1530) + 1.27.0 * [Supports version 11.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v11.0.0) diff --git a/benchmark/parser/Main.hs b/benchmark/parser/Main.hs --- a/benchmark/parser/Main.hs +++ b/benchmark/parser/Main.hs @@ -6,7 +6,8 @@ import Control.Monad (forM) import Data.Map (Map, foldrWithKey, singleton, unions) import Data.Monoid ((<>)) -import Gauge (defaultMain, bgroup, bench, whnf, nfIO) +import Data.Void (Void) +import Gauge (defaultMain, bgroup, bench, nf, whnf, nfIO) import System.Directory @@ -67,27 +68,25 @@ benchExprFromBytes :: String -> Data.ByteString.Lazy.ByteString -> Gauge.Benchmark -benchExprFromBytes name bytes = bench name (whnf f bytes) +benchExprFromBytes name bytes = bench name (nf f bytes) where f bytes = do - term <- case Codec.Serialise.deserialiseOrFail bytes of - Left _ -> Nothing - Right term -> return term - case Dhall.Binary.decodeExpression term - :: Either Dhall.Binary.DecodingFailure (Dhall.Expr () Dhall.Import) of - Left _ -> Nothing - Right expression -> return expression + case Dhall.Binary.decodeExpression bytes of + Left exception -> error (show exception) + Right expression -> expression :: Dhall.Expr Void Dhall.Import main :: IO () main = do prelude <- loadPreludeFiles issue108Text <- TIO.readFile "benchmark/examples/issue108.dhall" issue108Bytes <- Data.ByteString.Lazy.readFile "benchmark/examples/issue108.dhall.bin" + kubernetesExample <- Data.ByteString.Lazy.readFile "benchmark/examples/kubernetes.dhall.bin" defaultMain [ bgroup "Issue #108" [ benchExprFromText "Text" issue108Text , benchExprFromBytes "Binary" issue108Bytes ] + , benchExprFromBytes "Kubernetes/Binary" kubernetesExample , benchExprFromText "Long variable names" (T.replicate 1000000 "x") , benchExprFromText "Large number of function arguments" (T.replicate 10000 "x ") , benchExprFromText "Long double-quoted strings" ("\"" <> T.replicate 1000000 "x" <> "\"") diff --git a/dhall-lang/Prelude/Integer/abs b/dhall-lang/Prelude/Integer/abs new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/abs @@ -0,0 +1,19 @@ +{- +Returns the absolute value of an `Integer`, i.e. its non-negative value. +-} +let abs + : Integer → Natural + = λ(n : Integer) + → if Natural/isZero (Integer/clamp n) + + then Integer/clamp (Integer/negate n) + + else Integer/clamp n + +let example0 = assert : abs +7 ≡ 7 + +let example2 = assert : abs +0 ≡ 0 + +let example3 = assert : abs -3 ≡ 3 + +in abs diff --git a/dhall-lang/Prelude/Integer/add b/dhall-lang/Prelude/Integer/add new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/add @@ -0,0 +1,26 @@ +{- +`add m n` computes `m + n`. +-} +let Integer/subtract = + ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7 + ? ./subtract + +let add + : Integer → Integer → Integer + = λ(m : Integer) → λ(n : Integer) → Integer/subtract (Integer/negate m) n + +let example0 = assert : add +3 +5 ≡ +8 + +let example1 = assert : add -3 -5 ≡ -8 + +let example2 = assert : add -4 +4 ≡ +0 + +let example3 = assert : add -3 +5 ≡ +2 + +let example4 = assert : add +3 -5 ≡ -2 + +let example5 = assert : add +0 -3 ≡ -3 + +let example6 = assert : add +0 +3 ≡ +3 + +in add diff --git a/dhall-lang/Prelude/Integer/clamp b/dhall-lang/Prelude/Integer/clamp new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/clamp @@ -0,0 +1,14 @@ +{- +Convert an `Integer` to a `Natural` number, with negative numbers becoming zero. +-} +let clamp + : Integer → Natural + = Integer/clamp + +let example0 = assert : clamp +7 ≡ 7 + +let example2 = assert : clamp +0 ≡ 0 + +let example3 = assert : clamp -3 ≡ 0 + +in clamp diff --git a/dhall-lang/Prelude/Integer/equal b/dhall-lang/Prelude/Integer/equal new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/equal @@ -0,0 +1,26 @@ +{- +`equal` checks if two Integers are equal. +-} +let greaterThan = + ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c + ? ./greaterThan + +let Bool/not = + ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 + ? ../Bool/not + +let equal + : Integer → Integer → Bool + = λ(a : Integer) + → λ(b : Integer) + → Bool/not (greaterThan a b) && Bool/not (greaterThan b a) + +let example0 = assert : equal +5 +5 ≡ True + +let example1 = assert : equal +5 +6 ≡ False + +let example2 = assert : equal +5 -5 ≡ False + +let example3 = assert : equal -5 -5 ≡ True + +in equal diff --git a/dhall-lang/Prelude/Integer/greaterThan b/dhall-lang/Prelude/Integer/greaterThan new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/greaterThan @@ -0,0 +1,32 @@ +{- +`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 greaterThan + : Integer → Integer → Bool + = λ(x : Integer) + → λ(y : Integer) + → Bool/not (Natural/isZero (Integer/clamp (Integer/subtract y x))) + +let example0 = assert : greaterThan +5 +6 ≡ False + +let example1 = assert : greaterThan +5 +5 ≡ False + +let example2 = assert : greaterThan +5 +4 ≡ True + +let example3 = assert : greaterThan -5 +8 ≡ False + +let example4 = assert : greaterThan -5 -3 ≡ False + +let example5 = assert : greaterThan -3 -5 ≡ True + +let example6 = assert : greaterThan -3 -3 ≡ False + +in greaterThan diff --git a/dhall-lang/Prelude/Integer/greaterThanEqual b/dhall-lang/Prelude/Integer/greaterThanEqual new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/greaterThanEqual @@ -0,0 +1,30 @@ +{- +`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 greaterThanEqual + : Integer → Integer → Bool + = λ(x : Integer) → λ(y : Integer) → Bool/not (greaterThan y x) + +let example0 = assert : greaterThanEqual +5 +6 ≡ False + +let example1 = assert : greaterThanEqual +5 +5 ≡ True + +let example2 = assert : greaterThanEqual +5 +4 ≡ True + +let example3 = assert : greaterThanEqual -5 +8 ≡ False + +let example4 = assert : greaterThanEqual -5 -3 ≡ False + +let example5 = assert : greaterThanEqual -3 -5 ≡ True + +let example6 = assert : greaterThanEqual -3 -3 ≡ True + +in greaterThanEqual diff --git a/dhall-lang/Prelude/Integer/lessThan b/dhall-lang/Prelude/Integer/lessThan new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/lessThan @@ -0,0 +1,26 @@ +{- +`lessThan` checks if one Integer is less than another. +-} +let greaterThan = + ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c + ? ./greaterThan + +let lessThan + : Integer → Integer → Bool + = λ(x : Integer) → λ(y : Integer) → greaterThan y x + +let example0 = assert : lessThan +5 +6 ≡ True + +let example1 = assert : lessThan +5 +5 ≡ False + +let example2 = assert : lessThan +5 +4 ≡ False + +let example3 = assert : lessThan -5 +8 ≡ True + +let example4 = assert : lessThan -5 -3 ≡ True + +let example5 = assert : lessThan -3 -5 ≡ False + +let example6 = assert : lessThan -3 -3 ≡ False + +in lessThan diff --git a/dhall-lang/Prelude/Integer/lessThanEqual b/dhall-lang/Prelude/Integer/lessThanEqual new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/lessThanEqual @@ -0,0 +1,30 @@ +{- +`lessThanEqual` checks if one Integer is less than or equal to another. +-} +let lessThan = + ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d + ? ./lessThan + +let Bool/not = + ../Bool/not sha256:723df402df24377d8a853afed08d9d69a0a6d86e2e5b2bac8960b0d4756c7dc4 + ? ../Bool/not + +let lessThanEqual + : Integer → Integer → Bool + = λ(x : Integer) → λ(y : Integer) → Bool/not (lessThan y x) + +let example0 = assert : lessThanEqual +5 +6 ≡ True + +let example1 = assert : lessThanEqual +5 +5 ≡ True + +let example2 = assert : lessThanEqual +5 +4 ≡ False + +let example3 = assert : lessThanEqual -5 +8 ≡ True + +let example4 = assert : lessThanEqual -5 -3 ≡ True + +let example5 = assert : lessThanEqual -3 -5 ≡ False + +let example6 = assert : lessThanEqual -3 -3 ≡ True + +in lessThanEqual diff --git a/dhall-lang/Prelude/Integer/multiply b/dhall-lang/Prelude/Integer/multiply new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/multiply @@ -0,0 +1,43 @@ +{- +`multiply m n` computes `m * n`. +-} + +let Integer/abs = + ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 + ? ./abs + +let multiply + : 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) + + in if mNonPos == nNonPos + + then Natural/toInteger (mAbs * nAbs) + + else Integer/negate (Natural/toInteger (mAbs * nAbs)) + +let example0 = assert : multiply +3 +5 ≡ +15 + +let example1 = assert : multiply -3 +5 ≡ -15 + +let example2 = assert : multiply -3 -5 ≡ +15 + +let example3 = assert : multiply +0 +5 ≡ +0 + +let example4 = assert : multiply +5 +0 ≡ +0 + +let example5 = assert : multiply +0 +0 ≡ +0 + +let example6 = assert : multiply +1 +5 ≡ +5 + +let example7 = assert : multiply +3 -1 ≡ -3 + +in multiply diff --git a/dhall-lang/Prelude/Integer/negate b/dhall-lang/Prelude/Integer/negate new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/negate @@ -0,0 +1,14 @@ +{- +Invert the sign of an `Integer`, with zero remaining unchanged. +-} +let negate + : Integer → Integer + = Integer/negate + +let example0 = assert : negate -3 ≡ +3 + +let example2 = assert : negate +7 ≡ -7 + +let example3 = assert : negate +0 ≡ +0 + +in negate 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 @@ -1,7 +1,43 @@ -{ show = +{ abs = + ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 + ? ./abs +, add = + ./add sha256:96f1ae60f958febc911935ac4aa2685394642b116b7bddcec7e1ed201a69ed2c + ? ./add +, clamp = + ./clamp sha256:ea42096cf3e024fadfaf910e0b839005b0ea7514fff11e5a3950a77694d9c5d2 + ? ./clamp +, equal = + ./equal sha256:e4414b9eef4142eed6bb0b52eb6fd0074210b68d210e96dd5161697b0f14426a + ? ./equal +, greaterThan = + ./greaterThan sha256:accaa6b7cbca7ec2ace4a529e5f3bb57679df2b5ad962bde5b7867d9253d4b8c + ? ./greaterThan +, greaterThanEqual = + ./greaterThanEqual sha256:cede1f63b58cb26623148ef741f18e6476ad71d9d541dd54be2b1ec4972a4ad0 + ? ./greaterThanEqual +, lessThan = + ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d + ? ./lessThan +, lessThanEqual = + ./lessThanEqual sha256:a849203a9cd270210588f9db23e02b819117a997df1c8131b6f9a634cb2e5c8d + ? ./lessThanEqual +, multiply = + ./multiply sha256:71b2a720976c70f0cd06baba9c213867b9744e655927dc3857fa92c864c3cf86 + ? ./multiply +, negate = + ./negate sha256:2373c992e1de93634bc6a8781eb073b2a92a70170133e49762a785f3a136df5d + ? ./negate +, show = ./show sha256:ecf8b0594cd5181bc45d3b7ea0d44d3ba9ad5dac6ec17bb8968beb65f4b1baa9 ? ./show +, subtract = + ./subtract sha256:8de76d2e235eec1629750ae62e191f13631b36708bfda0425572d87e5a9a37e7 + ? ./subtract , toDouble = ./toDouble sha256:77bc5d635dc4d952f37cc96f2a681d5ac503b4e8b21fc00055b1946adb5beda7 ? ./toDouble +, toNatural = + ./toNatural sha256:68dabff205ffdb1ca0df3dabc561ce717b7ae6521c9da9eed893b923ae5a0e1c + ? ./toNatural } diff --git a/dhall-lang/Prelude/Integer/subtract b/dhall-lang/Prelude/Integer/subtract new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/subtract @@ -0,0 +1,56 @@ +{- +`subtract m n` computes `n - m`. +-} +let Natural/lessThanEqual = + ../Natural/lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99 + ? ../Natural/lessThanEqual + +let Integer/abs = + ./abs sha256:35212fcbe1e60cb95b033a4a9c6e45befca4a298aa9919915999d09e69ddced1 + ? ./abs + +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) + + let diff = + if mNonPos == nNonPos + + then if Natural/lessThanEqual mAbs nAbs + + then Integer/negate + (Natural/toInteger (Natural/subtract mAbs nAbs)) + + else Natural/toInteger (Natural/subtract nAbs mAbs) + + else Natural/toInteger (mAbs + nAbs) + + in if mNonPos then diff else Integer/negate diff + +let example0 = assert : subtract +3 +5 ≡ +2 + +let example1 = assert : subtract +4 +4 ≡ +0 + +let example2 = assert : subtract +5 +3 ≡ -2 + +let example3 = assert : subtract -3 -5 ≡ -2 + +let example4 = assert : subtract -4 -4 ≡ +0 + +let example5 = assert : subtract -5 -3 ≡ +2 + +let example6 = assert : subtract -3 +5 ≡ +8 + +let example7 = assert : subtract +3 -5 ≡ -8 + +let example8 = assert : subtract +0 -3 ≡ -3 + +in subtract diff --git a/dhall-lang/Prelude/Integer/toNatural b/dhall-lang/Prelude/Integer/toNatural new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Integer/toNatural @@ -0,0 +1,19 @@ +{- +Convert an `Integer` to an `Optional Natural`, with negative numbers becoming `None Natural`. +-} +let Integer/lessThan = + ./lessThan sha256:14cc3bc6ca8757f7c3af338f079fcc18e0c7ee3ed0d20914a9693aec81ae628d + ? ./lessThan + +let toNatural + : Integer → Optional Natural + = λ(n : Integer) + → if Integer/lessThan n +0 then None Natural else Some (Integer/clamp n) + +let example0 = assert : toNatural +7 ≡ Some 7 + +let example2 = assert : toNatural +0 ≡ Some 0 + +let example3 = assert : toNatural -3 ≡ None Natural + +in toNatural diff --git a/dhall-lang/Prelude/JSON/Tagged b/dhall-lang/Prelude/JSON/Tagged --- a/dhall-lang/Prelude/JSON/Tagged +++ b/dhall-lang/Prelude/JSON/Tagged @@ -62,11 +62,8 @@ -} let Tagged : Type → Type - = λ ( a - : Type - ) - → { field : - Text + = λ(a : Type) + → { field : Text , nesting : ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 ? ./Nesting diff --git a/dhall-lang/Prelude/JSON/core.dhall b/dhall-lang/Prelude/JSON/core.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/core.dhall @@ -0,0 +1,44 @@ +{- A record of functions useful for constructing `JSON` values. + + This is only a subset of what `package.dhall` exports. If you are + not writing a JSON prelude function, you should use the + `package.dhall` file instead. + + It is used internally by `render`, `renderYAML` and + `omitNullFields` instead of `package.dhall` to avoid import + cycles. +-} +{ Type = + ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e + ? ./Type +, Tagged = + ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194 + ? ./Tagged +, Nesting = + ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ? ./Nesting +, keyText = + ./keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc + ? ./keyText +, keyValue = + ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c + ? ./keyValue +, string = + ./string sha256:7a8ac435d30a96092d72889f3d48eabf7cba47ecf553fd6bc07a79fdf473e8d2 + ? ./string +, number = + ./number sha256:534745568065ae19d2b0fe1d09eeb071e9717d0f392187eb0bc95f386b018bec + ? ./number +, object = + ./object sha256:a4e047cf157c3971b026b3942a87d474c85950d9b9654f8ebc8631740abf75a9 + ? ./object +, array = + ./array sha256:3a4c06cf135f4c80619e48c0808f6600d19782705bc59ee7c27cfc2e0f097eb7 + ? ./array +, bool = + ./bool sha256:018d29f030b45d642aba6bb81bf2c19a7bf183684612ce7a2c8afd2099783c48 + ? ./bool +, null = + ./null sha256:52c1d45ab2ca54875b444bfb1afdea497c8c9b0652e5044fafd8b16d97f4b78d + ? ./null +} diff --git a/dhall-lang/Prelude/JSON/omitNullFields b/dhall-lang/Prelude/JSON/omitNullFields new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/omitNullFields @@ -0,0 +1,141 @@ +{- +This utility omits all `null` record fields, which is often the idiomatic way +for a configuration to encode absent fields +-} +let JSON = + ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ? ./core.dhall + +let List/concatMap = + ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 + ? ../List/concatMap + +let List/map = + ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + ? ../List/map + +let omitNullFields + : JSON.Type → JSON.Type + = λ(old : JSON.Type) + → λ(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 + } + ) + → let result = + old + { value : JSON, isNull : Bool } + { string = + λ(x : Text) → { value = json.string x, isNull = False } + , number = + λ(x : Double) → { value = json.number x, isNull = False } + , object = + λ ( keyValues + : List + { mapKey : Text + , mapValue : { value : JSON, isNull : Bool } + } + ) + → let value = + json.object + ( List/concatMap + { mapKey : Text + , mapValue : { value : JSON, isNull : Bool } + } + { mapKey : Text, mapValue : JSON } + ( λ ( keyValue + : { mapKey : Text + , mapValue : + { value : JSON, isNull : Bool } + } + ) + → if keyValue.mapValue.isNull + + then [] : List + { mapKey : Text + , mapValue : JSON + } + + else [ keyValue.{ mapKey } + ∧ { mapValue = + keyValue.mapValue.value + } + ] + ) + keyValues + ) + + in { value = value, isNull = False } + , array = + λ(xs : List { value : JSON, isNull : Bool }) + → let value = + json.array + ( List/map + { value : JSON, isNull : Bool } + JSON + ( λ(x : { value : JSON, isNull : Bool }) + → x.value + ) + xs + ) + + in { value = value, isNull = False } + , bool = λ(x : Bool) → { value = json.bool x, isNull = False } + , null = { value = json.null, isNull = True } + } + + in result.value + +let property = + λ(a : Text) + → λ(b : Double) + → λ(c : Bool) + → assert + : omitNullFields + ( JSON.object + ( toMap + { string = JSON.string a + , number = JSON.number b + , bool = JSON.bool c + , null = JSON.null + } + ) + ) + ≡ JSON.object + ( toMap + { string = JSON.string a + , number = JSON.number b + , bool = JSON.bool c + } + ) + +let example = + assert + : omitNullFields + ( JSON.object + ( toMap + { array = + JSON.array [ JSON.object (toMap { null = JSON.null }) ] + } + ) + ) + ≡ JSON.object + ( toMap + { array = + JSON.array + [ JSON.object + ([] : List { mapKey : Text, mapValue : JSON.Type }) + ] + } + ) + +let example = + assert + : omitNullFields (JSON.array [ JSON.null ]) ≡ JSON.array [ JSON.null ] + +in omitNullFields 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,37 +1,19 @@ -{ Type = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e - ? ./Type -, Tagged = - ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194 - ? ./Tagged -, Nesting = - ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 - ? ./Nesting -, keyText = - ./keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc - ? ./keyText -, keyValue = - ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c - ? ./keyValue -, string = - ./string sha256:7a8ac435d30a96092d72889f3d48eabf7cba47ecf553fd6bc07a79fdf473e8d2 - ? ./string -, number = - ./number sha256:534745568065ae19d2b0fe1d09eeb071e9717d0f392187eb0bc95f386b018bec - ? ./number -, object = - ./object sha256:a4e047cf157c3971b026b3942a87d474c85950d9b9654f8ebc8631740abf75a9 - ? ./object -, array = - ./array sha256:3a4c06cf135f4c80619e48c0808f6600d19782705bc59ee7c27cfc2e0f097eb7 - ? ./array -, bool = - ./bool sha256:018d29f030b45d642aba6bb81bf2c19a7bf183684612ce7a2c8afd2099783c48 - ? ./bool -, null = - ./null sha256:52c1d45ab2ca54875b444bfb1afdea497c8c9b0652e5044fafd8b16d97f4b78d - ? ./null -, render = - ./render sha256:81f5a84efbb35211b1556838e86d17ed497912cf765bfa4ab76708b21e5371f1 - ? ./render -} + { render = + ./render sha256:81f5a84efbb35211b1556838e86d17ed497912cf765bfa4ab76708b21e5371f1 + ? ./render + , renderYAML = + ./renderYAML sha256:862b535f6b905f1ce4b83207c58dd53ce5af0026da4c0960a3aec90fdbbb3eb0 + ? ./renderYAML + , omitNullFields = + ./omitNullFields sha256:c28270c553f48c406bd161c61776963315e278af5dae9331c4a320c3f4ecb4ec + ? ./omitNullFields + , tagInline = + ./tagInline sha256:49559ac11906ba6cc9eac25753e31e7addb13bc760df108024174c55523984c4 + ? ./tagInline + , tagNested = + ./tagNested sha256:93a7415853b7677c832246efadc8e880c1b641a23589286a836a384ca311d26f + ? ./tagNested + } +∧ ( ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ? ./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 @@ -2,34 +2,18 @@ This is useful for debugging `JSON` values or for tests. For anything more sophisticated you should use `dhall-to-json` or `dhall-to-yaml` - -``` -let JSON = ./package.dhall - -in JSON.render - ( JSON.array - [ JSON.bool True - , JSON.string "Hello" - , JSON.object - [ { mapKey = "foo", mapValue = JSON.null } - , { mapKey = "bar", mapValue = JSON.number 1.0 } - ] - ] - ) -= "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.0 } ]" -``` -} let JSON = - ./Type sha256:5adb234f5868a5b0eddeb034d690aaba8cb94ea20d0d557003e90334fff6be3e - ? ./Type + ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ? ./core.dhall let Text/concatMapSep = ../Text/concatMapSep sha256:c272aca80a607bc5963d1fcb38819e7e0d3e72ac4d02b1183b1afb6a91340840 ? ../Text/concatMapSep let render - : JSON → Text - = λ(j : JSON) + : JSON.Type → Text + = λ(j : JSON.Type) → j Text { string = λ(x : Text) → Text/show x @@ -44,15 +28,29 @@ → " ${Text/show e.mapKey}: ${e.mapValue}" ) x - + in "{${body} }" , array = λ(x : List Text) → let body = Text/concatMapSep "," Text (λ(y : Text) → " ${y}") x - + in "[${body} ]" , bool = λ(x : Bool) → if x then "true" else "false" , null = "null" } + +let example0 = + assert + : render + ( JSON.array + [ JSON.bool True + , JSON.string "Hello" + , JSON.object + [ { mapKey = "foo", mapValue = JSON.null } + , { mapKey = "bar", mapValue = JSON.number 1.0 } + ] + ] + ) + ≡ "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.0 } ]" in render diff --git a/dhall-lang/Prelude/JSON/renderYAML b/dhall-lang/Prelude/JSON/renderYAML new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/renderYAML @@ -0,0 +1,175 @@ +{- Render a `JSON` value as `Text` in YAML format. + + The generated YAML text will only contain escaped object keys and + string values and might therefore not be very human readable. + + However, it is useful for debugging `JSON` values or for tests. + For anything more sophisticated you should use `dhall-to-json` or + `dhall-to-yaml`. +-} + +let JSON = + ./core.dhall sha256:22ba363a8622642e788ffdd8fb98e5a51b1be8ebfcbefe2853e74932078a60af + ? ./core.dhall + +let Text/concatSep = + ../Text/concatSep sha256:e4401d69918c61b92a4c0288f7d60a6560ca99726138ed8ebc58dca2cd205e58 + ? ../Text/concatSep + +let List/drop = + ../List/drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf + ? ../List/drop + +let List/null = + ../List/null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80 + ? ../List/null + +let List/map = + ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + ? ../List/map + +let List/concatMap = + ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 + ? ../List/concatMap + +let Optional/map = + ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ? ../Optional/map + +let NonEmpty + : Type → Type + = λ(a : Type) → { head : a, tail : List a } + +let uncons + : ∀(a : Type) → List a → Optional (NonEmpty a) + = λ(a : Type) + → λ(ls : List a) + → Optional/map + a + (NonEmpty a) + (λ(head : a) → { head = head, tail = List/drop 1 a ls }) + (List/head a ls) + +let nonEmptyToList + : ∀(a : Type) → NonEmpty a → List a + = λ(a : Type) → λ(nonEmpty : NonEmpty a) → [ nonEmpty.head ] # nonEmpty.tail + +let concatNonEmpty + : ∀(a : Type) → NonEmpty (NonEmpty a) → NonEmpty a + = λ(a : Type) + → λ(lss : NonEmpty (NonEmpty a)) + → { head = lss.head.head + , tail = + lss.head.tail + # List/concatMap (NonEmpty a) a (nonEmptyToList a) lss.tail + } + +let Block + : Type + = NonEmpty Text + +let indentBlockWith + : Text → Text → Block → Block + = λ(headIndent : Text) + → λ(tailIndent : Text) + → λ(block : Block) + → { head = headIndent ++ block.head + , tail = List/map Text Text (λ(t : Text) → tailIndent ++ t) block.tail + } + +let manyBlocks + : Block → List Block → Block + = λ(ifEmpty : Block) + → λ(blocks : List Block) + → Optional/fold + (NonEmpty Block) + (uncons Block blocks) + Block + (concatNonEmpty Text) + ifEmpty + +let singleLine + : Text → Block + = λ(text : Text) → { head = text, tail = [] : List Text } + +let indentKeyedBlock + : Text → Text → Text → Block → Block + = λ(key : Text) + → λ(spacer : Text) + → λ(indentation : Text) + → λ(block : Block) + → if List/null Text block.tail + + then singleLine (key ++ spacer ++ block.head) + + else indentBlockWith + key + indentation + { head = "", tail = nonEmptyToList Text block } + +let blockToText + : Block → Text + = λ(block : Block) → Text/concatSep "\n" (nonEmptyToList Text block) ++ "\n" + +let renderYAML + : JSON.Type → Text + = λ(json : JSON.Type) + → let ObjectField = { mapKey : Text, mapValue : Block } + + in blockToText + ( json + Block + { string = λ(x : Text) → singleLine (Text/show x) + , number = λ(x : Double) → singleLine (Double/show x) + , object = + λ(fields : List ObjectField) + → manyBlocks + (singleLine "{}") + ( List/map + ObjectField + Block + ( λ(e : ObjectField) + → indentKeyedBlock + "! ${Text/show e.mapKey}:" + " " + " " + e.mapValue + ) + fields + ) + , array = + λ(elements : List Block) + → manyBlocks + (singleLine "[]") + ( List/map + Block + Block + (indentBlockWith "- " " ") + elements + ) + , bool = + λ(x : Bool) → singleLine (if x then "true" else "false") + , null = singleLine "null" + } + ) + +let example0 = + assert + : renderYAML + ( JSON.array + [ JSON.bool True + , JSON.string "Hello" + , JSON.object + [ { mapKey = "foo", mapValue = JSON.null } + , { mapKey = "bar", mapValue = JSON.number 1.0 } + ] + ] + ) + ≡ '' + - true + - "Hello" + - ! "foo": null + ! "bar": 1.0 + '' + +in renderYAML diff --git a/dhall-lang/Prelude/JSON/tagInline b/dhall-lang/Prelude/JSON/tagInline new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/tagInline @@ -0,0 +1,28 @@ +{- Prepare a union value for JSON- or YAML-encoding with the inline layout +-} +let Nesting = + ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ? ./Nesting + +let Tagged = + ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194 + ? ./Tagged + +let tagInline + : Text → ∀(a : Type) → a → Tagged a + = λ(tagFieldName : Text) + → λ(a : Type) + → λ(contents : a) + → { nesting = Nesting.Inline, field = tagFieldName, contents = contents } + +let example0 = + let Example = < Left : { foo : Natural } | Right : { bar : Bool } > + + in assert + : tagInline "name" Example (Example.Left { foo = 2 }) + ≡ { field = "name" + , nesting = Nesting.Inline + , contents = Example.Left { foo = 2 } + } + +in tagInline diff --git a/dhall-lang/Prelude/JSON/tagNested b/dhall-lang/Prelude/JSON/tagNested new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/tagNested @@ -0,0 +1,32 @@ +{- Prepare a union value for JSON- or YAML-encoding with the nested layout +-} +let Nesting = + ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ? ./Nesting + +let Tagged = + ./Tagged sha256:21feca7d2b23f210d0696131d792e18a7d24fdcc85d41a49ba85b98670eba194 + ? ./Tagged + +let tagNested + : Text → Text → ∀(a : Type) → a → Tagged a + = λ(contentsFieldName : Text) + → λ(tagFieldName : Text) + → λ(a : Type) + → λ(contents : a) + → { nesting = Nesting.Nested contentsFieldName + , field = tagFieldName + , contents = contents + } + +let example0 = + let Example = < Left : { foo : Natural } | Right : { bar : Bool } > + + in assert + : tagNested "value" "name" Example (Example.Left { foo = 2 }) + ≡ { field = "name" + , nesting = Nesting.Nested "value" + , contents = Example.Left { foo = 2 } + } + +in tagNested diff --git a/dhall-lang/Prelude/List/drop b/dhall-lang/Prelude/List/drop new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/drop @@ -0,0 +1,29 @@ +-- Remove first `n` elements of a list +let Natural/greaterThanEqual = + ../Natural/greaterThanEqual sha256:30ebfab0febd7aa0ccccfdf3dc36ee6d50f0117f35dd4a9b034750b7e885a1a4 + ? ../Natural/greaterThanEqual + +let drop + : ∀(n : Natural) → ∀(a : Type) → List a → List a + = λ(n : Natural) + → λ(a : Type) + → λ(xs : List a) + → List/fold + { index : Natural, value : a } + (List/indexed a xs) + (List a) + ( λ(x : { index : Natural, value : a }) + → λ(xs : List a) + → if Natural/greaterThanEqual x.index n + + then [ x.value ] # xs + + else xs + ) + ([] : List a) + +let example = assert : drop 2 Natural [ 2, 3, 5 ] ≡ [ 5 ] + +let example = assert : drop 5 Natural [ 2, 3, 5 ] ≡ ([] : List Natural) + +in drop diff --git a/dhall-lang/Prelude/List/package.dhall b/dhall-lang/Prelude/List/package.dhall --- a/dhall-lang/Prelude/List/package.dhall +++ b/dhall-lang/Prelude/List/package.dhall @@ -16,6 +16,9 @@ , default = ./default sha256:0ed2a04df6c1d55c08bcdbad82b30980af9ac40d2df7a1628f3663e3e8b4fe01 ? ./default +, drop = + ./drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf + ? ./drop , empty = ./empty sha256:b2f561f35098c457353723c93a22bd5de28d26ecc5370814bef9dfda421e0147 ? ./empty @@ -49,6 +52,9 @@ , null = ./null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80 ? ./null +, partition = + ./partition sha256:38147ac6d750a6492736dd90cc967bf09aa405c499de943c64fab7b86ae02f03 + ? ./partition , replicate = ./replicate sha256:d4250b45278f2d692302489ac3e78280acb238d27541c837ce46911ff3baa347 ? ./replicate @@ -58,6 +64,9 @@ , shifted = ./shifted sha256:54fb22c7e952ebce1cfc0fcdd33ce4cfa817bff9d6564af268dea6685f8b5dfe ? ./shifted +, take = + ./take sha256:b3e08ee8c3a5bf3d8ccee6b2b2008fbb8e51e7373aef6f1af67ad10078c9fbfa + ? ./take , unzip = ./unzip sha256:4d6003e9e683a289fe33f4c90f958eb1e08ea0bbb474210fcd90d1885c9660e9 ? ./unzip diff --git a/dhall-lang/Prelude/List/partition b/dhall-lang/Prelude/List/partition new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/partition @@ -0,0 +1,33 @@ +{- +`partition` divides a `List` of elements into those that satisfy a predicate +and those that do not +-} +let Partition + : Type → Type + = λ(a : Type) → { true : List a, false : List a } + +let partition + : ∀(a : Type) → (a → Bool) → List a → Partition a + = λ(a : Type) + → λ(f : a → Bool) + → λ(xs : List a) + → List/fold + a + xs + (Partition a) + ( λ(x : a) + → λ(p : Partition a) + → if f x + + then { true = [ x ] # p.true, false = p.false } + + else { true = p.true, false = [ x ] # p.false } + ) + { true = [] : List a, false = [] : List a } + +let example0 = + assert + : partition Natural Natural/even [ 0, 1, 2, 3 ] + ≡ { true = [ 0, 2 ], false = [ 1, 3 ] } + +in partition diff --git a/dhall-lang/Prelude/List/shifted b/dhall-lang/Prelude/List/shifted --- a/dhall-lang/Prelude/List/shifted +++ b/dhall-lang/Prelude/List/shifted @@ -22,7 +22,7 @@ → λ(y : { count : Natural, diff : Natural → list }) → let length = List/length { index : Natural, value : a } kvs - + in { count = y.count + length , diff = λ(n : Natural) @@ -38,14 +38,14 @@ { index = kvOld.index + n , value = kvOld.value } - + in cons kvNew z ) (y.diff (n + length)) } ) { count = 0, diff = λ(_ : Natural) → nil } - + in result.diff 0 ) diff --git a/dhall-lang/Prelude/List/take b/dhall-lang/Prelude/List/take new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/take @@ -0,0 +1,25 @@ +-- Truncate a list to the first `n` elements +let Natural/lessThan = + ../Natural/lessThan sha256:3381b66749290769badf8855d8a3f4af62e8de52d1364d838a9d1e20c94fa70c + ? ../Natural/lessThan + +let take + : ∀(n : Natural) → ∀(a : Type) → List a → List a + = λ(n : Natural) + → λ(a : Type) + → λ(xs : List a) + → List/fold + { index : Natural, value : a } + (List/indexed a xs) + (List a) + ( λ(x : { index : Natural, value : a }) + → λ(xs : List a) + → if Natural/lessThan x.index n then [ x.value ] # xs else xs + ) + ([] : List a) + +let example = assert : take 2 Natural [ 2, 3, 5 ] ≡ [ 2, 3 ] + +let example = assert : take 5 Natural [ 2, 3, 5 ] ≡ [ 2, 3, 5 ] + +in take diff --git a/dhall-lang/Prelude/Natural/listMax b/dhall-lang/Prelude/Natural/listMax new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Natural/listMax @@ -0,0 +1,28 @@ +{- +`listMax` returns the largest element of a `List` or `None Natural` if the +`List` is empty +-} +let max = + ./max sha256:1f3b18da330223ab039fad11693da72c7e68d516f50502c73f41a89a097b62f7 + ? ./max + +let Optional/map = + ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ? ../Optional/map + +let listMax + : List Natural → Optional Natural + = λ(xs : List Natural) + → Optional/map + Natural + Natural + (λ(n : Natural) → List/fold Natural xs Natural max n) + (List/head Natural xs) + +let example0 = assert : listMax [ 1, 2 ] ≡ Some 2 + +let example1 = assert : listMax ([] : List Natural) ≡ None Natural + +let property0 = λ(n : Natural) → assert : listMax [ n ] ≡ Some n + +in listMax diff --git a/dhall-lang/Prelude/Natural/listMin b/dhall-lang/Prelude/Natural/listMin new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Natural/listMin @@ -0,0 +1,32 @@ +{- +`listMin` returns the smallest element of a `List` or `None Natural` if the +`List` is empty +-} +let min = + ./min sha256:f25f9c462e4dbf0eb15f9ff6ac840c6e9c82255a7f4f2ab408bdab338e028710 + ? ./min + +let Optional/map = + ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ? ../Optional/map + +let listMin + : List Natural → Optional Natural + = λ(xs : List Natural) + → Optional/map + Natural + Natural + ( λ(n : Natural) + → if Natural/isZero n then n else List/fold Natural xs Natural min n + ) + (List/head Natural xs) + +let example0 = assert : listMin [ 0, 1 ] ≡ Some 0 + +let example1 = assert : listMin ([] : List Natural) ≡ None Natural + +let example2 = assert : listMin [ 3, 2, 1 ] ≡ Some 1 + +let property0 = λ(n : Natural) → assert : listMin [ n ] ≡ Some n + +in listMin diff --git a/dhall-lang/Prelude/Natural/max b/dhall-lang/Prelude/Natural/max new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Natural/max @@ -0,0 +1,20 @@ +{- +`max a b` returns the larger of `a` or `b` +-} +let lessThanEqual = + ./lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99 + ? ./lessThanEqual + +let max + : Natural → Natural → Natural + = λ(a : Natural) → λ(b : Natural) → if lessThanEqual a b then b else a + +let example0 = assert : max 1 2 ≡ 2 + +let example1 = assert : max 2 1 ≡ 2 + +let property0 = λ(n : Natural) → assert : max n n ≡ n + +let property1 = λ(n : Natural) → assert : max 0 n ≡ n + +in max diff --git a/dhall-lang/Prelude/Natural/min b/dhall-lang/Prelude/Natural/min new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Natural/min @@ -0,0 +1,18 @@ +{- +`min a b` returns the smaller of `a` or `b` +-} +let lessThanEqual = + ./lessThanEqual sha256:1a5caa2b80a42b9f58fff58e47ac0d9a9946d0b2d36c54034b8ddfe3cb0f3c99 + ? ./lessThanEqual + +let min + : Natural → Natural → Natural + = λ(a : Natural) → λ(b : Natural) → if lessThanEqual a b then a else b + +let example0 = assert : min 1 2 ≡ 1 + +let example1 = assert : min 2 1 ≡ 1 + +let property0 = λ(n : Natural) → assert : min n n ≡ n + +in min diff --git a/dhall-lang/Prelude/Natural/package.dhall b/dhall-lang/Prelude/Natural/package.dhall --- a/dhall-lang/Prelude/Natural/package.dhall +++ b/dhall-lang/Prelude/Natural/package.dhall @@ -46,6 +46,21 @@ , greaterThan = ./greaterThan sha256:f702abcdfcd7ad73619b9285d7e41c3a1d017fb6b8d037cf40bd93bf30c09b2c ? ./greaterThan +, min = + ./min sha256:f25f9c462e4dbf0eb15f9ff6ac840c6e9c82255a7f4f2ab408bdab338e028710 + ? ./min +, max = + ./max sha256:1f3b18da330223ab039fad11693da72c7e68d516f50502c73f41a89a097b62f7 + ? ./max +, listMin = + ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc + ? ./listMin +, listMax = + ./listMax sha256:30917e8ca230ea6044c6d8ea6e72bcf6f76437aaecc347f790e8a5946c6aa0e5 + ? ./listMax +, sort = + ./sort sha256:ed2eb5a33c5c96ac9227b0b4c77bdbf8911026d721c603ac897ae84b2bfb5dcd + ? ./sort , subtract = ./subtract sha256:b9277ac637d09142a3a3ac79137ef5955c42f8b33b6746d59db2c9d75ccdd745 ? ./subtract diff --git a/dhall-lang/Prelude/Natural/sort b/dhall-lang/Prelude/Natural/sort new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Natural/sort @@ -0,0 +1,60 @@ +{- +`sort` sorts a `List` of `Natural`s in ascending order +-} +let greaterThanEqual = + ./greaterThanEqual sha256:30ebfab0febd7aa0ccccfdf3dc36ee6d50f0117f35dd4a9b034750b7e885a1a4 + ? ./greaterThanEqual + +let listMin = + ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc + ? ./listMin + +let List/partition = + ../List/partition sha256:38147ac6d750a6492736dd90cc967bf09aa405c499de943c64fab7b86ae02f03 + ? ../List/partition + +let Accumulator = { sorted : List Natural, rest : List Natural } + +let partitionMinima = + λ(xs : List Natural) + → Optional/fold + Natural + (listMin xs) + { true : List Natural, false : List Natural } + (λ(m : Natural) → List/partition Natural (greaterThanEqual m) xs) + { true = [] : List Natural, false = [] : List Natural } + +let test0 = + assert + : partitionMinima [ 2, 1, 1, 3 ] ≡ { true = [ 1, 1 ], false = [ 2, 3 ] } + +let step = + λ(x : Accumulator) + → let p = partitionMinima x.rest + + in { sorted = x.sorted # p.true, rest = p.false } + +let test1 = + assert + : step { sorted = [ 1, 1 ], rest = [ 2, 3 ] } + ≡ { sorted = [ 1, 1, 2 ], rest = [ 3 ] } + +let sort + : List Natural → List Natural + = λ(xs : List Natural) + → let x = + Natural/fold + (List/length Natural xs) + Accumulator + step + { sorted = [] : List Natural, rest = xs } + + in x.sorted + +let example0 = assert : sort ([] : List Natural) ≡ ([] : List Natural) + +let example1 = assert : sort [ 1 ] ≡ [ 1 ] + +let example2 = assert : sort [ 3, 2, 1, 3, 2, 1 ] ≡ [ 1, 1, 2, 2, 3, 3 ] + +in sort diff --git a/dhall-lang/Prelude/Text/concatMapSep b/dhall-lang/Prelude/Text/concatMapSep --- a/dhall-lang/Prelude/Text/concatMapSep +++ b/dhall-lang/Prelude/Text/concatMapSep @@ -26,7 +26,7 @@ status ) Status.Empty - + in merge { Empty = "", NonEmpty = λ(result : Text) → result } status let example0 = diff --git a/dhall-lang/Prelude/Text/concatSep b/dhall-lang/Prelude/Text/concatSep --- a/dhall-lang/Prelude/Text/concatSep +++ b/dhall-lang/Prelude/Text/concatSep @@ -23,7 +23,7 @@ status ) Status.Empty - + in merge { Empty = "", NonEmpty = λ(result : Text) → result } status let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI" diff --git a/dhall-lang/Prelude/Text/show b/dhall-lang/Prelude/Text/show --- a/dhall-lang/Prelude/Text/show +++ b/dhall-lang/Prelude/Text/show @@ -9,6 +9,11 @@ let example0 = assert : show "ABC" ≡ "\"ABC\"" let example1 = - assert : show "\u0000 \$ \\ \n ☺" ≡ "\"\\u0000 \\u0024 \\\\ \\n ☺\"" + assert + : show + '' + ${"\u0000"} $ \ + ${" "}☺'' + ≡ "\"\\u0000 \\u0024 \\\\ \\n ☺\"" in show diff --git a/dhall-lang/Prelude/XML/render b/dhall-lang/Prelude/XML/render --- a/dhall-lang/Prelude/XML/render +++ b/dhall-lang/Prelude/XML/render @@ -52,13 +52,13 @@ } ) → let attribs = Text/concatMap Attr renderAttr elem.attributes - + in "<${elem.name}${attribs}" ++ ( if Natural/isZero (List/length Text elem.content) - + then "/>" - + else ">${Text/concat elem.content}" ) } 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 @@ -8,10 +8,10 @@ ./Function/package.dhall sha256:74c3822b98b9d37f9f820af8e1a7ee790bcfac03050eabd45af4a255fb93e026 ? ./Function/package.dhall , Integer = - ./Integer/package.dhall sha256:eb464566d3192dd16ce915a9bd874aaaad612d5c69beb356e5b7d2e0c4949dcf + ./Integer/package.dhall sha256:dbc82e5542a642b9372ce6126967028c0cade2b8ad6923312b086b686ad67e06 ? ./Integer/package.dhall , List = - ./List/package.dhall sha256:88ae09f29981480e62a39c925011b3246d716a80871440f071cf981efea1ad5e + ./List/package.dhall sha256:f0fdab7ab30415c128d89424589c42a15c835338be116fa14484086e4ba118d7 ? ./List/package.dhall , Location = ./Location/package.dhall sha256:0eb4e4a60814018009c720f6820aaa13cf9491eb1b09afb7b832039c6ee4d470 @@ -23,13 +23,13 @@ ./Monoid sha256:26fafa098600ef7a54ef9dba5ada416bbbdd21df1af306c052420c61553ad4af ? ./Monoid , Natural = - ./Natural/package.dhall sha256:4574df29e6bb82fd894c311f6c2ad9a22574756eb62f06d475aa8306d25006fc + ./Natural/package.dhall sha256:e230d4ee318826ab9517ae5d6f38d1a9359d7cff815cc32912cc6b991656bb1a ? ./Natural/package.dhall , Optional = ./Optional/package.dhall sha256:7608f2d38dabee8bfe6865b4adc11289059984220f422d2b023b15b3908f7a4c ? ./Optional/package.dhall , JSON = - ./JSON/package.dhall sha256:0c3c40a63108f2e6ad59f23b789c18eb484d0e9aebc9416c5a4f338c6753084b + ./JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7 ? ./JSON/package.dhall , Text = ./Text/package.dhall sha256:0a0ad9f649aed94c2680491efb384925b5b2bb5b353f1b8a7eb134955c1ffe45 diff --git a/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeA.dhallb b/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeA.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeA.dhallb @@ -0,0 +1,1 @@ +‚ÃIÿÿÿÿÿÿÿÿ diff --git a/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeB.dhall b/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/binary-decode/success/unit/IntegerBigNegativeB.dhall @@ -0,0 +1,2 @@ +{- -2^65 -} +-36893488147419103232 diff --git a/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveA.dhallb b/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveA.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveA.dhallb differ diff --git a/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveB.dhall b/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/binary-decode/success/unit/IntegerBigPositiveB.dhall @@ -0,0 +1,2 @@ +{- 2^65 -} ++36893488147419103232 diff --git a/dhall-lang/tests/binary-decode/success/unit/NaturalBigA.dhallb b/dhall-lang/tests/binary-decode/success/unit/NaturalBigA.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/binary-decode/success/unit/NaturalBigA.dhallb differ diff --git a/dhall-lang/tests/binary-decode/success/unit/NaturalBigB.dhall b/dhall-lang/tests/binary-decode/success/unit/NaturalBigB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/binary-decode/success/unit/NaturalBigB.dhall @@ -0,0 +1,2 @@ +{- 2^65 -} +36893488147419103232 diff --git a/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall b/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall @@ -0,0 +1,9 @@ +{- This test verifies that `missing` is treated as a referentially transparent + import. The following import contains a `missing as Location` in its + test assertion that should succeed since: + + * The `missing` is never actually resolved (due to the `as Location`) + * The `missing` should be treated as referentially transparent (and therefore + be a valid transitive dependency of a remote import) +-} +https://prelude.dhall-lang.org/v11.0.0/Location/Type diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampA.dhall @@ -0,0 +1,1 @@ +Integer/clamp diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampB.dhall @@ -0,0 +1,1 @@ +Integer/clamp diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeA.dhall @@ -0,0 +1,1 @@ +Integer/clamp -6 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampNegativeB.dhall @@ -0,0 +1,1 @@ +0 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveA.dhall @@ -0,0 +1,1 @@ +Integer/clamp +5 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampPositiveB.dhall @@ -0,0 +1,1 @@ +5 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampZeroA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampZeroA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampZeroA.dhall @@ -0,0 +1,1 @@ +Integer/clamp +0 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerClampZeroB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerClampZeroB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerClampZeroB.dhall @@ -0,0 +1,1 @@ +0 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateA.dhall @@ -0,0 +1,1 @@ +Integer/negate diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateB.dhall @@ -0,0 +1,1 @@ +Integer/negate diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeA.dhall @@ -0,0 +1,1 @@ +Integer/negate -7 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateNegativeB.dhall @@ -0,0 +1,1 @@ ++7 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveA.dhall @@ -0,0 +1,1 @@ +Integer/negate +3 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegatePositiveB.dhall @@ -0,0 +1,1 @@ +-3 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroA.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroA.dhall @@ -0,0 +1,1 @@ +Integer/negate +0 diff --git a/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroB.dhall b/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/IntegerNegateZeroB.dhall @@ -0,0 +1,1 @@ ++0 diff --git a/dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall b/dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall --- a/dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall +++ b/dhall-lang/tests/normalization/success/unit/ListBuildFoldFusionB.dhall @@ -1,1 +1,8 @@ -λ(T : Type) → λ(x : List T) → x + λ(T : Type) +→ λ(x : List T) +→ List/fold + T + x + (List T) + (λ(a : T) → λ(`as` : List T) → [ a ] # `as`) + ([] : List T) 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) → x +λ(x : Natural) → Natural/fold x Natural (λ(n : Natural) → n + 1) 0 diff --git a/dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall b/dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall --- a/dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall +++ b/dhall-lang/tests/normalization/success/unit/OptionalBuildFoldFusionB.dhall @@ -1,1 +1,3 @@ -λ(T : Type) → λ(x : Optional T) → x + λ(T : Type) +→ λ(x : Optional T) +→ Optional/fold T x (Optional T) (λ(a : T) → Some a) (None T) diff --git a/dhall-lang/tests/parser/failure/nonCharacterUnbraced.dhall b/dhall-lang/tests/parser/failure/nonCharacterUnbraced.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/failure/nonCharacterUnbraced.dhall @@ -0,0 +1,6 @@ +{- +The parser should reject unicode escape sequences for non-characters +(0xNFFFE-0xNFFFF for each `N` in `{ 0 .. F }), regardless of whether they are +braced or not. +-} +"\uFFFE" diff --git a/dhall-lang/tests/parser/failure/surrogatePairUnbraced.dhall b/dhall-lang/tests/parser/failure/surrogatePairUnbraced.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/failure/surrogatePairUnbraced.dhall @@ -0,0 +1,5 @@ +{- +The parser should reject unicode escape sequences for surrogate pairs +(0xD800-DFFF), regardless of whether they are braced or not. +-} +"\uD800" diff --git a/dhall-lang/tests/parser/success/missingFooA.dhall b/dhall-lang/tests/parser/success/missingFooA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/missingFooA.dhall @@ -0,0 +1,1 @@ +missingFoo diff --git a/dhall-lang/tests/parser/success/missingFooB.dhallb b/dhall-lang/tests/parser/success/missingFooB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/missingFooB.dhallb differ diff --git a/dhall-lang/tests/parser/success/missingInParenthesesA.dhall b/dhall-lang/tests/parser/success/missingInParenthesesA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/missingInParenthesesA.dhall @@ -0,0 +1,1 @@ +(missing) diff --git a/dhall-lang/tests/parser/success/missingInParenthesesB.dhallb b/dhall-lang/tests/parser/success/missingInParenthesesB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/missingInParenthesesB.dhallb differ diff --git a/dhall-lang/tests/parser/success/missingSlashA.dhall b/dhall-lang/tests/parser/success/missingSlashA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/missingSlashA.dhall @@ -0,0 +1,1 @@ +missing/ diff --git a/dhall-lang/tests/parser/success/missingSlashB.dhallb b/dhall-lang/tests/parser/success/missingSlashB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/missingSlashB.dhallb differ diff --git a/dhall-lang/tests/parser/success/preferMissingNoSpacesA.dhall b/dhall-lang/tests/parser/success/preferMissingNoSpacesA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/preferMissingNoSpacesA.dhall @@ -0,0 +1,1 @@ +missing//foo diff --git a/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb b/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/preferMissingNoSpacesB.dhallb differ diff --git a/dhall-lang/tests/parser/success/text/nonAssignedUnicodeA.dhall b/dhall-lang/tests/parser/success/text/nonAssignedUnicodeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/nonAssignedUnicodeA.dhall @@ -0,0 +1,1 @@ +"\u{1FFF0}" diff --git a/dhall-lang/tests/parser/success/text/nonAssignedUnicodeB.dhallb b/dhall-lang/tests/parser/success/text/nonAssignedUnicodeB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/nonAssignedUnicodeB.dhallb @@ -0,0 +1,1 @@ +‚d🿰 diff --git a/dhall-lang/tests/parser/success/unit/CompletionA.dhall b/dhall-lang/tests/parser/success/unit/CompletionA.dhall --- a/dhall-lang/tests/parser/success/unit/CompletionA.dhall +++ b/dhall-lang/tests/parser/success/unit/CompletionA.dhall @@ -1,1 +1,1 @@ -T::r +T :: r 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 @@ -21,7 +21,22 @@ → ∀(x : A) → C } -, Integer : { show : Integer → Text, toDouble : Integer → Double } +, Integer : + { abs : ∀(n : Integer) → Natural + , add : ∀(m : Integer) → ∀(n : Integer) → Integer + , clamp : Integer → Natural + , equal : ∀(a : Integer) → ∀(b : Integer) → Bool + , greaterThan : ∀(x : Integer) → ∀(y : Integer) → Bool + , greaterThanEqual : ∀(x : Integer) → ∀(y : Integer) → Bool + , lessThan : ∀(x : Integer) → ∀(y : Integer) → Bool + , lessThanEqual : ∀(x : Integer) → ∀(y : Integer) → Bool + , multiply : ∀(m : Integer) → ∀(n : Integer) → Integer + , negate : Integer → Integer + , show : Integer → Text + , subtract : ∀(m : Integer) → ∀(n : Integer) → Integer + , toDouble : Integer → Double + , toNatural : ∀(n : Integer) → Optional Natural + } , JSON : { Nesting : Type , Tagged : ∀(a : Type) → Type @@ -129,6 +144,31 @@ } ) → JSON + , omitNullFields : + ∀ ( old + : ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON + ) + → ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON , render : ∀ ( j : ∀(JSON : Type) @@ -144,6 +184,21 @@ → JSON ) → Text + , renderYAML : + ∀ ( json + : ∀(JSON : Type) + → ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) + → JSON + ) + → Text , string : ∀(x : Text) → ∀(JSON : Type) @@ -157,6 +212,17 @@ } ) → JSON + , tagInline : + ∀(tagFieldName : Text) + → ∀(a : Type) + → ∀(contents : a) + → { contents : a, field : Text, nesting : < Inline | Nested : Text > } + , tagNested : + ∀(contentsFieldName : Text) + → ∀(tagFieldName : Text) + → ∀(a : Type) + → ∀(contents : a) + → { contents : a, field : Text, nesting : < Inline | Nested : Text > } } , List : { all : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool @@ -169,6 +235,7 @@ , concatMap : ∀(a : Type) → ∀(b : Type) → ∀(f : a → List b) → ∀(xs : List a) → List b , default : ∀(a : Type) → ∀(o : Optional (List a)) → List a + , drop : ∀(n : Natural) → ∀(a : Type) → ∀(xs : List a) → List a , empty : ∀(a : Type) → List a , filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → List a , fold : @@ -186,12 +253,18 @@ , length : ∀(a : Type) → List a → Natural , map : ∀(a : Type) → ∀(b : Type) → ∀(f : a → b) → ∀(xs : List a) → List b , null : ∀(a : Type) → ∀(xs : List a) → Bool + , partition : + ∀(a : Type) + → ∀(f : a → Bool) + → ∀(xs : List a) + → { false : List a, true : List a } , replicate : ∀(n : Natural) → ∀(a : Type) → ∀(x : a) → List a , reverse : ∀(a : Type) → List a → List a , shifted : ∀(a : Type) → ∀(kvss : List (List { index : Natural, value : a })) → List { index : Natural, value : a } + , take : ∀(n : Natural) → ∀(a : Type) → ∀(xs : List a) → List a , unzip : ∀(a : Type) → ∀(b : Type) @@ -251,9 +324,14 @@ , isZero : Natural → Bool , lessThan : ∀(x : Natural) → ∀(y : Natural) → Bool , lessThanEqual : ∀(x : Natural) → ∀(y : Natural) → Bool + , listMax : ∀(xs : List Natural) → Optional Natural + , listMin : ∀(xs : List Natural) → Optional Natural + , max : ∀(a : Natural) → ∀(b : Natural) → Natural + , min : ∀(a : Natural) → ∀(b : Natural) → Natural , odd : Natural → Bool , product : ∀(xs : List Natural) → Natural , show : Natural → Text + , sort : ∀(xs : List Natural) → List Natural , subtract : Natural → Natural → Natural , sum : ∀(xs : List Natural) → Natural , toDouble : ∀(n : Natural) → Double diff --git a/dhall-lang/tests/type-inference/success/unit/IntegerClampA.dhall b/dhall-lang/tests/type-inference/success/unit/IntegerClampA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/IntegerClampA.dhall @@ -0,0 +1,1 @@ +Integer/clamp diff --git a/dhall-lang/tests/type-inference/success/unit/IntegerClampB.dhall b/dhall-lang/tests/type-inference/success/unit/IntegerClampB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/IntegerClampB.dhall @@ -0,0 +1,1 @@ +Integer → Natural diff --git a/dhall-lang/tests/type-inference/success/unit/IntegerNegateA.dhall b/dhall-lang/tests/type-inference/success/unit/IntegerNegateA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/IntegerNegateA.dhall @@ -0,0 +1,1 @@ +Integer/negate diff --git a/dhall-lang/tests/type-inference/success/unit/IntegerNegateB.dhall b/dhall-lang/tests/type-inference/success/unit/IntegerNegateB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/IntegerNegateB.dhall @@ -0,0 +1,1 @@ +Integer → Integer diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.27.0 +Version: 1.28.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 @@ -40,28 +40,46 @@ dhall-lang/Prelude/Double/show dhall-lang/Prelude/Function/compose dhall-lang/Prelude/Function/package.dhall + dhall-lang/Prelude/Integer/abs + dhall-lang/Prelude/Integer/add + dhall-lang/Prelude/Integer/clamp + dhall-lang/Prelude/Integer/equal + dhall-lang/Prelude/Integer/greaterThan + dhall-lang/Prelude/Integer/greaterThanEqual + dhall-lang/Prelude/Integer/lessThan + dhall-lang/Prelude/Integer/lessThanEqual + dhall-lang/Prelude/Integer/multiply + dhall-lang/Prelude/Integer/negate dhall-lang/Prelude/Integer/package.dhall dhall-lang/Prelude/Integer/show + dhall-lang/Prelude/Integer/subtract dhall-lang/Prelude/Integer/toDouble + dhall-lang/Prelude/Integer/toNatural + dhall-lang/Prelude/JSON/Nesting + dhall-lang/Prelude/JSON/Tagged + dhall-lang/Prelude/JSON/Type dhall-lang/Prelude/JSON/array dhall-lang/Prelude/JSON/bool + dhall-lang/Prelude/JSON/core.dhall dhall-lang/Prelude/JSON/keyText dhall-lang/Prelude/JSON/keyValue - dhall-lang/Prelude/JSON/Nesting 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/renderYAML dhall-lang/Prelude/JSON/string - dhall-lang/Prelude/JSON/Tagged - dhall-lang/Prelude/JSON/Type + dhall-lang/Prelude/JSON/tagInline + dhall-lang/Prelude/JSON/tagNested dhall-lang/Prelude/List/all dhall-lang/Prelude/List/any dhall-lang/Prelude/List/build dhall-lang/Prelude/List/concat dhall-lang/Prelude/List/concatMap dhall-lang/Prelude/List/default + dhall-lang/Prelude/List/drop dhall-lang/Prelude/List/empty dhall-lang/Prelude/List/filter dhall-lang/Prelude/List/fold @@ -74,20 +92,22 @@ dhall-lang/Prelude/List/map dhall-lang/Prelude/List/null dhall-lang/Prelude/List/package.dhall + dhall-lang/Prelude/List/partition dhall-lang/Prelude/List/replicate dhall-lang/Prelude/List/reverse dhall-lang/Prelude/List/shifted + dhall-lang/Prelude/List/take dhall-lang/Prelude/List/unzip - dhall-lang/Prelude/Location/package.dhall dhall-lang/Prelude/Location/Type + dhall-lang/Prelude/Location/package.dhall dhall-lang/Prelude/Map/Entry + dhall-lang/Prelude/Map/Type dhall-lang/Prelude/Map/empty - dhall-lang/Prelude/Map/keys dhall-lang/Prelude/Map/keyText dhall-lang/Prelude/Map/keyValue + dhall-lang/Prelude/Map/keys dhall-lang/Prelude/Map/map dhall-lang/Prelude/Map/package.dhall - dhall-lang/Prelude/Map/Type dhall-lang/Prelude/Map/values dhall-lang/Prelude/Monoid dhall-lang/Prelude/Natural/build @@ -100,10 +120,15 @@ dhall-lang/Prelude/Natural/isZero dhall-lang/Prelude/Natural/lessThan dhall-lang/Prelude/Natural/lessThanEqual + dhall-lang/Prelude/Natural/listMax + dhall-lang/Prelude/Natural/listMin + dhall-lang/Prelude/Natural/max + dhall-lang/Prelude/Natural/min dhall-lang/Prelude/Natural/odd dhall-lang/Prelude/Natural/package.dhall dhall-lang/Prelude/Natural/product dhall-lang/Prelude/Natural/show + dhall-lang/Prelude/Natural/sort dhall-lang/Prelude/Natural/subtract dhall-lang/Prelude/Natural/sum dhall-lang/Prelude/Natural/toDouble @@ -123,7 +148,6 @@ dhall-lang/Prelude/Optional/package.dhall dhall-lang/Prelude/Optional/toList dhall-lang/Prelude/Optional/unzip - dhall-lang/Prelude/package.dhall dhall-lang/Prelude/Text/concat dhall-lang/Prelude/Text/concatMap dhall-lang/Prelude/Text/concatMapSep @@ -132,6 +156,7 @@ dhall-lang/Prelude/Text/defaultMap dhall-lang/Prelude/Text/package.dhall dhall-lang/Prelude/Text/show + dhall-lang/Prelude/XML/Type dhall-lang/Prelude/XML/attribute dhall-lang/Prelude/XML/element dhall-lang/Prelude/XML/emptyAttributes @@ -139,7 +164,7 @@ dhall-lang/Prelude/XML/package.dhall dhall-lang/Prelude/XML/render dhall-lang/Prelude/XML/text - dhall-lang/Prelude/XML/Type + dhall-lang/Prelude/package.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 @@ -396,6 +421,7 @@ aeson >= 1.0.0.0 && < 1.5 , aeson-pretty < 0.9 , ansi-terminal >= 0.6.3.1 && < 0.11, + atomic-write >= 0.2.0.7 && < 0.3 , bytestring < 0.11, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , @@ -411,16 +437,17 @@ exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , haskeline >= 0.7.2.1 && < 0.8 , - hashable >= 1.2 && < 1.3 , + hashable >= 1.2 && < 1.4 , lens-family-core >= 1.0.0 && < 2.1 , - megaparsec >= 6.5.0 && < 7.1 , + megaparsec >= 7 && < 8.1 , memory >= 0.14 && < 0.16, mtl >= 2.2.1 && < 2.3 , network-uri >= 2.6 && < 2.7 , optparse-applicative >= 0.14.0.0 && < 0.16, parsers >= 0.12.4 && < 0.13, - prettyprinter >= 1.2.0.1 && < 1.4 , + prettyprinter >= 1.5.1 && < 1.6 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , + pretty-simple < 4 , profunctors >= 3.1.2 && < 5.6 , repline >= 0.2.1.0 && < 0.3 , serialise >= 0.2.0.0 && < 0.3 , @@ -484,47 +511,49 @@ TemplateHaskell Exposed-Modules: - Dhall, - Dhall.Binary, - Dhall.Context, - Dhall.Core, - Dhall.Crypto, - Dhall.Diff, - Dhall.Tags, - Dhall.Format, - Dhall.Freeze, - Dhall.Import, - Dhall.Lint, - Dhall.Main, - Dhall.Map, - Dhall.Optics, - Dhall.Set, - Dhall.Src, - Dhall.Parser, - Dhall.Parser.Expression, - Dhall.Parser.Token, - Dhall.Pretty, - Dhall.Repl, - Dhall.Tutorial, - Dhall.TypeCheck, + Dhall + Dhall.Binary + Dhall.Context + Dhall.Core + Dhall.Crypto + Dhall.Diff + Dhall.Format + Dhall.Freeze + Dhall.Import + Dhall.Lint + Dhall.Main + Dhall.Map + Dhall.Optics + Dhall.Parser + Dhall.Parser.Expression + Dhall.Parser.Token + Dhall.Pretty + Dhall.Repl + Dhall.Set + Dhall.Src + Dhall.Tags + Dhall.Tutorial + Dhall.TypeCheck Dhall.Util Dhall.Version if !flag(cross) Exposed-Modules: Dhall.TH Other-Modules: - Dhall.Pretty.Internal, - Dhall.Parser.Combinators, - Dhall.URL, - Dhall.Import.Types, - Dhall.Syntax, - Dhall.Eval, + Dhall.Eval + Dhall.Import.Types + Dhall.Normalize + Dhall.Parser.Combinators + Dhall.Pretty.Internal + Dhall.Syntax + Dhall.URL Paths_dhall Autogen-Modules: Paths_dhall if flag(with-http) Other-Modules: Dhall.Import.HTTP + Dhall.Import.Manager GHC-Options: -Wall -fwarn-incomplete-uni-patterns Default-Language: Haskell2010 diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -27,10 +27,17 @@ Test.DocTest.doctest [ "-DWITH_HTTP" , "--fast" + , prefix "ghc-src" + + -- Unfortunately we cannot target the entire @src@ directory. + -- The reason is that src/Dhall/Version.hs depends on + -- the generated Paths_dhall module which is "out-of-scope" + -- when running the testsuite with cabal v1-test. + -- Instead, we target a selection of modules whose combined module + -- dependency tree covers all modules that contain doctests. + + -- , prefix "src" , "-i" <> (prefix "src") - , "-i" <> (prefix "ghc-src") - , prefix "src/Dhall.hs" - , prefix "src/Dhall/Import.hs" - , prefix "src/Dhall/Tutorial.hs" , prefix "src/Dhall/Tags.hs" + , prefix "src/Dhall/Tutorial.hs" ] diff --git a/ghc-src/Dhall/Import/HTTP.hs b/ghc-src/Dhall/Import/HTTP.hs --- a/ghc-src/Dhall/Import/HTTP.hs +++ b/ghc-src/Dhall/Import/HTTP.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Dhall.Import.HTTP where +module Dhall.Import.HTTP + ( fetchFromHttpUrl + ) where import Control.Exception (Exception) import Control.Monad.IO.Class (MonadIO(..)) @@ -169,18 +171,28 @@ <> show e' <> "\n" #endif -newManager :: IO Manager +newManager :: StateT Status IO Manager newManager = do let settings = HTTP.tlsManagerSettings -#ifdef MIN_VERSION_http_client #if MIN_VERSION_http_client(0,5,0) { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds #else { HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds #endif -#endif - HTTP.newManager settings + Status { _manager = oldManager, ..} <- State.get + + case oldManager of + Nothing -> do + manager <- liftIO (HTTP.newManager settings) + + State.put (Status { _manager = Just manager , ..}) + + return manager + + Just manager -> do + return manager + data NotCORSCompliant = NotCORSCompliant { expectedOrigins :: [ByteString] , actualOrigin :: ByteString @@ -260,7 +272,7 @@ fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do - manager <- liftIO $ newManager + manager <- newManager let childURLString = Text.unpack (renderURL childURL) diff --git a/ghc-src/Dhall/Import/Manager.hs b/ghc-src/Dhall/Import/Manager.hs new file mode 100644 --- /dev/null +++ b/ghc-src/Dhall/Import/Manager.hs @@ -0,0 +1,14 @@ +{-| Both the GHC and GHCJS implementations of "Dhall.Import.Manager" export a + `Manager` type suitable for use within the "Dhall.Import" module + + For the GHC implementation the `Manager` type is a real `Manager` from the + @http-client@ package. For the GHCJS implementation the `Manager` type is + a synonym for @`Data.Void.Void`@ since GHCJS does not use a `Manager` for + HTTP requests. +-} +module Dhall.Import.Manager + ( -- * Manager + Manager + ) where + +import Network.HTTP.Client (Manager) diff --git a/ghcjs-src/Dhall/Import/HTTP.hs b/ghcjs-src/Dhall/Import/HTTP.hs --- a/ghcjs-src/Dhall/Import/HTTP.hs +++ b/ghcjs-src/Dhall/Import/HTTP.hs @@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Dhall.Import.HTTP where +module Dhall.Import.HTTP + ( fetchFromHttpUrl + , Manager + ) where import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State.Strict (StateT) @@ -12,9 +15,18 @@ import qualified Data.Text as Text import qualified JavaScript.XHR +import Data.Void (Void) import Dhall.Core (URL(..)) import Dhall.URL (renderURL) import Dhall.Import.Types + +{-| The GHCJS implementation does not require a `Manager` + + The purpose of this synonym is so that "Dhall.Import.Types" can import a + `Manager` type from "Dhall.Import.HTTP" that does the correct thing for + both the GHC and GHCJS implementations +-} +type Manager = Void fetchFromHttpUrl :: URL diff --git a/ghcjs-src/Dhall/Import/Manager.hs b/ghcjs-src/Dhall/Import/Manager.hs new file mode 100644 --- /dev/null +++ b/ghcjs-src/Dhall/Import/Manager.hs @@ -0,0 +1,17 @@ +{-| Both the GHC and GHCJS implementations of "Dhall.Import.Manager" export a + `Manager` type suitable for use within the "Dhall.Import" module + + For the GHC implementation the `Manager` type is a real `Manager` from the + @http-client@ package. For the GHCJS implementation the `Manager` type is + a synonym for @`Data.Void.Void`@ since GHCJS does not use a `Manager` for + HTTP requests. +-} +module Dhall.Import.Manager + ( -- * Manager + Manager + ) where + +import Data.Void (Void) + +-- | GHCJS does not use a `Manager` +type Manager = Void diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -41,14 +41,14 @@ , HasEvaluateSettings , detailed - -- * Types - , Type (..) - , RecordType(..) - , UnionType(..) - , InputType(..) + -- * Decoders + , Decoder (..) + , RecordDecoder(..) + , UnionDecoder(..) + , Encoder(..) , FromDhall(..) , Interpret - , InvalidType(..) + , InvalidDecoder(..) , ExtractErrors(..) , Extractor , MonadicExtractor @@ -72,6 +72,7 @@ , sequence , list , vector + , function , setFromDistinctList , setIgnoringDuplicates , hashSetFromDistinctList @@ -94,14 +95,14 @@ , Inject , inject , genericToDhall - , RecordInputType(..) - , inputFieldWith - , inputField - , inputRecord - , UnionInputType(..) - , inputConstructorWith - , inputConstructor - , inputUnion + , RecordEncoder(..) + , encodeFieldWith + , encodeField + , recordEncoder + , UnionEncoder(..) + , encodeConstructorWith + , encodeConstructor + , unionEncoder , (>|<) -- * Miscellaneous @@ -140,7 +141,7 @@ import Data.Vector (Vector) import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64) -import Dhall.Core (Expr(..), Chunks(..), DhallDouble(..)) +import Dhall.Syntax (Expr(..), Chunks(..), DhallDouble(..)) import Dhall.Import (Imported(..)) import Dhall.Parser (Src(..)) import Dhall.TypeCheck (DetailedTypeError(..), TypeError) @@ -202,7 +203,7 @@ -} typeError :: Expr s a -> Expr s a -> Extractor s a b typeError expected actual = - Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual + Failure . ExtractErrors . pure . TypeMismatch $ InvalidDecoder expected actual -- | Turn a `Text` message into an extraction failure extractError :: Text -> Extractor s a b @@ -240,7 +241,7 @@ a term-level error, described with a freeform text value. -} data ExtractError s a = - TypeMismatch (InvalidType s a) + TypeMismatch (InvalidDecoder s a) | ExtractError Text instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (ExtractError s a) where @@ -256,32 +257,32 @@ instance (Pretty s, Pretty a, Typeable s, Typeable a) => Exception (ExtractError s a) -{-| Every `Type` must obey the contract that if an expression's type matches the +{-| Every `Decoder` must obey the contract that if an expression's type matches the the `expected` type then the `extract` function must not fail with a type error. If not, then this value is returned. - This value indicates that an invalid `Type` was provided to the `input` + This value indicates that an invalid `Decoder` was provided to the `input` function -} -data InvalidType s a = InvalidType - { invalidTypeExpected :: Expr s a - , invalidTypeExpression :: Expr s a +data InvalidDecoder s a = InvalidDecoder + { invalidDecoderExpected :: Expr s a + , invalidDecoderExpression :: Expr s a } deriving (Typeable) -instance (Pretty s, Typeable s, Pretty a, Typeable a) => Exception (InvalidType s a) +instance (Pretty s, Typeable s, Pretty a, Typeable a) => Exception (InvalidDecoder s a) _ERROR :: String _ERROR = "\ESC[1;31mError\ESC[0m" -instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidType s a) where - show InvalidType { .. } = - _ERROR <> ": Invalid Dhall.Type \n\ +instance (Pretty s, Pretty a, Typeable s, Typeable a) => Show (InvalidDecoder s a) where + show InvalidDecoder { .. } = + _ERROR <> ": Invalid Dhall.Decoder \n\ \ \n\ - \Every Type must provide an extract function that succeeds if an expression \n\ - \matches the expected type. You provided a Type that disobeys this contract \n\ + \Every Decoder must provide an extract function that succeeds if an expression \n\ + \matches the expected type. You provided a Decoder that disobeys this contract \n\ \ \n\ - \The Type provided has the expected dhall type: \n\ + \The Decoder provided has the expected dhall type: \n\ \ \n\ \" <> show txt0 <> "\n\ \ \n\ @@ -290,8 +291,8 @@ \" <> show txt1 <> "\n\ \ \n" where - txt0 = Dhall.Util.insert invalidTypeExpected - txt1 = Dhall.Util.insert invalidTypeExpression + txt0 = Dhall.Util.insert invalidDecoderExpected + txt1 = Dhall.Util.insert invalidDecoderExpression -- | @since 1.16 data InputSettings = InputSettings @@ -403,8 +404,8 @@ This uses the settings from 'defaultInputSettings'. -} input - :: Type a - -- ^ The type of value to decode from Dhall to Haskell + :: Decoder a + -- ^ The decoder for the Dhall value -> Text -- ^ The Dhall program -> IO a @@ -420,13 +421,13 @@ -} inputWithSettings :: InputSettings - -> Type a - -- ^ The type of value to decode from Dhall to Haskell + -> Decoder a + -- ^ The decoder for the Dhall value -> Text -- ^ The Dhall program -> IO a -- ^ The decoded value in Haskell -inputWithSettings settings (Type {..}) txt = do +inputWithSettings settings (Decoder {..}) txt = do expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) let InputSettings {..} = settings @@ -464,8 +465,8 @@ @since 1.16 -} inputFile - :: Type a - -- ^ The type of value to decode from Dhall to Haskell + :: Decoder a + -- ^ The decoder for the Dhall value -> FilePath -- ^ The path to the Dhall program. -> IO a @@ -480,8 +481,8 @@ -} inputFileWithSettings :: EvaluateSettings - -> Type a - -- ^ The type of value to decode from Dhall to Haskell + -> Decoder a + -- ^ The decoder for the Dhall value -> FilePath -- ^ The path to the Dhall program. -> IO a @@ -546,13 +547,13 @@ -- a much better user experience. rawInput :: Alternative f - => Type a - -- ^ The type of value to decode from Dhall to Haskell + => Decoder a + -- ^ The decoder for the Dhall value -> Expr s Void -- ^ a closed form Dhall program, which evaluates to the expected type -> f a -- ^ The decoded value in Haskell -rawInput (Type {..}) expr = do +rawInput (Decoder {..}) expr = do case extract (Dhall.Core.normalize expr) of Success x -> pure x Failure _e -> empty @@ -672,24 +673,24 @@ handler1 :: TypeError Src Void -> IO a handler1 e = Control.Exception.throwIO (DetailedTypeError e) -{-| A @(Type a)@ represents a way to marshal a value of type @\'a\'@ from Dhall +{-| A @(Decoder a)@ represents a way to marshal a value of type @\'a\'@ from Dhall into Haskell - You can produce `Type`s either explicitly: + You can produce `Decoder`s either explicitly: -> example :: Type (Vector Text) +> example :: Decoder (Vector Text) > example = vector text ... or implicitly using `auto`: -> example :: Type (Vector Text) +> example :: Decoder (Vector Text) > example = auto - You can consume `Type`s using the `input` function: + You can consume `Decoder`s using the `input` function: -> input :: Type a -> Text -> IO a +> input :: Decoder a -> Text -> IO a -} -data Type a = Type +data Decoder a = Decoder { extract :: Expr Src Void -> Extractor Src Void a -- ^ Extracts Haskell value from the Dhall expression , expected :: Expr Src Void @@ -702,8 +703,8 @@ >>> input bool "True" True -} -bool :: Type Bool -bool = Type {..} +bool :: Decoder Bool +bool = Decoder {..} where extract (BoolLit b) = pure b extract expr = typeError expected expr @@ -715,8 +716,8 @@ >>> input natural "42" 42 -} -natural :: Type Natural -natural = Type {..} +natural :: Decoder Natural +natural = Decoder {..} where extract (NaturalLit n) = pure n extract expr = typeError Natural expr @@ -728,8 +729,8 @@ >>> input integer "+42" 42 -} -integer :: Type Integer -integer = Type {..} +integer :: Decoder Integer +integer = Decoder {..} where extract (IntegerLit n) = pure n extract expr = typeError Integer expr @@ -741,7 +742,7 @@ >>> input scientific "1e100" 1.0e100 -} -scientific :: Type Scientific +scientific :: Decoder Scientific scientific = fmap Data.Scientific.fromFloatDigits double {-| Decode a `Double` @@ -749,8 +750,8 @@ >>> input double "42.0" 42.0 -} -double :: Type Double -double = Type {..} +double :: Decoder Double +double = Decoder {..} where extract (DoubleLit (DhallDouble n)) = pure n extract expr = typeError Double expr @@ -762,7 +763,7 @@ >>> input lazyText "\"Test\"" "Test" -} -lazyText :: Type Data.Text.Lazy.Text +lazyText :: Decoder Data.Text.Lazy.Text lazyText = fmap Data.Text.Lazy.fromStrict strictText {-| Decode strict `Text` @@ -770,8 +771,8 @@ >>> input strictText "\"Test\"" "Test" -} -strictText :: Type Text -strictText = Type {..} +strictText :: Decoder Text +strictText = Decoder {..} where extract (TextLit (Chunks [] t)) = pure t extract expr = typeError Text expr @@ -782,8 +783,8 @@ >>> input (maybe natural) "Some 1" Just 1 -} -maybe :: Type a -> Type (Maybe a) -maybe (Type extractIn expectedIn) = Type extractOut expectedOut +maybe :: Decoder a -> Decoder (Maybe a) +maybe (Decoder extractIn expectedIn) = Decoder extractOut expectedOut where extractOut (Some e ) = fmap Just (extractIn e) extractOut (App None _) = pure Nothing @@ -796,8 +797,8 @@ >>> input (sequence natural) "[1, 2, 3]" fromList [1,2,3] -} -sequence :: Type a -> Type (Seq a) -sequence (Type extractIn expectedIn) = Type extractOut expectedOut +sequence :: Decoder a -> Decoder (Seq a) +sequence (Decoder extractIn expectedIn) = Decoder extractOut expectedOut where extractOut (ListLit _ es) = traverse extractIn es extractOut expr = typeError expectedOut expr @@ -809,7 +810,7 @@ >>> input (list natural) "[1, 2, 3]" [1,2,3] -} -list :: Type a -> Type [a] +list :: Decoder a -> Decoder [a] list = fmap Data.Foldable.toList . sequence {-| Decode a `Vector` @@ -817,9 +818,33 @@ >>> input (vector natural) "[1, 2, 3]" [1,2,3] -} -vector :: Type a -> Type (Vector a) +vector :: Decoder a -> Decoder (Vector a) vector = fmap Data.Vector.fromList . list +{-| Decode a Dhall function into a Haskell function + +>>> f <- input (function defaultInterpretOptions inject bool) "Natural/even" :: IO (Natural -> Bool) +>>> f 0 +True +>>> f 1 +False +-} +function + :: InterpretOptions + -> Encoder a + -> Decoder b + -> Decoder (a -> b) +function options (Encoder {..}) (Decoder extractIn expectedIn) = + Decoder extractOut expectedOut + where + normalizer_ = Just (inputNormalizer options) + + extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of + Success o -> o + Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" ) + + expectedOut = Pi "_" declared expectedIn + {-| Decode a `Set` from a `List` >>> input (setIgnoringDuplicates natural) "[1, 2, 3]" @@ -831,7 +856,7 @@ fromList [1,3] -} -setIgnoringDuplicates :: (Ord a) => Type a -> Type (Data.Set.Set a) +setIgnoringDuplicates :: (Ord a) => Decoder a -> Decoder (Data.Set.Set a) setIgnoringDuplicates = fmap Data.Set.fromList . list {-| Decode a `HashSet` from a `List` @@ -846,8 +871,8 @@ -} hashSetIgnoringDuplicates :: (Hashable a, Ord a) - => Type a - -> Type (Data.HashSet.HashSet a) + => Decoder a + -> Decoder (Data.HashSet.HashSet a) hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list {-| Decode a `Set` from a `List` with distinct elements @@ -876,7 +901,7 @@ > -} -setFromDistinctList :: (Ord a, Show a) => Type a -> Type (Data.Set.Set a) +setFromDistinctList :: (Ord a, Show a) => Decoder a -> Decoder (Data.Set.Set a) setFromDistinctList = setHelper Data.Set.size Data.Set.fromList {-| Decode a `HashSet` from a `List` with distinct elements @@ -906,17 +931,17 @@ -} hashSetFromDistinctList :: (Hashable a, Ord a, Show a) - => Type a - -> Type (Data.HashSet.HashSet a) + => Decoder a + -> Decoder (Data.HashSet.HashSet a) hashSetFromDistinctList = setHelper Data.HashSet.size Data.HashSet.fromList setHelper :: (Eq a, Foldable t, Show a) => (t a -> Int) -> ([a] -> t a) - -> Type a - -> Type (t a) -setHelper size toSet (Type extractIn expectedIn) = Type extractOut expectedOut + -> Decoder a + -> Decoder (t a) +setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut where extractOut (ListLit _ es) = case traverse extractIn es of Success vSeq @@ -954,7 +979,7 @@ fromList [(1,False)] -} -map :: Ord k => Type k -> Type v -> Type (Map k v) +map :: Ord k => Decoder k -> Decoder v -> Decoder (Map k v) map k v = fmap Data.Map.fromList (list (pairFromMapEntry k v)) {-| Decode a `HashMap` from a @toMap@ expression or generally a @Prelude.Map.Type@ @@ -971,7 +996,7 @@ fromList [(1,False)] -} -hashMap :: (Eq k, Hashable k) => Type k -> Type v -> Type (HashMap k v) +hashMap :: (Eq k, Hashable k) => Decoder k -> Decoder v -> Decoder (HashMap k v) hashMap k v = fmap HashMap.fromList (list (pairFromMapEntry k v)) {-| Decode a tuple from a @Prelude.Map.Entry@ record @@ -979,8 +1004,8 @@ >>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }" ("foo",3) -} -pairFromMapEntry :: Type k -> Type v -> Type (k, v) -pairFromMapEntry k v = Type extractOut expectedOut +pairFromMapEntry :: Decoder k -> Decoder v -> Decoder (k, v) +pairFromMapEntry k v = Decoder extractOut expectedOut where extractOut (RecordLit kvs) | Just key <- Dhall.Map.lookup "mapKey" kvs @@ -995,8 +1020,8 @@ >>> input unit "{=}" -- GHC doesn't print the result if it is () -} -unit :: Type () -unit = Type extractOut expectedOut +unit :: Decoder () +unit = Decoder extractOut expectedOut where extractOut (RecordLit fields) | Data.Foldable.null fields = pure () @@ -1008,7 +1033,7 @@ Since @<>@ is uninhabited, @'input' 'void'@ will always fail. -} -void :: Type Void +void :: Decoder Void void = union mempty {-| Decode a `String` @@ -1017,16 +1042,16 @@ "ABC" -} -string :: Type String +string :: Decoder String string = Data.Text.Lazy.unpack <$> lazyText -{-| Given a pair of `Type`s, decode a tuple-record into their pairing. +{-| Given a pair of `Decoder`s, decode a tuple-record into their pairing. >>> input (pair natural bool) "{ _1 = 42, _2 = False }" (42,False) -} -pair :: Type a -> Type b -> Type (a, b) -pair l r = Type extractOut expectedOut +pair :: Decoder a -> Decoder b -> Decoder (a, b) +pair l r = Decoder extractOut expectedOut where extractOut expr@(RecordLit fields) = (,) <$> ( Data.Maybe.maybe (typeError expectedOut expr) (extract l) $ Dhall.Map.lookup "_1" fields) @@ -1054,9 +1079,9 @@ types. -} class FromDhall a where - autoWith:: InterpretOptions -> Type a + autoWith:: InterpretOptions -> Decoder a default autoWith - :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Type a + :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Decoder a autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1) {-| A compatibility alias for `FromDhall` @@ -1126,20 +1151,8 @@ autoWith opts = Dhall.hashMap (autoWith opts) (autoWith opts) instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where - autoWith opts = Type extractOut expectedOut - where - normalizer_ = Just (inputNormalizer opts) - - -- ToDo - extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of - Success o -> o - Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" ) - - expectedOut = Pi "_" declared expectedIn - - InputType {..} = injectWith opts - - Type extractIn expectedIn = autoWith opts + autoWith opts = + function opts (injectWith opts) (autoWith opts) instance (FromDhall a, FromDhall b) => FromDhall (a, b) @@ -1147,7 +1160,7 @@ > auto = autoWith defaultInterpretOptions -} -auto :: FromDhall a => Type a +auto :: FromDhall a => Decoder a auto = autoWith defaultInterpretOptions {-| This type is exactly the same as `Data.Fix.Fix` except with a different @@ -1160,7 +1173,7 @@ resultToFix (Result x) = Fix (fmap resultToFix x) instance FromDhall (f (Result f)) => FromDhall (Result f) where - autoWith options = Type { expected = expected_, extract = extract_ } + autoWith options = Decoder { expected = expected_, extract = extract_ } where expected_ = "result" @@ -1244,11 +1257,11 @@ -- > -- > print (convert x :: Expr) instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where - autoWith options = Type { expected = expected_, extract = extract_ } + autoWith options = Decoder { expected = expected_, extract = extract_ } where expected_ = Pi "result" (Const Dhall.Core.Type) - (Pi "Make" (Pi "_" (expected (autoWith options :: Type (f (Result f)))) "result") + (Pi "Make" (Pi "_" (expected (autoWith options :: Decoder (f (Result f)))) "result") "result" ) @@ -1263,7 +1276,7 @@ having to explicitly provide a `FromDhall` instance for a type as long as the type derives `Generic` -} -genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Type a +genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Decoder a genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1) {-| Use these options to tweak how Dhall derives a generic implementation of @@ -1330,7 +1343,7 @@ for automatically deriving a generic implementation -} class GenericFromDhall f where - genericAutoWith :: InterpretOptions -> State Int (Type (f a)) + genericAutoWith :: InterpretOptions -> State Int (Decoder (f a)) instance GenericFromDhall f => GenericFromDhall (M1 D d f) where genericAutoWith options = do @@ -1338,7 +1351,7 @@ pure (fmap M1 res) instance GenericFromDhall V1 where - genericAutoWith _ = pure Type {..} + genericAutoWith _ = pure Decoder {..} where extract expr = typeError expected expr @@ -1399,7 +1412,7 @@ empty instance (Constructor c1, Constructor c2, GenericFromDhall f1, GenericFromDhall f2) => GenericFromDhall (M1 C c1 f1 :+: M1 C c2 f2) where - genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) + genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) where nL :: M1 i c1 f1 a nL = undefined @@ -1427,11 +1440,11 @@ ] ) - Type extractL expectedL = evalState (genericAutoWith options) 1 - Type extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWith options) 1 + Decoder extractR expectedR = evalState (genericAutoWith options) 1 instance (Constructor c, GenericFromDhall (f :+: g), GenericFromDhall h) => GenericFromDhall ((f :+: g) :+: M1 C c h) where - genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) + genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) where n :: M1 i c h a n = undefined @@ -1448,13 +1461,13 @@ expected = Union (Dhall.Map.insert name (notEmptyRecord expectedR) ktsL) - Type extractL expectedL = evalState (genericAutoWith options) 1 - Type extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWith options) 1 + Decoder extractR expectedR = evalState (genericAutoWith options) 1 ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL instance (Constructor c, GenericFromDhall f, GenericFromDhall (g :+: h)) => GenericFromDhall (M1 C c f :+: (g :+: h)) where - genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) + genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) where n :: M1 i c f a n = undefined @@ -1471,20 +1484,20 @@ expected = Union (Dhall.Map.insert name (notEmptyRecord expectedL) ktsR) - Type extractL expectedL = evalState (genericAutoWith options) 1 - Type extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWith options) 1 + Decoder extractR expectedR = evalState (genericAutoWith options) 1 ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR instance (GenericFromDhall (f :+: g), GenericFromDhall (h :+: i)) => GenericFromDhall ((f :+: g) :+: (h :+: i)) where - genericAutoWith options = pure (Type {..}) + genericAutoWith options = pure (Decoder {..}) where extract e = fmap L1 (extractL e) `ealt` fmap R1 (extractR e) expected = Union (Dhall.Map.union ktsL ktsR) - Type extractL expectedL = evalState (genericAutoWith options) 1 - Type extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWith options) 1 + Decoder extractR expectedR = evalState (genericAutoWith options) 1 ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR @@ -1495,7 +1508,7 @@ pure (fmap M1 res) instance GenericFromDhall U1 where - genericAutoWith _ = pure (Type {..}) + genericAutoWith _ = pure (Decoder {..}) where extract _ = pure U1 @@ -1510,8 +1523,8 @@ instance (GenericFromDhall (f :*: g), GenericFromDhall (h :*: i)) => GenericFromDhall ((f :*: g) :*: (h :*: i)) where genericAutoWith options = do - Type extractL expectedL <- genericAutoWith options - Type extractR expectedR <- genericAutoWith options + Decoder extractL expectedL <- genericAutoWith options + Decoder extractR expectedR <- genericAutoWith options let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR @@ -1521,7 +1534,7 @@ let extract expression = liftA2 (:*:) (extractL expression) (extractR expression) - return (Type {..}) + return (Decoder {..}) instance (GenericFromDhall (f :*: g), Selector s, FromDhall a) => GenericFromDhall ((f :*: g) :*: M1 S s (K1 i a)) where genericAutoWith options@InterpretOptions{..} = do @@ -1530,9 +1543,9 @@ nameR <- fmap fieldModifier (getSelName nR) - Type extractL expectedL <- genericAutoWith options + Decoder extractL expectedL <- genericAutoWith options - let Type extractR expectedR = autoWith options + let Decoder extractR expectedR = autoWith options let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL @@ -1551,7 +1564,7 @@ _ -> die _ -> die - return (Type {..}) + return (Decoder {..}) instance (Selector s, FromDhall a, GenericFromDhall (f :*: g)) => GenericFromDhall (M1 S s (K1 i a) :*: (f :*: g)) where genericAutoWith options@InterpretOptions{..} = do @@ -1560,9 +1573,9 @@ nameL <- fmap fieldModifier (getSelName nL) - let Type extractL expectedL = autoWith options + let Decoder extractL expectedL = autoWith options - Type extractR expectedR <- genericAutoWith options + Decoder extractR expectedR <- genericAutoWith options let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR @@ -1581,7 +1594,7 @@ _ -> die _ -> die - return (Type {..}) + return (Decoder {..}) instance (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where genericAutoWith options@InterpretOptions{..} = do @@ -1594,8 +1607,8 @@ nameL <- fmap fieldModifier (getSelName nL) nameR <- fmap fieldModifier (getSelName nR) - let Type extractL expectedL = autoWith options - let Type extractR expectedR = autoWith options + let Decoder extractL expectedL = autoWith options + let Decoder extractR expectedR = autoWith options let expected = Record @@ -1618,7 +1631,7 @@ Nothing -> die _ -> die - return (Type {..}) + return (Decoder {..}) instance (Selector s, FromDhall a) => GenericFromDhall (M1 S s (K1 i a)) where genericAutoWith options@InterpretOptions{..} = do @@ -1627,7 +1640,7 @@ name <- fmap fieldModifier (getSelName n) - let Type { extract = extract', expected = expected'} = autoWith options + let Decoder { extract = extract', expected = expected'} = autoWith options let expected = case singletonConstructors of @@ -1660,20 +1673,20 @@ Smart | selName n == "" -> extract0 _ -> extract1 - return (Type {..}) + return (Decoder {..}) -{-| An @(InputType a)@ represents a way to marshal a value of type @\'a\'@ from +{-| An @(Encoder a)@ represents a way to marshal a value of type @\'a\'@ from Haskell into Dhall -} -data InputType a = InputType +data Encoder a = Encoder { embed :: a -> Expr Src Void -- ^ Embeds a Haskell value as a Dhall expression , declared :: Expr Src Void -- ^ Dhall type of the Haskell value } -instance Contravariant InputType where - contramap f (InputType embed declared) = InputType embed' declared +instance Contravariant Encoder where + contramap f (Encoder embed declared) = Encoder embed' declared where embed' x = embed (f x) @@ -1692,9 +1705,9 @@ * Marshaling the resulting Dhall expression back into a Haskell value -} class ToDhall a where - injectWith :: InterpretOptions -> InputType a + injectWith :: InterpretOptions -> Encoder a default injectWith - :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputType a + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a injectWith options = contramap GHC.Generics.from (evalState (genericToDhallWith options) 1) @@ -1708,7 +1721,7 @@ > inject = injectWith defaultInterpretOptions -} -inject :: ToDhall a => InputType a +inject :: ToDhall a => Encoder a inject = injectWith defaultInterpretOptions {-| Use the default options for injecting a value, whose structure is @@ -1718,26 +1731,26 @@ want to define orphan instances for. -} genericToDhall - :: (Generic a, GenericToDhall (Rep a)) => InputType a + :: (Generic a, GenericToDhall (Rep a)) => Encoder a genericToDhall = contramap GHC.Generics.from (evalState (genericToDhallWith defaultInterpretOptions) 1) instance ToDhall Void where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = Data.Void.absurd declared = Union mempty instance ToDhall Bool where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = BoolLit declared = Bool instance ToDhall Data.Text.Lazy.Text where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed text = TextLit (Chunks [] (Data.Text.Lazy.toStrict text)) @@ -1745,7 +1758,7 @@ declared = Text instance ToDhall Text where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed text = TextLit (Chunks [] text) @@ -1753,24 +1766,24 @@ instance {-# OVERLAPS #-} ToDhall String where injectWith options = - contramap Data.Text.pack (injectWith options :: InputType Text) + contramap Data.Text.pack (injectWith options :: Encoder Text) instance ToDhall Natural where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit declared = Natural instance ToDhall Integer where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = IntegerLit declared = Integer instance ToDhall Int where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = IntegerLit . toInteger @@ -1783,7 +1796,7 @@ -} instance ToDhall Word where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit . fromIntegral @@ -1796,7 +1809,7 @@ -} instance ToDhall Word8 where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit . fromIntegral @@ -1809,7 +1822,7 @@ -} instance ToDhall Word16 where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit . fromIntegral @@ -1822,7 +1835,7 @@ -} instance ToDhall Word32 where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit . fromIntegral @@ -1835,14 +1848,14 @@ -} instance ToDhall Word64 where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = NaturalLit . fromIntegral declared = Natural instance ToDhall Double where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = DoubleLit . DhallDouble @@ -1850,27 +1863,27 @@ instance ToDhall Scientific where injectWith options = - contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double) + contramap Data.Scientific.toRealFloat (injectWith options :: Encoder Double) instance ToDhall () where - injectWith _ = InputType {..} + injectWith _ = Encoder {..} where embed = const (RecordLit mempty) declared = Record mempty instance ToDhall a => ToDhall (Maybe a) where - injectWith options = InputType embedOut declaredOut + injectWith options = Encoder embedOut declaredOut where embedOut (Just x ) = Some (embedIn x) embedOut Nothing = App None declaredIn - InputType embedIn declaredIn = injectWith options + Encoder embedIn declaredIn = injectWith options declaredOut = App Optional declaredIn instance ToDhall a => ToDhall (Seq a) where - injectWith options = InputType embedOut declaredOut + injectWith options = Encoder embedOut declaredOut where embedOut xs = ListLit listType (fmap embedIn xs) where @@ -1880,7 +1893,7 @@ declaredOut = App List declaredIn - InputType embedIn declaredIn = injectWith options + Encoder embedIn declaredIn = injectWith options instance ToDhall a => ToDhall [a] where injectWith = fmap (contramap Data.Sequence.fromList) injectWith @@ -1920,7 +1933,7 @@ -} instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where - injectWith options = InputType embedOut declaredOut + injectWith options = Encoder embedOut declaredOut where embedOut m = ListLit listType (mapEntries m) where @@ -1935,8 +1948,8 @@ recordPair (k, v) = RecordLit (Dhall.Map.fromList [("mapKey", embedK k), ("mapValue", embedV v)]) - InputType embedK declaredK = injectWith options - InputType embedV declaredV = injectWith options + Encoder embedK declaredK = injectWith options + Encoder embedV declaredV = injectWith options {-| Embed a `Data.HashMap` as a @Prelude.Map.Type@ @@ -1948,7 +1961,7 @@ -} instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where - injectWith options = InputType embedOut declaredOut + injectWith options = Encoder embedOut declaredOut where embedOut m = ListLit listType (mapEntries m) where @@ -1963,14 +1976,14 @@ recordPair (k, v) = RecordLit (Dhall.Map.fromList [("mapKey", embedK k), ("mapValue", embedV v)]) - InputType embedK declaredK = injectWith options - InputType embedV declaredV = injectWith options + Encoder embedK declaredK = injectWith options + Encoder embedV declaredV = injectWith options {-| This is the underlying class that powers the `FromDhall` class's support for automatically deriving a generic implementation -} class GenericToDhall f where - genericToDhallWith :: InterpretOptions -> State Int (InputType (f a)) + genericToDhallWith :: InterpretOptions -> State Int (Encoder (f a)) instance GenericToDhall f => GenericToDhall (M1 D d f) where genericToDhallWith options = do @@ -1984,7 +1997,7 @@ instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where genericToDhallWith options@InterpretOptions{..} = do - let InputType { embed = embed', declared = declared' } = + let Encoder { embed = embed', declared = declared' } = injectWith options let n :: M1 S s (K1 i a) r @@ -2012,10 +2025,10 @@ _ -> Record (Dhall.Map.singleton name declared') - return (InputType {..}) + return (Encoder {..}) instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where - genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) + genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -2048,11 +2061,11 @@ keyL = constructorModifier (Data.Text.pack (conName nL)) keyR = constructorModifier (Data.Text.pack (conName nR)) - InputType embedL declaredL = evalState (genericToDhallWith options) 1 - InputType embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWith options) 1 + Encoder embedR declaredR = evalState (genericToDhallWith options) 1 instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where - genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) + genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 l) = case maybeValL of @@ -2073,13 +2086,13 @@ declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) - InputType embedL declaredL = evalState (genericToDhallWith options) 1 - InputType embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWith options) 1 + Encoder embedR declaredR = evalState (genericToDhallWith options) 1 ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where - genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) + genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -2100,13 +2113,13 @@ declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) - InputType embedL declaredL = evalState (genericToDhallWith options) 1 - InputType embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWith options) 1 + Encoder embedR declaredR = evalState (genericToDhallWith options) 1 ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where - genericToDhallWith options = pure (InputType {..}) + genericToDhallWith options = pure (Encoder {..}) where embed (L1 l) = case maybeValL of @@ -2125,16 +2138,16 @@ declared = Union (Dhall.Map.union ktsL ktsR) - InputType embedL declaredL = evalState (genericToDhallWith options) 1 - InputType embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWith options) 1 + Encoder embedR declaredR = evalState (genericToDhallWith options) 1 ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where genericToDhallWith options = do - InputType embedL declaredL <- genericToDhallWith options - InputType embedR declaredR <- genericToDhallWith options + Encoder embedL declaredL <- genericToDhallWith options + Encoder embedR declaredR <- genericToDhallWith options let embed (l :*: r) = RecordLit (Dhall.Map.union mapL mapR) @@ -2150,7 +2163,7 @@ mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR - pure (InputType {..}) + pure (Encoder {..}) instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where genericToDhallWith options@InterpretOptions{..} = do @@ -2159,9 +2172,9 @@ nameR <- fmap fieldModifier (getSelName nR) - InputType embedL declaredL <- genericToDhallWith options + Encoder embedL declaredL <- genericToDhallWith options - let InputType embedR declaredR = injectWith options + let Encoder embedR declaredR = injectWith options let embed (l :*: M1 (K1 r)) = RecordLit (Dhall.Map.insert nameR (embedR r) mapL) @@ -2173,7 +2186,7 @@ where mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL - return (InputType {..}) + return (Encoder {..}) instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where genericToDhallWith options@InterpretOptions{..} = do @@ -2182,9 +2195,9 @@ nameL <- fmap fieldModifier (getSelName nL) - let InputType embedL declaredL = injectWith options + let Encoder embedL declaredL = injectWith options - InputType embedR declaredR <- genericToDhallWith options + Encoder embedR declaredR <- genericToDhallWith options let embed (M1 (K1 l) :*: r) = RecordLit (Dhall.Map.insert nameL (embedL l) mapR) @@ -2196,7 +2209,7 @@ where mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR - return (InputType {..}) + return (Encoder {..}) instance (Selector s1, Selector s2, ToDhall a1, ToDhall a2) => GenericToDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where genericToDhallWith options@InterpretOptions{..} = do @@ -2209,8 +2222,8 @@ nameL <- fmap fieldModifier (getSelName nL) nameR <- fmap fieldModifier (getSelName nR) - let InputType embedL declaredL = injectWith options - let InputType embedR declaredR = injectWith options + let Encoder embedL declaredL = injectWith options + let Encoder embedR declaredR = injectWith options let embed (M1 (K1 l) :*: M1 (K1 r)) = RecordLit @@ -2224,16 +2237,16 @@ [ (nameL, declaredL), (nameR, declaredR) ] ) - return (InputType {..}) + return (Encoder {..}) instance GenericToDhall U1 where - genericToDhallWith _ = pure (InputType {..}) + genericToDhallWith _ = pure (Encoder {..}) where embed _ = RecordLit mempty declared = Record mempty -{-| The 'RecordType' applicative functor allows you to build a 'Type' parser +{-| The 'RecordDecoder' applicative functor allows you to build a 'Decoder' from a Dhall record. For example, let's take the following Haskell data type: @@ -2257,12 +2270,12 @@ > 289 > } - Our parser has type 'Type' @Project@, but we can't build that out of any - smaller parsers, as 'Type's cannot be combined (they are only 'Functor's). - However, we can use a 'RecordType' to build a 'Type' for @Project@: + Our decoder has type 'Decoder' @Project@, but we can't build that out of any + smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). + However, we can use a 'RecordDecoder' to build a 'Decoder' for @Project@: >>> :{ -project :: Type Project +project :: Decoder Project project = record ( Project <$> field "name" strictText @@ -2272,8 +2285,8 @@ :} -} -newtype RecordType a = - RecordType +newtype RecordDecoder a = + RecordDecoder ( Data.Functor.Product.Product ( Control.Applicative.Const ( Dhall.Map.Map @@ -2290,10 +2303,10 @@ deriving (Functor, Applicative) --- | Run a 'RecordType' parser to build a 'Type' parser. -record :: RecordType a -> Dhall.Type a -record ( RecordType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Data.Functor.Compose.Compose extractF ) ) ) = - Type +-- | Run a 'RecordDecoder' to build a 'Decoder'. +record :: RecordDecoder a -> Dhall.Decoder a +record ( RecordDecoder ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Data.Functor.Compose.Compose extractF ) ) ) = + Decoder { extract = extractF , expected = @@ -2302,27 +2315,26 @@ -- | Parse a single field of a record. -field :: Text -> Type a -> RecordType a -field key valueType@(Type extract expected) = +field :: Text -> Decoder a -> RecordDecoder a +field key valueDecoder@(Decoder extract expected) = let extractBody expr@(RecordLit fields) = case Dhall.Map.lookup key fields of Just v -> extract v _ -> typeError expected expr extractBody expr = typeError expected expr in - RecordType + RecordDecoder ( Data.Functor.Product.Pair ( Control.Applicative.Const ( Dhall.Map.singleton key - ( Dhall.expected valueType ) + ( Dhall.expected valueDecoder ) ) ) ( Data.Functor.Compose.Compose extractBody ) ) -{-| The 'UnionType' monoid allows you to build a 'Type' parser - from a Dhall union +{-| The 'UnionDecoder' monoid allows you to build a 'Decoder' from a Dhall union For example, let's take the following Haskell data type: @@ -2340,12 +2352,12 @@ > | Errored : Text > >.Result "Finish successfully" - Our parser has type 'Type' @Status@, but we can't build that out of any - smaller parsers, as 'Type's cannot be combined (they are only 'Functor's). - However, we can use a 'UnionType' to build a 'Type' for @Status@: + Our decoder has type 'Decoder' @Status@, but we can't build that out of any + smaller decoders, as 'Decoder's cannot be combined (they are only 'Functor's). + However, we can use a 'UnionDecoder' to build a 'Decoder' for @Status@: >>> :{ -status :: Type Status +status :: Decoder Status status = union ( ( Queued <$> constructor "Queued" natural ) <> ( Result <$> constructor "Result" strictText ) @@ -2354,21 +2366,21 @@ :} -} -newtype UnionType a = - UnionType - ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Type a ) +newtype UnionDecoder a = + UnionDecoder + ( Data.Functor.Compose.Compose (Dhall.Map.Map Text) Decoder a ) deriving (Functor) -instance Data.Semigroup.Semigroup (UnionType a) where - (<>) = coerce ((<>) :: Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a) -> Dhall.Map.Map Text (Type a)) +instance Data.Semigroup.Semigroup (UnionDecoder a) where + (<>) = coerce ((<>) :: Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a) -> Dhall.Map.Map Text (Decoder a)) -instance Monoid (UnionType a) where - mempty = coerce (mempty :: Dhall.Map.Map Text (Type a)) +instance Monoid (UnionDecoder a) where + mempty = coerce (mempty :: Dhall.Map.Map Text (Decoder a)) mappend = (Data.Semigroup.<>) --- | Run a 'UnionType' parser to build a 'Type' parser. -union :: UnionType a -> Type a -union (UnionType (Data.Functor.Compose.Compose mp)) = Type +-- | Run a 'UnionDecoder' to build a 'Decoder'. +union :: UnionDecoder a -> Decoder a +union (UnionDecoder (Data.Functor.Compose.Compose mp)) = Decoder { extract = extractF , expected = Union expect } @@ -2387,12 +2399,12 @@ in Data.Maybe.maybe (typeError (Union expect) e0) (uncurry extract) result -- | Parse a single constructor of a union -constructor :: Text -> Type a -> UnionType a -constructor key valueType = UnionType - ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueType) ) +constructor :: Text -> Decoder a -> UnionDecoder a +constructor key valueDecoder = UnionDecoder + ( Data.Functor.Compose.Compose (Dhall.Map.singleton key valueDecoder) ) -{-| The 'RecordInputType' divisible (contravariant) functor allows you to build - an 'InputType' injector for a Dhall record. +{-| The 'RecordEncoder' divisible (contravariant) functor allows you to build + an 'Encoder' for a Dhall record. For example, let's take the following Haskell data type: @@ -2415,17 +2427,17 @@ > 289 > } - Our injector has type 'InputType' @Project@, but we can't build that out of any - smaller injectors, as 'InputType's cannot be combined (they are only 'Contravariant's). - However, we can use an 'InputRecordType' to build an 'InputType' for @Project@: + Our encoder has type 'Encoder' @Project@, but we can't build that out of any + smaller encoders, as 'Encoder's cannot be combined (they are only 'Contravariant's). + However, we can use an 'RecordEncoder' to build an 'Encoder' for @Project@: >>> :{ -injectProject :: InputType Project +injectProject :: Encoder Project injectProject = - inputRecord - ( adapt >$< inputFieldWith "name" inject - >*< inputFieldWith "description" inject - >*< inputFieldWith "stars" inject + recordEncoder + ( adapt >$< encodeFieldWith "name" inject + >*< encodeFieldWith "description" inject + >*< encodeFieldWith "stars" inject ) where adapt (Project{..}) = (projectName, (projectDescription, projectStars)) @@ -2434,12 +2446,12 @@ Or, since we are simply using the `ToDhall` instance to inject each field, we could write >>> :{ -injectProject :: InputType Project +injectProject :: Encoder Project injectProject = - inputRecord - ( adapt >$< inputField "name" - >*< inputField "description" - >*< inputField "stars" + recordEncoder + ( adapt >$< encodeField "name" + >*< encodeField "description" + >*< encodeField "stars" ) where adapt (Project{..}) = (projectName, (projectDescription, projectStars)) @@ -2454,41 +2466,40 @@ infixr 5 >*< -- | Intermediate type used for building a `ToDhall` instance for a record -newtype RecordInputType a - = RecordInputType (Dhall.Map.Map Text (InputType a)) +newtype RecordEncoder a + = RecordEncoder (Dhall.Map.Map Text (Encoder a)) -instance Contravariant RecordInputType where - contramap f (RecordInputType inputTypeRecord) = RecordInputType $ contramap f <$> inputTypeRecord +instance Contravariant RecordEncoder where + contramap f (RecordEncoder encodeTypeRecord) = RecordEncoder $ contramap f <$> encodeTypeRecord -instance Divisible RecordInputType where - divide f (RecordInputType bInputTypeRecord) (RecordInputType cInputTypeRecord) = - RecordInputType +instance Divisible RecordEncoder where + divide f (RecordEncoder bEncoderRecord) (RecordEncoder cEncoderRecord) = + RecordEncoder $ Dhall.Map.union - ((contramap $ fst . f) <$> bInputTypeRecord) - ((contramap $ snd . f) <$> cInputTypeRecord) - conquer = RecordInputType mempty + ((contramap $ fst . f) <$> bEncoderRecord) + ((contramap $ snd . f) <$> cEncoderRecord) + conquer = RecordEncoder mempty {-| Specify how to encode one field of a record by supplying an explicit - `InputType` for that field + `Encoder` for that field -} -inputFieldWith :: Text -> InputType a -> RecordInputType a -inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType +encodeFieldWith :: Text -> Encoder a -> RecordEncoder a +encodeFieldWith name encodeType = RecordEncoder $ Dhall.Map.singleton name encodeType {-| Specify how to encode one field of a record using the default `ToDhall` instance for that type -} -inputField :: ToDhall a => Text -> RecordInputType a -inputField name = inputFieldWith name inject +encodeField :: ToDhall a => Text -> RecordEncoder a +encodeField name = encodeFieldWith name inject --- | Convert a `RecordInputType` into the equivalent `InputType` -inputRecord :: RecordInputType a -> InputType a -inputRecord (RecordInputType inputTypeRecord) = InputType makeRecordLit recordType +-- | Convert a `RecordEncoder` into the equivalent `Encoder` +recordEncoder :: RecordEncoder a -> Encoder a +recordEncoder (RecordEncoder encodeTypeRecord) = Encoder makeRecordLit recordType where - recordType = Record $ declared <$> inputTypeRecord - makeRecordLit x = RecordLit $ (($ x) . embed) <$> inputTypeRecord + recordType = Record $ declared <$> encodeTypeRecord + makeRecordLit x = RecordLit $ (($ x) . embed) <$> encodeTypeRecord -{-| 'UnionInputType' allows you to build an 'InputType' injector for a Dhall - record. +{-| 'UnionEncoder' allows you to build an 'Encoder' for a Dhall record. For example, let's take the following Haskell data type: @@ -2506,16 +2517,16 @@ > | Errored : Text > >.Result "Finish successfully" - Our injector has type 'InputType' @Status@, but we can't build that out of any - smaller injectors, as 'InputType's cannot be combined. - However, we can use an 'UnionInputType' to build an 'InputType' for @Status@: + Our encoder has type 'Encoder' @Status@, but we can't build that out of any + smaller encoders, as 'Encoder's cannot be combined. + However, we can use an 'UnionEncoder' to build an 'Encoder' for @Status@: >>> :{ -injectStatus :: InputType Status -injectStatus = adapt >$< inputUnion - ( inputConstructorWith "Queued" inject - >|< inputConstructorWith "Result" inject - >|< inputConstructorWith "Errored" inject +injectStatus :: Encoder Status +injectStatus = adapt >$< unionEncoder + ( encodeConstructorWith "Queued" inject + >|< encodeConstructorWith "Result" inject + >|< encodeConstructorWith "Errored" inject ) where adapt (Queued n) = Left n @@ -2526,11 +2537,11 @@ Or, since we are simply using the `ToDhall` instance to inject each branch, we could write >>> :{ -injectStatus :: InputType Status -injectStatus = adapt >$< inputUnion - ( inputConstructor "Queued" - >|< inputConstructor "Result" - >|< inputConstructor "Errored" +injectStatus :: Encoder Status +injectStatus = adapt >$< unionEncoder + ( encodeConstructor "Queued" + >|< encodeConstructor "Result" + >|< encodeConstructor "Errored" ) where adapt (Queued n) = Left n @@ -2539,8 +2550,8 @@ :} -} -newtype UnionInputType a = - UnionInputType +newtype UnionEncoder a = + UnionEncoder ( Data.Functor.Product.Product ( Control.Applicative.Const ( Dhall.Map.Map @@ -2553,16 +2564,16 @@ ) deriving (Contravariant) --- | Combines two 'UnionInputType' values. See 'UnionInputType' for usage +-- | Combines two 'UnionEncoder' values. See 'UnionEncoder' for usage -- notes. -- -- Ideally, this matches 'Data.Functor.Contravariant.Divisible.chosen'; --- however, this allows 'UnionInputType' to not need a 'Divisible' instance +-- however, this allows 'UnionEncoder' to not need a 'Divisible' instance -- itself (since no instance is possible). -(>|<) :: UnionInputType a -> UnionInputType b -> UnionInputType (Either a b) -UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx)) - >|< UnionInputType (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) = - UnionInputType +(>|<) :: UnionEncoder a -> UnionEncoder b -> UnionEncoder (Either a b) +UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const mx) (Op fx)) + >|< UnionEncoder (Data.Functor.Product.Pair (Control.Applicative.Const my) (Op fy)) = + UnionEncoder ( Data.Functor.Product.Pair ( Control.Applicative.Const (mx <> my) ) ( Op (either fx fy) ) @@ -2570,10 +2581,10 @@ infixr 5 >|< --- | Convert a `UnionInputType` into the equivalent `InputType` -inputUnion :: UnionInputType a -> InputType a -inputUnion ( UnionInputType ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) = - InputType +-- | Convert a `UnionEncoder` into the equivalent `Encoder` +unionEncoder :: UnionEncoder a -> Encoder a +unionEncoder ( UnionEncoder ( Data.Functor.Product.Pair ( Control.Applicative.Const fields ) ( Op embedF ) ) ) = + Encoder { embed = \x -> let (name, y) = embedF x in case notEmptyRecordLit y of @@ -2585,29 +2596,29 @@ where fields' = fmap notEmptyRecord fields -{-| Specify how to encode an alternative by providing an explicit `InputType` +{-| Specify how to encode an alternative by providing an explicit `Encoder` for that alternative -} -inputConstructorWith +encodeConstructorWith :: Text - -> InputType a - -> UnionInputType a -inputConstructorWith name inputType = UnionInputType $ + -> Encoder a + -> UnionEncoder a +encodeConstructorWith name encodeType = UnionEncoder $ Data.Functor.Product.Pair ( Control.Applicative.Const ( Dhall.Map.singleton name - ( declared inputType ) + ( declared encodeType ) ) ) - ( Op ( (name,) . embed inputType ) + ( Op ( (name,) . embed encodeType ) ) {-| Specify how to encode an alternative by using the default `ToDhall` instance for that type -} -inputConstructor +encodeConstructor :: ToDhall a => Text - -> UnionInputType a -inputConstructor name = inputConstructorWith name inject + -> UnionEncoder a +encodeConstructor name = encodeConstructorWith name inject diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -1,967 +1,1248 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| This module contains logic for converting Dhall expressions to and from - CBOR expressions which can in turn be converted to and from a binary - representation --} - -module Dhall.Binary - ( -- * Standard versions - StandardVersion(..) - , renderStandardVersion - - -- * Encoding and decoding - , ToTerm(..) - , FromTerm(..) - , encodeExpression - , decodeExpression - - -- * Exceptions - , DecodingFailure(..) - ) where - -import Codec.CBOR.Term (Term(..)) -import Control.Applicative (empty, (<|>)) -import Control.Exception (Exception) -import Dhall.Core - ( Binding(..) - , Chunks(..) - , Const(..) - , Directory(..) - , DhallDouble(..) - , Expr(..) - , File(..) - , FilePrefix(..) - , Import(..) - , ImportHashed(..) - , ImportMode(..) - , ImportType(..) - , MultiLet(..) - , Scheme(..) - , URL(..) - , Var(..) - ) - -import Data.Foldable (toList) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Void (Void, absurd) -import GHC.Float (double2Float, float2Double) - -import qualified Control.Monad as Monad -import qualified Data.ByteArray -import qualified Data.ByteString -import qualified Data.Sequence -import qualified Dhall.Core -import qualified Dhall.Crypto -import qualified Dhall.Map -import qualified Dhall.Set - -{-| Supported version strings - - This exists primarily for backwards compatibility for expressions encoded - before Dhall removed version tags from the binary encoding --} -data StandardVersion - = NoVersion - -- ^ No version string - | V_5_0_0 - -- ^ Version "5.0.0" - | V_4_0_0 - -- ^ Version "4.0.0" - | V_3_0_0 - -- ^ Version "3.0.0" - | V_2_0_0 - -- ^ Version "2.0.0" - | V_1_0_0 - -- ^ Version "1.0.0" - deriving (Enum, Bounded) - --- | Render a `StandardVersion` as `Text` -renderStandardVersion :: StandardVersion -> Text -renderStandardVersion NoVersion = "none" -renderStandardVersion V_1_0_0 = "1.0.0" -renderStandardVersion V_2_0_0 = "2.0.0" -renderStandardVersion V_3_0_0 = "3.0.0" -renderStandardVersion V_4_0_0 = "4.0.0" -renderStandardVersion V_5_0_0 = "5.0.0" - -{-| Convert a function applied to multiple arguments to the base function and - the list of arguments --} -unApply :: Expr s a -> (Expr s a, [Expr s a]) -unApply e₀ = (baseFunction₀, diffArguments₀ []) - where - ~(baseFunction₀, diffArguments₀) = go e₀ - - go (App f a) = (baseFunction, diffArguments . (a :)) - where - ~(baseFunction, diffArguments) = go f - - go (Note _ e) = go e - - go baseFunction = (baseFunction, id) - --- | Types that can be encoded as a CBOR `Term` -class ToTerm a where - encode :: a -> Term - -instance ToTerm a => ToTerm (Expr Void a) where - encode (Var (V "_" n)) = - TInt n - encode (Var (V x n)) = - TList [ TString x, TInt n ] - encode NaturalBuild = - TString "Natural/build" - encode NaturalFold = - TString "Natural/fold" - encode NaturalIsZero = - TString "Natural/isZero" - encode NaturalEven = - TString "Natural/even" - encode NaturalOdd = - TString "Natural/odd" - encode NaturalToInteger = - TString "Natural/toInteger" - encode NaturalShow = - TString "Natural/show" - encode NaturalSubtract = - TString "Natural/subtract" - encode IntegerToDouble = - TString "Integer/toDouble" - encode IntegerShow = - TString "Integer/show" - encode DoubleShow = - TString "Double/show" - encode ListBuild = - TString "List/build" - encode ListFold = - TString "List/fold" - encode ListLength = - TString "List/length" - encode ListHead = - TString "List/head" - encode ListLast = - TString "List/last" - encode ListIndexed = - TString "List/indexed" - encode ListReverse = - TString "List/reverse" - encode OptionalFold = - TString "Optional/fold" - encode OptionalBuild = - TString "Optional/build" - encode Bool = - TString "Bool" - encode Optional = - TString "Optional" - encode None = - TString "None" - encode Natural = - TString "Natural" - encode Integer = - TString "Integer" - encode Double = - TString "Double" - encode Text = - TString "Text" - encode TextShow = - TString "Text/show" - encode List = - TString "List" - encode (Const Type) = - TString "Type" - encode (Const Kind) = - TString "Kind" - encode (Const Sort) = - TString "Sort" - encode e@(App _ _) = - TList ([ TInt 0, f₁ ] ++ map encode arguments) - where - (f₀, arguments) = unApply e - - f₁ = encode f₀ - encode (Lam "_" _A₀ b₀) = - TList [ TInt 1, _A₁, b₁ ] - where - _A₁ = encode _A₀ - b₁ = encode b₀ - encode (Lam x _A₀ b₀) = - TList [ TInt 1, TString x, _A₁, b₁ ] - where - _A₁ = encode _A₀ - b₁ = encode b₀ - encode (Pi "_" _A₀ _B₀) = - TList [ TInt 2, _A₁, _B₁ ] - where - _A₁ = encode _A₀ - _B₁ = encode _B₀ - encode (Pi x _A₀ _B₀) = - TList [ TInt 2, TString x, _A₁, _B₁ ] - where - _A₁ = encode _A₀ - _B₁ = encode _B₀ - encode (BoolOr l₀ r₀) = - TList [ TInt 3, TInt 0, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (BoolAnd l₀ r₀) = - TList [ TInt 3, TInt 1, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (BoolEQ l₀ r₀) = - TList [ TInt 3, TInt 2, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (BoolNE l₀ r₀) = - TList [ TInt 3, TInt 3, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (NaturalPlus l₀ r₀) = - TList [ TInt 3, TInt 4, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (NaturalTimes l₀ r₀) = - TList [ TInt 3, TInt 5, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (TextAppend l₀ r₀) = - TList [ TInt 3, TInt 6, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (ListAppend l₀ r₀) = - TList [ TInt 3, TInt 7, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (Combine l₀ r₀) = - TList [ TInt 3, TInt 8, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (Prefer l₀ r₀) = - TList [ TInt 3, TInt 9, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (CombineTypes l₀ r₀) = - TList [ TInt 3, TInt 10, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (ImportAlt l₀ r₀) = - TList [ TInt 3, TInt 11, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (Equivalent l₀ r₀) = - TList [ TInt 3, TInt 12, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (RecordCompletion l₀ r₀) = - TList [ TInt 3, TInt 13, l₁, r₁ ] - where - l₁ = encode l₀ - r₁ = encode r₀ - encode (ListLit _T₀ xs₀) - | null xs₀ = TList [ TInt label, _T₁ ] - | otherwise = TList ([ TInt 4, TNull ] ++ xs₁) - where - (label, _T₁) = case _T₀ of - Nothing -> (4 , TNull) - Just (App List t) -> (4 , encode t) - Just t -> (28, encode t) - - xs₁ = map encode (Data.Foldable.toList xs₀) - encode (Some t₀) = - TList [ TInt 5, TNull, t₁ ] - where - t₁ = encode t₀ - encode (Merge t₀ u₀ Nothing) = - TList [ TInt 6, t₁, u₁ ] - where - t₁ = encode t₀ - u₁ = encode u₀ - encode (Merge t₀ u₀ (Just _T₀)) = - TList [ TInt 6, t₁, u₁, _T₁ ] - where - t₁ = encode t₀ - u₁ = encode u₀ - _T₁ = encode _T₀ - encode (Record xTs₀) = - TList [ TInt 7, TMap xTs₁ ] - where - xTs₁ = do - (x₀, _T₀) <- Dhall.Map.toList (Dhall.Map.sort xTs₀) - let x₁ = TString x₀ - let _T₁ = encode _T₀ - return (x₁, _T₁) - encode (RecordLit xts₀) = - TList [ TInt 8, TMap xts₁ ] - where - xts₁ = do - (x₀, t₀) <- Dhall.Map.toList (Dhall.Map.sort xts₀) - let x₁ = TString x₀ - let t₁ = encode t₀ - return (x₁, t₁) - encode (Field t₀ x) = - TList [ TInt 9, t₁, TString x ] - where - t₁ = encode t₀ - encode (Project t₀ (Left xs₀)) = - TList ([ TInt 10, t₁ ] ++ xs₁) - where - t₁ = encode t₀ - xs₁ = map TString (Dhall.Set.toList xs₀) - encode (Project t₀ (Right _T₀)) = - TList [ TInt 10, t₁, TList [ _T₁ ] ] - where - _T₁ = encode _T₀ - t₁ = encode t₀ - encode (Union xTs₀) = - TList [ TInt 11, TMap xTs₁ ] - where - xTs₁ = do - (x₀, mT₀) <- Dhall.Map.toList (Dhall.Map.sort xTs₀) - - let x₁ = TString x₀ - - let _T₁ = case mT₀ of - Nothing -> TNull - Just _T₀ -> encode _T₀ - - return (x₁, _T₁) - encode (BoolLit b) = - TBool b - encode (BoolIf t₀ l₀ r₀) = - TList [ TInt 14, t₁, l₁, r₁ ] - where - t₁ = encode t₀ - l₁ = encode l₀ - r₁ = encode r₀ - encode (NaturalLit n) = - TList [ TInt 15, TInteger (fromIntegral n) ] - encode (IntegerLit n) = - TList [ TInt 16, TInteger n ] - encode (DoubleLit d) = - encode d - encode (TextLit (Chunks xys₀ z₀)) = - TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ]) - where - xys₁ = do - (x₀, y₀) <- xys₀ - let x₁ = TString x₀ - let y₁ = encode y₀ - [ x₁, y₁ ] - - z₁ = TString z₀ - encode (Assert t₀) = - TList [ TInt 19, t₁ ] - where - t₁ = encode t₀ - encode (Embed x) = - encode x - encode (Let a b) = - TList ([ TInt 25 ] ++ as₁ ++ [ b₁ ]) - where - MultiLet as₀ b₀ = Dhall.Core.multiLet a b - - as₁ = do - Binding _ x₀ _ mA₀ _ a₀ <- toList as₀ - - let mA₁ = case mA₀ of - Nothing -> TNull - Just (_, _A₀) -> encode _A₀ - - let a₁ = encode a₀ - - [ TString x₀, mA₁, a₁ ] - - b₁ = encode b₀ - encode (Annot t₀ _T₀) = - TList [ TInt 26, t₁, _T₁ ] - where - t₁ = encode t₀ - _T₁ = encode _T₀ - encode (ToMap t₀ Nothing) = - TList [ TInt 27, t₁ ] - where - t₁ = encode t₀ - encode (ToMap t₀ (Just _T₀)) = - TList [ TInt 27, t₁, _T₁ ] - where - t₁ = encode t₀ - _T₁ = encode _T₀ - encode (Note a _) = absurd a - -instance ToTerm Import where - encode import_ = - case importType of - Remote (URL { scheme = scheme₀, ..}) -> - TList - ( prefix - ++ [ TInt scheme₁, using, TString authority ] - ++ map TString (reverse components) - ++ [ TString file ] - ++ (case query of Nothing -> [ TNull ]; Just q -> [ TString q ]) - ) - where - using = case headers of - Nothing -> - TNull - Just h -> - encodeExpression h - - scheme₁ = case scheme₀ of - HTTP -> 0 - HTTPS -> 1 - File {..} = path - - Directory {..} = directory - - Local prefix₀ path -> - TList - ( prefix - ++ [ TInt prefix₁ ] - ++ map TString components₁ - ++ [ TString file ] - ) - where - File {..} = path - - Directory {..} = directory - - prefix₁ = case prefix₀ of - Absolute -> 2 - Here -> 3 - Parent -> 4 - Home -> 5 - - components₁ = reverse components - - Env x -> - TList (prefix ++ [ TInt 6, TString x ]) - - Missing -> - TList (prefix ++ [ TInt 7 ]) - where - prefix = [ TInt 24, h, m ] - where - h = case hash of - Nothing -> - TNull - Just digest -> - TBytes ("\x12\x20" <> Data.ByteArray.convert digest) - - m = TInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;) - - Import {..} = import_ - - ImportHashed {..} = importHashed - -instance ToTerm Void where - encode = absurd - -instance ToTerm DhallDouble where - encode (DhallDouble n64) - -- cborg always encodes NaN as a half-precision float of value "7e00" - | useHalf = THalf n32 - | useFloat = TFloat n32 - | otherwise = TDouble n64 - where - n32 = double2Float n64 - useFloat = n64 == float2Double n32 - -- the other four cases for Half-floats are -0.0, 0.0 and the infinities - useHalf = n64 == 0.0 || n64 == infinity || n64 == -infinity - infinity = 1/0 :: Double - --- | Types that can be decoded from a CBOR `Term` -class FromTerm a where - decode :: Term -> Maybe a - -instance FromTerm a => FromTerm (Expr s a) where - decode (TInt n) = - return (Var (V "_" n)) - decode (TInteger n) = - return (Var (V "_" (fromIntegral n))) - decode (TString "Natural/build") = - return NaturalBuild - decode (TString "Natural/fold") = - return NaturalFold - decode (TString "Natural/isZero") = - return NaturalIsZero - decode (TString "Natural/even") = - return NaturalEven - decode (TString "Natural/odd") = - return NaturalOdd - decode (TString "Natural/toInteger") = - return NaturalToInteger - decode (TString "Natural/show") = - return NaturalShow - decode (TString "Natural/subtract") = - return NaturalSubtract - decode (TString "Integer/toDouble") = - return IntegerToDouble - decode (TString "Integer/show") = - return IntegerShow - decode (TString "Double/show") = - return DoubleShow - decode (TString "List/build") = - return ListBuild - decode (TString "List/fold") = - return ListFold - decode (TString "List/length") = - return ListLength - decode (TString "List/head") = - return ListHead - decode (TString "List/last") = - return ListLast - decode (TString "List/indexed") = - return ListIndexed - decode (TString "List/reverse") = - return ListReverse - decode (TString "Optional/fold") = - return OptionalFold - decode (TString "Optional/build") = - return OptionalBuild - decode (TString "Bool") = - return Bool - decode (TString "Optional") = - return Optional - decode (TString "None") = - return None - decode (TString "Natural") = - return Natural - decode (TString "Integer") = - return Integer - decode (TString "Double") = - return Double - decode (TString "Text") = - return Text - decode (TString "Text/show") = - return TextShow - decode (TString "List") = - return List - decode (TString "Type") = - return (Const Type) - decode (TString "Kind") = - return (Const Kind) - decode (TString "Sort") = - return (Const Sort) - decode (TString "_") = - empty - decode (TList [ TString x, TInt n ]) = do - Monad.guard (x /= "_") - return (Var (V x n)) - decode (TList [ TString x, TInteger n ]) = do - Monad.guard (x /= "_") - return (Var (V x (fromIntegral n))) - decode (TList (TInt 0 : f₁ : xs₁)) = do - f₀ <- decode f₁ - xs₀ <- traverse decode xs₁ - Monad.guard (not (null xs₀)) - return (foldl App f₀ xs₀) - decode (TList [ TInt 1, _A₁, b₁ ]) = do - _A₀ <- decode _A₁ - b₀ <- decode b₁ - return (Lam "_" _A₀ b₀) - decode (TList [ TInt 1, TString x, _A₁, b₁ ]) = do - Monad.guard (x /= "_") - _A₀ <- decode _A₁ - b₀ <- decode b₁ - return (Lam x _A₀ b₀) - decode (TList [ TInt 2, _A₁, _B₁ ]) = do - _A₀ <- decode _A₁ - _B₀ <- decode _B₁ - return (Pi "_" _A₀ _B₀) - decode (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do - Monad.guard (x /= "_") - _A₀ <- decode _A₁ - _B₀ <- decode _B₁ - return (Pi x _A₀ _B₀) - decode (TList [ TInt 3, TInt n, l₁, r₁ ]) = do - l₀ <- decode l₁ - r₀ <- decode r₁ - op <- case n of - 0 -> return BoolOr - 1 -> return BoolAnd - 2 -> return BoolEQ - 3 -> return BoolNE - 4 -> return NaturalPlus - 5 -> return NaturalTimes - 6 -> return TextAppend - 7 -> return ListAppend - 8 -> return Combine - 9 -> return Prefer - 10 -> return CombineTypes - 11 -> return ImportAlt - 12 -> return Equivalent - 13 -> return RecordCompletion - _ -> empty - return (op l₀ r₀) - decode (TList [ TInt 4, _T₁ ]) = do - _T₀ <- decode _T₁ - return (ListLit (Just (App List _T₀)) empty) - decode (TList (TInt 4 : TNull : xs₁ )) = do - xs₀ <- traverse decode xs₁ - return (ListLit Nothing (Data.Sequence.fromList xs₀)) - decode (TList [ TInt 5, TNull, t₁ ]) = do - t₀ <- decode t₁ - return (Some t₀) - decode (TList [ TInt 6, t₁, u₁ ]) = do - t₀ <- decode t₁ - u₀ <- decode u₁ - return (Merge t₀ u₀ Nothing) - decode (TList [ TInt 6, t₁, u₁, _T₁ ]) = do - t₀ <- decode t₁ - u₀ <- decode u₁ - _T₀ <- decode _T₁ - return (Merge t₀ u₀ (Just _T₀)) - decode (TList [ TInt 7, TMap xTs₁ ]) = do - let process (TString x, _T₁) = do - _T₀ <- decode _T₁ - - return (x, _T₀) - process _ = - empty - - xTs₀ <- traverse process xTs₁ - - return (Record (Dhall.Map.fromList xTs₀)) - decode (TList [ TInt 8, TMap xts₁ ]) = do - let process (TString x, t₁) = do - t₀ <- decode t₁ - - return (x, t₀) - process _ = - empty - - xts₀ <- traverse process xts₁ - - return (RecordLit (Dhall.Map.fromList xts₀)) - decode (TList [ TInt 9, t₁, TString x ]) = do - t₀ <- decode t₁ - - return (Field t₀ x) - decode (TList (TInt 10 : t₁ : xs₁)) = do - t₀ <- decode t₁ - - let expectString (TString x) = return x - expectString _ = empty - - let decodeLeft = do - strings <- traverse expectString xs₁ - - return (Left (Dhall.Set.fromList strings)) - - let decodeRight = - case xs₁ of - [ TList [ _T₁ ] ] -> do - _T₀ <- decode _T₁ - - return (Right _T₀) - _ -> do - empty - - xs₀ <- decodeLeft <|> decodeRight - - return (Project t₀ xs₀) - decode (TList [ TInt 11, TMap xTs₁ ]) = do - let process (TString x, _T₁) = do - mT₀ <- case _T₁ of - TNull -> return Nothing - _ -> fmap Just (decode _T₁) - - return (x, mT₀) - process _ = - empty - - xTs₀ <- traverse process xTs₁ - - return (Union (Dhall.Map.fromList xTs₀)) - decode (TBool b) = do - return (BoolLit b) - decode (TList [ TInt 14, t₁, l₁, r₁ ]) = do - t₀ <- decode t₁ - l₀ <- decode l₁ - r₀ <- decode r₁ - - return (BoolIf t₀ l₀ r₀) - decode (TList [ TInt 15, TInt n ]) = do - Monad.guard (0 <= n) - return (NaturalLit (fromIntegral n)) - decode (TList [ TInt 15, TInteger n ]) = do - return (NaturalLit (fromInteger n)) - decode (TList [ TInt 16, TInt n ]) = do - return (IntegerLit (fromIntegral n)) - decode (TList [ TInt 16, TInteger n ]) = do - return (IntegerLit n) - decode (THalf n) = do - return (DoubleLit (DhallDouble (float2Double n))) - decode (TFloat n) = do - return (DoubleLit (DhallDouble (float2Double n))) - decode (TDouble n) = do - return (DoubleLit (DhallDouble n)) - decode (TList (TInt 18 : xs)) = do - let process (TString x : y₁ : zs) = do - y₀ <- decode y₁ - - ~(xys, z) <- process zs - - return ((x, y₀) : xys, z) - process [ TString z ] = do - return ([], z) - process _ = do - empty - - (xys, z) <- process xs - - return (TextLit (Chunks xys z)) - decode (TList [ TInt 19, t₁ ]) = do - t₀ <- decode t₁ - - return (Assert t₀) - decode e@(TList (TInt 24 : _)) = fmap Embed (decode e) - decode (TList (TInt 25 : xs)) = do - let process (TString x : _A₁ : a₁ : ls₁) = do - mA₀ <- case _A₁ of - TNull -> return Nothing - _ -> do - _A₀ <- decode _A₁ - return (Just (Nothing, _A₀)) - - a₀ <- decode a₁ - - b₀ <- case ls₁ of - [ b₁ ] -> decode b₁ - _ -> process ls₁ - - return (Let (Binding Nothing x Nothing mA₀ Nothing a₀) b₀) - process _ = do - empty - - process xs - decode (TList [ TInt 26, t₁, _T₁ ]) = do - t₀ <- decode t₁ - _T₀ <- decode _T₁ - return (Annot t₀ _T₀) - decode (TList [ TInt 27, t₁ ]) = do - t₀ <- decode t₁ - return (ToMap t₀ Nothing) - decode (TList [ TInt 27, t₁, _T₁ ]) = do - t₀ <- decode t₁ - _T₀ <- decode _T₁ - return (ToMap t₀ (Just _T₀)) - decode (TList [ TInt 28, _T₁ ]) = do - _T₀ <- decode _T₁ - return (ListLit (Just _T₀) empty) - decode _ = - empty - -instance FromTerm Import where - decode (TList (TInt 24 : h : TInt mode : TInt n : xs)) = do - hash <- case h of - TNull -> do - return Nothing - - TBytes bytes -> do - let (prefix, suffix) = Data.ByteString.splitAt 2 bytes - - case prefix of - "\x12\x20" -> return () - _ -> empty - - digest <- case Dhall.Crypto.sha256DigestFromByteString suffix of - Nothing -> empty - Just digest -> return digest - - return (Just digest) - - _ -> do - empty - - importMode <- case mode of - 0 -> return Code - 1 -> return RawText - 2 -> return Location - _ -> empty - - let remote scheme = do - let process [ TString file, q ] = do - query <- case q of - TNull -> return Nothing - TString x -> return (Just x) - _ -> empty - return ([], file, query) - process (TString path : ys) = do - (paths, file, query) <- process ys - return (path : paths, file, query) - process _ = do - empty - - (headers, authority, paths, file, query) <- case xs of - headers₀ : TString authority : ys -> do - headers₁ <- case headers₀ of - TNull -> do - return Nothing - _ -> do - headers <- decode headers₀ - - return (Just headers) - (paths, file, query) <- process ys - return (headers₁, authority, paths, file, query) - _ -> do - empty - - let components = reverse paths - let directory = Directory {..} - let path = File {..} - - return (Remote (URL {..})) - - let local prefix = do - let process [ TString file ] = do - return ([], file) - process (TString path : ys) = do - (paths, file) <- process ys - return (path : paths, file) - process _ = - empty - - (paths, file) <- process xs - - let components = reverse paths - let directory = Directory {..} - - return (Local prefix (File {..})) - - let env = do - case xs of - [ TString x ] -> return (Env x) - _ -> empty - - let missing = return Missing - - importType <- case n of - 0 -> remote HTTP - 1 -> remote HTTPS - 2 -> local Absolute - 3 -> local Here - 4 -> local Parent - 5 -> local Home - 6 -> env - 7 -> missing - _ -> empty - - let importHashed = ImportHashed {..} - - return (Import {..}) - - decode _ = empty - -instance FromTerm Void where - decode _ = empty - -strip55799Tag :: Term -> Term -strip55799Tag term = - case term of - TInt a -> - TInt a - TInteger a -> - TInteger a - TBytes a -> - TBytes a - TBytesI a -> - TBytesI a - TString a -> - TString a - TStringI a -> - TStringI a - TList as -> - TList (fmap strip55799Tag as) - TListI as -> - TListI (fmap strip55799Tag as) - TMap as -> - TMap (fmap adapt as) - where - adapt (a, b) = (strip55799Tag a, strip55799Tag b) - TMapI as -> - TMapI (fmap adapt as) - where - adapt (a, b) = (strip55799Tag a, strip55799Tag b) - TTagged 55799 b -> - strip55799Tag b - TTagged a b-> - TTagged a (strip55799Tag b) - TBool a -> - TBool a - TNull -> - TNull - TSimple a -> - TSimple a - THalf a -> - THalf a - TFloat a -> - TFloat a - TDouble a -> - TDouble a - --- | Encode a Dhall expression as a CBOR `Term` --- --- This 'Dhall.Core.denote's the expression before encoding it. To encode an --- already denoted expression, it is more efficient to directly use 'encode'. -encodeExpression :: Expr s Import -> Term -encodeExpression e = encode (Dhall.Core.denote e :: Expr Void Import) - --- | Decode a Dhall expression from a CBOR `Term` -decodeExpression :: FromTerm a => Term -> Either DecodingFailure (Expr s a) -decodeExpression term = - case decodeWithoutVersion <|> decodeWithVersion of - Just expression -> Right expression - Nothing -> Left (CBORIsNotDhall term) - where - strippedTerm = strip55799Tag term - -- This is the behavior specified by the standard - decodeWithoutVersion = decode strippedTerm - - -- For backwards compatibility with older expressions that have a version - -- tag to ease the migration - decodeWithVersion = do - TList [ TString version, taggedTerm ] <- return strippedTerm - - -- "_" has never been a valid version string, and this ensures that we - -- don't interpret `[ "_", 0 ]` as the expression `_` (encoded as `0`) - -- tagged with a version string of `"_"` - Monad.guard (version /= "_") - - decode taggedTerm - -{-| This indicates that a given CBOR expression did not correspond to a valid - Dhall expression --} -data DecodingFailure = CBORIsNotDhall Term - deriving (Eq) - -instance Exception DecodingFailure - -_ERROR :: String -_ERROR = "\ESC[1;31mError\ESC[0m" - -instance Show DecodingFailure where - show (CBORIsNotDhall term) = - _ERROR <> ": Cannot decode CBOR to Dhall\n" - <> "\n" - <> "The following CBOR expression does not encode a valid Dhall expression\n" - <> "\n" - <> "↳ " <> show term <> "\n" +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| This module contains logic for converting Dhall expressions to and from + CBOR expressions which can in turn be converted to and from a binary + representation +-} + +module Dhall.Binary + ( -- * Standard versions + StandardVersion(..) + , renderStandardVersion + + -- * Encoding and decoding + , encodeExpression + , decodeExpression + + -- * Exceptions + , DecodingFailure(..) + ) where + +import Codec.CBOR.Decoding (Decoder, TokenType(..)) +import Codec.CBOR.Encoding (Encoding) +import Codec.Serialise (Serialise(encode, decode)) +import Control.Applicative (empty, (<|>)) +import Control.Exception (Exception) +import Data.ByteString.Lazy (ByteString) +import Dhall.Syntax + ( Binding(..) + , Chunks(..) + , Const(..) + , Directory(..) + , DhallDouble(..) + , Expr(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportMode(..) + , ImportType(..) + , MultiLet(..) + , Scheme(..) + , URL(..) + , Var(..) + ) + +import Data.Foldable (toList, foldl') +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Void (Void, absurd) +import GHC.Float (double2Float, float2Double) + +import qualified Codec.CBOR.Decoding as Decoding +import qualified Codec.CBOR.Encoding as Encoding +import qualified Codec.CBOR.Read as Read +import qualified Codec.Serialise as Serialise +import qualified Control.Monad as Monad +import qualified Data.ByteArray +import qualified Data.ByteString +import qualified Data.ByteString.Lazy +import qualified Data.Sequence +import qualified Data.Text as Text +import qualified Dhall.Syntax +import qualified Dhall.Crypto +import qualified Dhall.Map +import qualified Dhall.Set +import qualified Text.Printf as Printf + +{-| Supported version strings + + This exists primarily for backwards compatibility for expressions encoded + before Dhall removed version tags from the binary encoding +-} +data StandardVersion + = NoVersion + -- ^ No version string + | V_5_0_0 + -- ^ Version "5.0.0" + | V_4_0_0 + -- ^ Version "4.0.0" + | V_3_0_0 + -- ^ Version "3.0.0" + | V_2_0_0 + -- ^ Version "2.0.0" + | V_1_0_0 + -- ^ Version "1.0.0" + deriving (Enum, Bounded) + +-- | Render a `StandardVersion` as `Text` +renderStandardVersion :: StandardVersion -> Text +renderStandardVersion NoVersion = "none" +renderStandardVersion V_1_0_0 = "1.0.0" +renderStandardVersion V_2_0_0 = "2.0.0" +renderStandardVersion V_3_0_0 = "3.0.0" +renderStandardVersion V_4_0_0 = "4.0.0" +renderStandardVersion V_5_0_0 = "5.0.0" + +{-| Convert a function applied to multiple arguments to the base function and + the list of arguments +-} +unApply :: Expr s a -> (Expr s a, [Expr s a]) +unApply e₀ = (baseFunction₀, diffArguments₀ []) + where + ~(baseFunction₀, diffArguments₀) = go e₀ + + go (App f a) = (baseFunction, diffArguments . (a :)) + where + ~(baseFunction, diffArguments) = go f + + go (Note _ e) = go e + + go baseFunction = (baseFunction, id) + +decodeExpressionInternal :: (Int -> Decoder s a) -> Decoder s (Expr t a) +decodeExpressionInternal decodeEmbed = go + where + go = do + let die message = fail ("Dhall.Binary.decodeExpressionInternal: " <> message) + + tokenType₀ <- Decoding.peekTokenType + + case tokenType₀ of + TypeUInt -> do + !n <- Decoding.decodeWord + + return (Var (V "_" (fromIntegral n))) + + TypeUInt64 -> do + !n <- Decoding.decodeWord64 + + return (Var (V "_" (fromIntegral n))) + + TypeFloat16 -> do + !n <- Decoding.decodeFloat + + return (DoubleLit (DhallDouble (float2Double n))) + + TypeFloat32 -> do + !n <- Decoding.decodeFloat + + return (DoubleLit (DhallDouble (float2Double n))) + + TypeFloat64 -> do + !n <- Decoding.decodeDouble + + return (DoubleLit (DhallDouble n)) + + TypeBool -> do + !b <- Decoding.decodeBool + + return (BoolLit b) + + TypeString -> do + s <- Decoding.decodeString + + case s of + "Natural/build" -> return NaturalBuild + "Natural/fold" -> return NaturalFold + "Natural/isZero" -> return NaturalIsZero + "Natural/even" -> return NaturalEven + "Natural/odd" -> return NaturalOdd + "Natural/toInteger" -> return NaturalToInteger + "Natural/show" -> return NaturalShow + "Natural/subtract" -> return NaturalSubtract + "Integer/toDouble" -> return IntegerToDouble + "Integer/clamp" -> return IntegerClamp + "Integer/negate" -> return IntegerNegate + "Integer/show" -> return IntegerShow + "Double/show" -> return DoubleShow + "List/build" -> return ListBuild + "List/fold" -> return ListFold + "List/length" -> return ListLength + "List/head" -> return ListHead + "List/last" -> return ListLast + "List/indexed" -> return ListIndexed + "List/reverse" -> return ListReverse + "Optional/fold" -> return OptionalFold + "Optional/build" -> return OptionalBuild + "Bool" -> return Bool + "Optional" -> return Optional + "None" -> return None + "Natural" -> return Natural + "Integer" -> return Integer + "Double" -> return Double + "Text" -> return Text + "Text/show" -> return TextShow + "List" -> return List + "Type" -> return (Const Type) + "Kind" -> return (Const Kind) + "Sort" -> return (Const Sort) + _ -> die ("Unrecognized built-in: " <> Text.unpack s) + + TypeListLen -> do + len <- Decoding.decodeListLen + + case len of + 0 -> die "Missing tag" + _ -> return () + + tokenType₁ <- Decoding.peekTokenType + + case tokenType₁ of + TypeString -> do + x <- Decoding.decodeString + + if x == "_" + then die "Non-standard encoding of an α-normalized variable" + else return () + + tokenType₂ <- Decoding.peekTokenType + + case tokenType₂ of + TypeUInt -> do + !n <- Decoding.decodeWord + + return (Var (V x (fromIntegral n))) + + TypeUInt64 -> do + !n <- Decoding.decodeWord64 + + return (Var (V x (fromIntegral n))) + + _ -> do + die ("Unexpected token type for variable index: " <> show tokenType₂) + + TypeUInt -> do + tag <- Decoding.decodeWord + + case tag of + 0 -> do + f <- go + + xs <- Monad.replicateM (len - 2) go + + if null xs + then die "Non-standard encoding of a function with no arguments" + else return () + + return (foldl' App f xs) + + 1 -> do + case len of + 3 -> do + _A <- go + + b <- go + + return (Lam "_" _A b) + + 4 -> do + x <- Decoding.decodeString + + if x == "_" + then die "Non-standard encoding of a λ expression" + else return () + + _A <- go + + b <- go + + return (Lam x _A b) + + _ -> do + die ("Incorrect number of tokens used to encode a λ expression: " <> show len) + + 2 -> do + case len of + 3 -> do + _A <- go + + _B <- go + + return (Pi "_" _A _B) + + 4 -> do + x <- Decoding.decodeString + + if x == "_" + then die "Non-standard encoding of a ∀ expression" + else return () + + _A <- go + + _B <- go + + return (Pi x _A _B) + + _ -> do + die ("Incorrect number of tokens used to encode a ∀ expression: " <> show len) + + 3 -> do + opcode <- Decoding.decodeWord + + op <- case opcode of + 0 -> return BoolOr + 1 -> return BoolAnd + 2 -> return BoolEQ + 3 -> return BoolNE + 4 -> return NaturalPlus + 5 -> return NaturalTimes + 6 -> return TextAppend + 7 -> return ListAppend + 8 -> return Combine + 9 -> return Prefer + 10 -> return CombineTypes + 11 -> return ImportAlt + 12 -> return Equivalent + 13 -> return RecordCompletion + _ -> die ("Unrecognized operator code: " <> show opcode) + + l <- go + + r <- go + + return (op l r) + + 4 -> do + case len of + 2 -> do + _T <- go + + return (ListLit (Just (App List _T)) empty) + + _ -> do + Decoding.decodeNull + + xs <- Monad.replicateM (len - 2) go + return (ListLit Nothing (Data.Sequence.fromList xs)) + + 5 -> do + Decoding.decodeNull + + t <- go + + return (Some t) + + 6 -> do + t <- go + + u <- go + + case len of + 3 -> do + return (Merge t u Nothing) + + 4 -> do + _T <- go + + return (Merge t u (Just _T)) + + _ -> do + die ("Incorrect number of tokens used to encode a `merge` expression: " <> show len) + + 7 -> do + mapLength <- Decoding.decodeMapLen + + xTs <- Monad.replicateM mapLength $ do + x <- Decoding.decodeString + + _T <- go + + return (x, _T) + + return (Record (Dhall.Map.fromList xTs)) + + 8 -> do + mapLength <- Decoding.decodeMapLen + + xts <- Monad.replicateM mapLength $ do + x <- Decoding.decodeString + + t <- go + + return (x, t) + + return (RecordLit (Dhall.Map.fromList xts)) + + 9 -> do + t <- go + + x <- Decoding.decodeString + + return (Field t x) + + 10 -> do + t <- go + + xs <- case len of + 3 -> do + tokenType₂ <- Decoding.peekTokenType + + case tokenType₂ of + TypeListLen -> do + _ <- Decoding.decodeListLen + + _T <- go + + return (Right _T) + + TypeString -> do + x <- Decoding.decodeString + return (Left (Dhall.Set.fromList [x])) + + _ -> do + die ("Unexpected token type for projection: " <> show tokenType₂) + + _ -> do + xs <- Monad.replicateM (len - 2) Decoding.decodeString + + return (Left (Dhall.Set.fromList xs)) + + return (Project t xs) + + 11 -> do + mapLength <- Decoding.decodeMapLen + + xTs <- Monad.replicateM mapLength $ do + x <- Decoding.decodeString + + tokenType₂ <- Decoding.peekTokenType + + mT <- case tokenType₂ of + TypeNull -> do + Decoding.decodeNull + + return Nothing + + _ -> do + _T <- go + + return (Just _T) + + return (x, mT) + + return (Union (Dhall.Map.fromList xTs)) + + 14 -> do + t <- go + + l <- go + + r <- go + + return (BoolIf t l r) + + 15 -> do + tokenType₂ <- Decoding.peekTokenType + + case tokenType₂ of + TypeUInt -> do + n <- Decoding.decodeWord + + return (NaturalLit (fromIntegral n)) + + TypeUInt64 -> do + n <- Decoding.decodeWord64 + + return (NaturalLit (fromIntegral n)) + + TypeInteger -> do + n <- Decoding.decodeInteger + return (NaturalLit (fromIntegral n)) + + _ -> do + die ("Unexpected token type for Natural literal: " <> show tokenType₂) + + 16 -> do + tokenType₂ <- Decoding.peekTokenType + + case tokenType₂ of + TypeUInt -> do + n <- Decoding.decodeWord + + return (IntegerLit (fromIntegral n)) + + TypeUInt64 -> do + n <- Decoding.decodeWord64 + + return (IntegerLit (fromIntegral n)) + + TypeNInt -> do + n <- Decoding.decodeNegWord + + return (IntegerLit (-1 - fromIntegral n)) + + TypeNInt64 -> do + n <- Decoding.decodeNegWord64 + + return (IntegerLit (-1 - fromIntegral n)) + TypeInteger -> do + n <- Decoding.decodeInteger + return (IntegerLit n) + + _ -> do + die ("Unexpected token type for Integer literal: " <> show tokenType₂) + + 18 -> do + xys <- Monad.replicateM ((len - 2) `quot` 2) $ do + x <- Decoding.decodeString + + y <- go + + return (x, y) + + z <- Decoding.decodeString + + return (TextLit (Chunks xys z)) + + 19 -> do + t <- go + + return (Assert t) + + 24 -> do + fmap Embed (decodeEmbed len) + + 25 -> do + bindings <- Monad.replicateM ((len - 2) `quot` 3) $ do + x <- Decoding.decodeString + + tokenType₂ <- Decoding.peekTokenType + + mA <- case tokenType₂ of + TypeNull -> do + Decoding.decodeNull + + return Nothing + + _ -> do + _A <- go + + return (Just (Nothing, _A)) + + a <- go + + return (Binding Nothing x Nothing mA Nothing a) + + b <- go + + return (foldr Let b bindings) + + 26 -> do + t <- go + + _T <- go + + return (Annot t _T) + + 27 -> do + t <- go + + mT <- case len of + 2 -> do + return Nothing + + 3 -> do + _T <- go + + return (Just _T) + + _ -> do + die ("Incorrect number of tokens used to encode a type annotation: " <> show len) + + return (ToMap t mT) + + 28 -> do + _T <- go + + return (ListLit (Just _T) empty) + + _ -> do + die ("Unexpected tag: " <> show tag) + + _ -> do + die ("Unexpected tag type: " <> show tokenType₁) + + _ -> do + die ("Unexpected initial token: " <> show tokenType₀) + +encodeExpressionInternal :: (a -> Encoding) -> Expr Void a -> Encoding +encodeExpressionInternal encodeEmbed = go + where + go e = case e of + Var (V "_" n) -> + Encoding.encodeInt n + + Var (V x n) -> + Encoding.encodeListLen 2 + <> Encoding.encodeString x + <> Encoding.encodeInt n + + NaturalBuild -> + Encoding.encodeString "Natural/build" + + NaturalFold -> + Encoding.encodeString "Natural/fold" + + NaturalIsZero -> + Encoding.encodeString "Natural/isZero" + + NaturalEven -> + Encoding.encodeString "Natural/even" + + NaturalOdd -> + Encoding.encodeString "Natural/odd" + + NaturalToInteger -> + Encoding.encodeString "Natural/toInteger" + + NaturalShow -> + Encoding.encodeString "Natural/show" + + NaturalSubtract -> + Encoding.encodeString "Natural/subtract" + + IntegerToDouble -> + Encoding.encodeString "Integer/toDouble" + + IntegerClamp -> + Encoding.encodeString "Integer/clamp" + + IntegerNegate -> + Encoding.encodeString "Integer/negate" + + IntegerShow -> + Encoding.encodeString "Integer/show" + + DoubleShow -> + Encoding.encodeString "Double/show" + + ListBuild -> + Encoding.encodeString "List/build" + + ListFold -> + Encoding.encodeString "List/fold" + + ListLength -> + Encoding.encodeString "List/length" + + ListHead -> + Encoding.encodeString "List/head" + + ListLast -> + Encoding.encodeString "List/last" + + ListIndexed -> + Encoding.encodeString "List/indexed" + + ListReverse -> + Encoding.encodeString "List/reverse" + + OptionalFold -> + Encoding.encodeString "Optional/fold" + + OptionalBuild -> + Encoding.encodeString "Optional/build" + + Bool -> + Encoding.encodeString "Bool" + + Optional -> + Encoding.encodeString "Optional" + + None -> + Encoding.encodeString "None" + + Natural -> + Encoding.encodeString "Natural" + + Integer -> + Encoding.encodeString "Integer" + + Double -> + Encoding.encodeString "Double" + + Text -> + Encoding.encodeString "Text" + + TextShow -> + Encoding.encodeString "Text/show" + + List -> + Encoding.encodeString "List" + + Const Type -> + Encoding.encodeString "Type" + + Const Kind -> + Encoding.encodeString "Kind" + + Const Sort -> + Encoding.encodeString "Sort" + + a@App{} -> + encodeListN + (2 + length arguments) + ( Encoding.encodeInt 0 + : go function + : map go arguments + ) + where + (function, arguments) = unApply a + + Lam "_" _A b -> + encodeList3 + (Encoding.encodeInt 1) + (go _A) + (go b) + + Lam x _A b -> + encodeList4 + (Encoding.encodeInt 1) + (Encoding.encodeString x) + (go _A) + (go b) + + Pi "_" _A _B -> + encodeList3 + (Encoding.encodeInt 2) + (go _A) + (go _B) + + Pi x _A _B -> + encodeList4 + (Encoding.encodeInt 2) + (Encoding.encodeString x) + (go _A) + (go _B) + + BoolOr l r -> + encodeOperator 0 l r + + BoolAnd l r -> + encodeOperator 1 l r + + BoolEQ l r -> + encodeOperator 2 l r + + BoolNE l r -> + encodeOperator 3 l r + + NaturalPlus l r -> + encodeOperator 4 l r + + NaturalTimes l r -> + encodeOperator 5 l r + + TextAppend l r -> + encodeOperator 6 l r + + ListAppend l r -> + encodeOperator 7 l r + + Combine l r -> + encodeOperator 8 l r + + Prefer l r -> + encodeOperator 9 l r + + CombineTypes l r -> + encodeOperator 10 l r + + ImportAlt l r -> + encodeOperator 11 l r + + Equivalent l r -> + encodeOperator 12 l r + + RecordCompletion l r -> + encodeOperator 13 l r + + ListLit _T₀ xs + | null xs -> + encodeList2 (Encoding.encodeInt label) _T₁ + | otherwise -> + encodeListN + (2 + length xs) + ( Encoding.encodeInt 4 + : Encoding.encodeNull + : map go (Data.Foldable.toList xs) + ) + where + (label, _T₁) = case _T₀ of + Nothing -> (4 , Encoding.encodeNull) + Just (App List t) -> (4 , go t ) + Just t -> (28, go t ) + + Some t -> + encodeList3 + (Encoding.encodeInt 5) + Encoding.encodeNull + (go t) + + Merge t u Nothing -> + encodeList3 + (Encoding.encodeInt 6) + (go t) + (go u) + + Merge t u (Just _T) -> + encodeList4 + (Encoding.encodeInt 6) + (go t) + (go u) + (go _T) + + Record xTs -> + encodeList2 + (Encoding.encodeInt 7) + (encodeMapWith go xTs) + + RecordLit xts -> + encodeList2 + (Encoding.encodeInt 8) + (encodeMapWith go xts) + + Field t x -> + encodeList3 + (Encoding.encodeInt 9) + (go t) + (Encoding.encodeString x) + + Project t (Left xs) -> + encodeListN + (2 + Dhall.Set.size xs) + ( Encoding.encodeInt 10 + : go t + : map Encoding.encodeString (Dhall.Set.toList xs) + ) + + Project t (Right _T) -> + encodeList3 + (Encoding.encodeInt 10) + (go t) + (encodeList1 (go _T)) + + Union xTs -> + encodeList2 + (Encoding.encodeInt 11) + (encodeMapWith encodeValue xTs) + where + encodeValue Nothing = Encoding.encodeNull + encodeValue (Just _T) = go _T + + BoolLit b -> + Encoding.encodeBool b + + BoolIf t l r -> + encodeList4 + (Encoding.encodeInt 14) + (go t) + (go l) + (go r) + + NaturalLit n -> + encodeList2 + (Encoding.encodeInt 15) + (Encoding.encodeInteger (fromIntegral n)) + + IntegerLit n -> + encodeList2 + (Encoding.encodeInt 16) + (Encoding.encodeInteger (fromIntegral n)) + + DoubleLit (DhallDouble n64) + | useHalf -> Encoding.encodeFloat16 n32 + | useFloat -> Encoding.encodeFloat n32 + | otherwise -> Encoding.encodeDouble n64 + where + n32 = double2Float n64 + + useFloat = n64 == float2Double n32 + + useHalf = n64 == 0.0 || n64 == infinity || n64 == -infinity + + infinity = 1/0 :: Double + + -- Fast path for the common case of an uninterpolated string + TextLit (Chunks [] z) -> + encodeList2 + (Encoding.encodeInt 18) + (Encoding.encodeString z) + + TextLit (Chunks xys z) -> + encodeListN + (2 + 2 * length xys) + ( Encoding.encodeInt 18 + : concatMap encodePair xys ++ [ Encoding.encodeString z ] + ) + where + encodePair (x, y) = [ Encoding.encodeString x, go y ] + + Assert t -> + encodeList2 + (Encoding.encodeInt 19) + (go t) + + Embed x -> + encodeEmbed x + + Let a₀ b₀ -> + encodeListN + (2 + 3 * length as) + ( Encoding.encodeInt 25 + : concatMap encodeBinding (toList as) ++ [ go b₁ ] + ) + where + MultiLet as b₁ = Dhall.Syntax.multiLet a₀ b₀ + + encodeBinding (Binding _ x _ mA₀ _ a) = + [ Encoding.encodeString x + , mA₁ + , go a + ] + where + mA₁ = case mA₀ of + Nothing -> Encoding.encodeNull + Just (_, _A) -> go _A + + Annot t _T -> + encodeList3 + (Encoding.encodeInt 26) + (go t) + (go _T) + + ToMap t Nothing -> + encodeList2 + (Encoding.encodeInt 27) + (go t) + + ToMap t (Just _T) -> + encodeList3 + (Encoding.encodeInt 27) + (go t) + (go _T) + + Note _ b -> + go b + + encodeOperator n l r = + encodeList4 + (Encoding.encodeInt 3) + (Encoding.encodeInt n) + (go l) + (go r) + + encodeMapWith encodeValue m = + Encoding.encodeMapLen (fromIntegral (Dhall.Map.size m)) + <> foldMap encodeKeyValue (Dhall.Map.toList (Dhall.Map.sort m)) + where + encodeKeyValue (k, v) = Encoding.encodeString k <> encodeValue v + +encodeList1 :: Encoding -> Encoding +encodeList1 a = Encoding.encodeListLen 1 <> a +{-# INLINE encodeList1 #-} + +encodeList2 :: Encoding -> Encoding -> Encoding +encodeList2 a b = Encoding.encodeListLen 2 <> a <> b +{-# INLINE encodeList2 #-} + +encodeList3 :: Encoding -> Encoding -> Encoding -> Encoding +encodeList3 a b c = Encoding.encodeListLen 3 <> a <> b <> c +{-# INLINE encodeList3 #-} + +encodeList4 :: Encoding -> Encoding -> Encoding -> Encoding -> Encoding +encodeList4 a b c d = Encoding.encodeListLen 4 <> a <> b <> c <> d +{-# INLINE encodeList4 #-} + +encodeListN :: Int -> [ Encoding ] -> Encoding +encodeListN len xs = Encoding.encodeListLen (fromIntegral len) <> mconcat xs +{-# INLINE encodeListN #-} + +encodeList :: [ Encoding ] -> Encoding +encodeList xs = encodeListN (length xs) xs +{-# INLINE encodeList #-} + +decodeImport :: Int -> Decoder s Import +decodeImport len = do + let die message = fail ("Dhall.Binary.decodeImport: " <> message) + + tokenType₀ <- Decoding.peekTokenType + + hash <- case tokenType₀ of + TypeNull -> do + Decoding.decodeNull + + return Nothing + + TypeBytes -> do + bytes <- Decoding.decodeBytes + + let (prefix, suffix) = Data.ByteString.splitAt 2 bytes + + case prefix of + "\x12\x20" -> return () + _ -> die ("Unrecognized multihash prefix: " <> show prefix) + case Dhall.Crypto.sha256DigestFromByteString suffix of + Nothing -> die ("Invalid sha256 digest: " <> show bytes) + Just digest -> return (Just digest) + + _ -> do + die ("Unexpected hash token: " <> show tokenType₀) + + m <- Decoding.decodeWord + + importMode <- case m of + 0 -> return Code + 1 -> return RawText + 2 -> return Location + _ -> die ("Unexpected code for import mode: " <> show m) + + let remote scheme = do + tokenType₁ <- Decoding.peekTokenType + + headers <- case tokenType₁ of + TypeNull -> do + Decoding.decodeNull + return Nothing + + _ -> do + headers <- decodeExpressionInternal decodeImport + + return (Just headers) + + authority <- Decoding.decodeString + + paths <- Monad.replicateM (len - 8) Decoding.decodeString + + file <- Decoding.decodeString + + tokenType₂ <- Decoding.peekTokenType + + query <- case tokenType₂ of + TypeNull -> do + Decoding.decodeNull + return Nothing + _ -> do + fmap Just Decoding.decodeString + + let components = reverse paths + let directory = Directory {..} + let path = File {..} + + return (Remote (URL {..})) + + let local prefix = do + paths <- Monad.replicateM (len - 5) Decoding.decodeString + + file <- Decoding.decodeString + + let components = reverse paths + let directory = Directory {..} + + return (Local prefix (File {..})) + + let missing = return Missing + + let env = do + x <- Decoding.decodeString + + return (Env x) + + n <- Decoding.decodeWord + + importType <- case n of + 0 -> remote HTTP + 1 -> remote HTTPS + 2 -> local Absolute + 3 -> local Here + 4 -> local Parent + 5 -> local Home + 6 -> env + 7 -> missing + _ -> fail ("Unrecognized import type code: " <> show n) + + let importHashed = ImportHashed {..} + + return (Import {..}) + +encodeImport :: Import -> Encoding +encodeImport import_ = + case importType of + Remote (URL { scheme = scheme₀, .. }) -> + encodeList + ( prefix + ++ [ Encoding.encodeInt scheme₁ + , using + , Encoding.encodeString authority + ] + ++ map Encoding.encodeString (reverse components) + ++ [ Encoding.encodeString file ] + ++ [ case query of + Nothing -> Encoding.encodeNull + Just q -> Encoding.encodeString q + ] + ) + where + using = case headers of + Nothing -> + Encoding.encodeNull + Just h -> + encodeExpressionInternal encodeImport (Dhall.Syntax.denote h) + + scheme₁ = case scheme₀ of + HTTP -> 0 + HTTPS -> 1 + + File{..} = path + + Directory {..} = directory + + Local prefix₀ path -> + encodeList + ( prefix + ++ [ Encoding.encodeInt prefix₁ ] + ++ map Encoding.encodeString components₁ + ++ [ Encoding.encodeString file ] + ) + where + File{..} = path + + Directory{..} = directory + + prefix₁ = case prefix₀ of + Absolute -> 2 + Here -> 3 + Parent -> 4 + Home -> 5 + + components₁ = reverse components + + Env x -> + encodeList + (prefix ++ [ Encoding.encodeInt 6, Encoding.encodeString x ]) + + Missing -> + encodeList (prefix ++ [ Encoding.encodeInt 7 ]) + where + prefix = [ Encoding.encodeInt 24, h, m ] + where + h = case hash of + Nothing -> + Encoding.encodeNull + + Just digest -> + Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) + + m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;) + + Import{..} = import_ + + ImportHashed{..} = importHashed + +decodeVoid :: Int -> Decoder s Void +decodeVoid _ = fail "Dhall.Binary.decodeVoid: Cannot decode an uninhabited type" + +encodeVoid :: Void -> Encoding +encodeVoid = absurd + +instance Serialise (Expr Void Void) where + encode = encodeExpressionInternal encodeVoid + + decode = decodeExpressionInternal decodeVoid + +instance Serialise (Expr Void Import) where + encode = encodeExpressionInternal encodeImport + + decode = decodeExpressionInternal decodeImport + +-- | Encode a Dhall expression as a CBOR-encoded `ByteString` +encodeExpression :: Expr Void Import -> ByteString +encodeExpression = Serialise.serialise + +-- | Decode a Dhall expression from a CBOR `Term` +decodeExpression + :: Serialise (Expr s a) => ByteString -> Either DecodingFailure (Expr s a) +decodeExpression bytes = + case decodeWithoutVersion <|> decodeWithVersion of + Just expression -> Right expression + Nothing -> Left (CBORIsNotDhall bytes) + where + adapt (Right ("", x)) = Just x + adapt _ = Nothing + + decode' = decodeWith55799Tag decode + + -- This is the behavior specified by the standard + decodeWithoutVersion = adapt (Read.deserialiseFromBytes decode' bytes) + + -- tag to ease the migration + decodeWithVersion = adapt (Read.deserialiseFromBytes decodeWithTag bytes) + where + decodeWithTag = do + 2 <- Decoding.decodeListLen + + version <- Decoding.decodeString + + + -- "_" has never been a valid version string, and this ensures that + -- we don't interpret `[ "_", 0 ]` as the expression `_` (encoded as + -- `0`) tagged with a version string of `"_"` + if (version == "_") + then fail "Dhall.Binary.decodeExpression: \"_\" is not a valid version string" + else return () + + decode' + +decodeWith55799Tag :: Decoder s a -> Decoder s a +decodeWith55799Tag decoder = do + tokenType <- Decoding.peekTokenType + + case tokenType of + TypeTag -> do + w <- Decoding.decodeTag + + if w /= 55799 + then fail ("Dhall.Binary.decodeWith55799Tag: Unexpected tag: " <> show w) + else return () + + decoder + _ -> do + decoder + +{-| This indicates that a given CBOR-encoded `ByteString` did not correspond to + a valid Dhall expression +-} +newtype DecodingFailure = CBORIsNotDhall ByteString + deriving (Eq) + +instance Exception DecodingFailure + +_ERROR :: String +_ERROR = "\ESC[1;31mError\ESC[0m" + +instance Show DecodingFailure where + show (CBORIsNotDhall bytes) = + _ERROR <> ": Cannot decode CBOR to Dhall\n" + <> "\n" + <> "The following bytes do not encode a valid Dhall expression\n" + <> "\n" + <> "↳ 0x" <> concatMap toHex (Data.ByteString.Lazy.unpack bytes) <> "\n" + where + toHex = Printf.printf "%02x " diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -1,1306 +1,89 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -{-| This module contains the core calculus for the Dhall language. - - Dhall is essentially a fork of the @morte@ compiler but with more built-in - functionality, better error messages, and Haskell integration --} - -module Dhall.Core ( - -- * Syntax - Const(..) - , Directory(..) - , File(..) - , FilePrefix(..) - , Import(..) - , ImportHashed(..) - , ImportMode(..) - , ImportType(..) - , URL(..) - , Scheme(..) - , DhallDouble(..) - , Var(..) - , Binding(..) - , makeBinding - , Chunks(..) - , Expr(..) - - -- * Normalization - , alphaNormalize - , normalize - , normalizeWith - , normalizeWithM - , Normalizer - , NormalizerM - , ReifiedNormalizer (..) - , judgmentallyEqual - , subst - , shift - , isNormalized - , isNormalizedWith - , denote - , renote - , shallowDenote - , freeIn - - -- * Pretty-printing - , pretty - - -- * Optics - , subExpressions - , chunkExprs - , bindingExprs - - -- * Let-blocks - , multiLet - , wrapInLets - , MultiLet(..) - - -- * Miscellaneous - , internalError - , reservedIdentifiers - , escapeText - , pathCharacter - , throws - , Eval.textShow - , censorExpression - , censorText - ) where - -import Control.Applicative (empty) -import Control.Exception (Exception) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Foldable -import Data.Functor.Identity (Identity(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..), ViewR(..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) -import Data.Traversable -import Dhall.Src (Src(..)) -import Dhall.Syntax -import Dhall.Pretty.Internal -import Instances.TH.Lift () -import Lens.Family (over) -import Prelude hiding (succ) - -import qualified Control.Exception -import qualified Dhall.Eval as Eval -import qualified Data.Sequence -import qualified Data.Set -import qualified Data.Text -import qualified Dhall.Map -import qualified Dhall.Set - -{-| Returns `True` if two expressions are α-equivalent and β-equivalent and - `False` otherwise - - `judgmentallyEqual` can fail with an `error` if you compare ill-typed - expressions --} -judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool -judgmentallyEqual = Eval.judgmentallyEqual -{-# INLINE judgmentallyEqual #-} - -{-| `shift` is used by both normalization and type-checking to avoid variable - capture by shifting variable indices - - For example, suppose that you were to normalize the following expression: - -> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x - - If you were to substitute @y@ with @x@ without shifting any variable - indices, then you would get the following incorrect result: - -> λ(a : Type) → λ(x : a) → λ(x : a) → x -- Incorrect normalized form - - In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in - order to avoid being misinterpreted as the @x@ bound by the innermost - lambda. If we perform that `shift` then we get the correct result: - -> λ(a : Type) → λ(x : a) → λ(x : a) → x@1 - - As a more worked example, suppose that you were to normalize the following - expression: - -> λ(a : Type) -> → λ(f : a → a → a) -> → λ(x : a) -> → λ(x : a) -> → (λ(x : a) → f x x@1) x@1 - - The correct normalized result would be: - -> λ(a : Type) -> → λ(f : a → a → a) -> → λ(x : a) -> → λ(x : a) -> → f x@1 x - - The above example illustrates how we need to both increase and decrease - variable indices as part of substitution: - - * We need to increase the index of the outer @x\@1@ to @x\@2@ before we - substitute it into the body of the innermost lambda expression in order - to avoid variable capture. This substitution changes the body of the - lambda expression to @(f x\@2 x\@1)@ - - * We then remove the innermost lambda and therefore decrease the indices of - both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one - less @x@ variable is now bound within that scope - - Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to - the indices of all variables named @x@ whose indices are greater than - @(n + m)@, where @m@ is the number of bound variables of the same name - within that scope - - In practice, @d@ is always @1@ or @-1@ because we either: - - * increment variables by @1@ to avoid variable capture during substitution - * decrement variables by @1@ when deleting lambdas after substitution - - @n@ starts off at @0@ when substitution begins and increments every time we - descend into a lambda or let expression that binds a variable of the same - name in order to avoid shifting the bound variables by mistake. --} -shift :: Int -> Var -> Expr s a -> Expr s a -shift _ _ (Const a) = Const a -shift d (V x n) (Var (V x' n')) = Var (V x' n'') - where - n'' = if x == x' && n <= n' then n' + d else n' -shift d (V x n) (Lam x' _A b) = Lam x' _A' b' - where - _A' = shift d (V x n ) _A - b' = shift d (V x n') b - where - n' = if x == x' then n + 1 else n -shift d (V x n) (Pi x' _A _B) = Pi x' _A' _B' - where - _A' = shift d (V x n ) _A - _B' = shift d (V x n') _B - where - n' = if x == x' then n + 1 else n -shift d v (App f a) = App f' a' - where - f' = shift d v f - a' = shift d v a -shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) = - Let (Binding src0 f src1 mt' src2 r') e' - where - e' = shift d (V x n') e - where - n' = if x == f then n + 1 else n - - mt' = fmap (fmap (shift d (V x n))) mt - r' = shift d (V x n) r -shift d v (Annot a b) = Annot a' b' - where - a' = shift d v a - b' = shift d v b -shift _ _ Bool = Bool -shift _ _ (BoolLit a) = BoolLit a -shift d v (BoolAnd a b) = BoolAnd a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (BoolOr a b) = BoolOr a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (BoolEQ a b) = BoolEQ a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (BoolNE a b) = BoolNE a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (BoolIf a b c) = BoolIf a' b' c' - where - a' = shift d v a - b' = shift d v b - c' = shift d v c -shift _ _ Natural = Natural -shift _ _ (NaturalLit a) = NaturalLit a -shift _ _ NaturalFold = NaturalFold -shift _ _ NaturalBuild = NaturalBuild -shift _ _ NaturalIsZero = NaturalIsZero -shift _ _ NaturalEven = NaturalEven -shift _ _ NaturalOdd = NaturalOdd -shift _ _ NaturalToInteger = NaturalToInteger -shift _ _ NaturalShow = NaturalShow -shift _ _ NaturalSubtract = NaturalSubtract -shift d v (NaturalPlus a b) = NaturalPlus a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (NaturalTimes a b) = NaturalTimes a' b' - where - a' = shift d v a - b' = shift d v b -shift _ _ Integer = Integer -shift _ _ (IntegerLit a) = IntegerLit a -shift _ _ IntegerShow = IntegerShow -shift _ _ IntegerToDouble = IntegerToDouble -shift _ _ Double = Double -shift _ _ (DoubleLit a) = DoubleLit a -shift _ _ DoubleShow = DoubleShow -shift _ _ Text = Text -shift d v (TextLit (Chunks a b)) = TextLit (Chunks a' b) - where - a' = fmap (fmap (shift d v)) a -shift d v (TextAppend a b) = TextAppend a' b' - where - a' = shift d v a - b' = shift d v b -shift _ _ TextShow = TextShow -shift _ _ List = List -shift d v (ListLit a b) = ListLit a' b' - where - a' = fmap (shift d v) a - b' = fmap (shift d v) b -shift _ _ ListBuild = ListBuild -shift d v (ListAppend a b) = ListAppend a' b' - where - a' = shift d v a - b' = shift d v b -shift _ _ ListFold = ListFold -shift _ _ ListLength = ListLength -shift _ _ ListHead = ListHead -shift _ _ ListLast = ListLast -shift _ _ ListIndexed = ListIndexed -shift _ _ ListReverse = ListReverse -shift _ _ Optional = Optional -shift d v (Some a) = Some a' - where - a' = shift d v a -shift _ _ None = None -shift _ _ OptionalFold = OptionalFold -shift _ _ OptionalBuild = OptionalBuild -shift d v (Record a) = Record a' - where - a' = fmap (shift d v) a -shift d v (RecordLit a) = RecordLit a' - where - a' = fmap (shift d v) a -shift d v (Union a) = Union a' - where - a' = fmap (fmap (shift d v)) a -shift d v (Combine a b) = Combine a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (CombineTypes a b) = CombineTypes a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (Prefer a b) = Prefer a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (RecordCompletion a b) = RecordCompletion a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (Merge a b c) = Merge a' b' c' - where - a' = shift d v a - b' = shift d v b - c' = fmap (shift d v) c -shift d v (ToMap a b) = ToMap a' b' - where - a' = shift d v a - b' = fmap (shift d v) b -shift d v (Field a b) = Field a' b - where - a' = shift d v a -shift d v (Assert a) = Assert a' - where - a' = shift d v a -shift d v (Equivalent a b) = Equivalent a' b' - where - a' = shift d v a - b' = shift d v b -shift d v (Project a b) = Project a' b' - where - a' = shift d v a - b' = fmap (shift d v) b -shift d v (Note a b) = Note a b' - where - b' = shift d v b -shift d v (ImportAlt a b) = ImportAlt a' b' - where - a' = shift d v a - b' = shift d v b --- The Dhall compiler enforces that all embedded values are closed expressions --- and `shift` does nothing to a closed expression -shift _ _ (Embed p) = Embed p - -{-| Substitute all occurrences of a variable with an expression - -> subst x C B ~ B[x := C] --} -subst :: Var -> Expr s a -> Expr s a -> Expr s a -subst _ _ (Const a) = Const a -subst (V x n) e (Lam y _A b) = Lam y _A' b' - where - _A' = subst (V x n ) e _A - b' = subst (V x n') (shift 1 (V y 0) e) b - n' = if x == y then n + 1 else n -subst (V x n) e (Pi y _A _B) = Pi y _A' _B' - where - _A' = subst (V x n ) e _A - _B' = subst (V x n') (shift 1 (V y 0) e) _B - n' = if x == y then n + 1 else n -subst v e (App f a) = App f' a' - where - f' = subst v e f - a' = subst v e a -subst v e (Var v') = if v == v' then e else Var v' -subst (V x n) e (Let (Binding src0 f src1 mt src2 r) b) = - Let (Binding src0 f src1 mt' src2 r') b' - where - b' = subst (V x n') (shift 1 (V f 0) e) b - where - n' = if x == f then n + 1 else n - - mt' = fmap (fmap (subst (V x n) e)) mt - r' = subst (V x n) e r -subst x e (Annot a b) = Annot a' b' - where - a' = subst x e a - b' = subst x e b -subst _ _ Bool = Bool -subst _ _ (BoolLit a) = BoolLit a -subst x e (BoolAnd a b) = BoolAnd a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (BoolOr a b) = BoolOr a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (BoolEQ a b) = BoolEQ a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (BoolNE a b) = BoolNE a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (BoolIf a b c) = BoolIf a' b' c' - where - a' = subst x e a - b' = subst x e b - c' = subst x e c -subst _ _ Natural = Natural -subst _ _ (NaturalLit a) = NaturalLit a -subst _ _ NaturalFold = NaturalFold -subst _ _ NaturalBuild = NaturalBuild -subst _ _ NaturalIsZero = NaturalIsZero -subst _ _ NaturalEven = NaturalEven -subst _ _ NaturalOdd = NaturalOdd -subst _ _ NaturalToInteger = NaturalToInteger -subst _ _ NaturalShow = NaturalShow -subst _ _ NaturalSubtract = NaturalSubtract -subst x e (NaturalPlus a b) = NaturalPlus a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (NaturalTimes a b) = NaturalTimes a' b' - where - a' = subst x e a - b' = subst x e b -subst _ _ Integer = Integer -subst _ _ (IntegerLit a) = IntegerLit a -subst _ _ IntegerShow = IntegerShow -subst _ _ IntegerToDouble = IntegerToDouble -subst _ _ Double = Double -subst _ _ (DoubleLit a) = DoubleLit a -subst _ _ DoubleShow = DoubleShow -subst _ _ Text = Text -subst x e (TextLit (Chunks a b)) = TextLit (Chunks a' b) - where - a' = fmap (fmap (subst x e)) a -subst x e (TextAppend a b) = TextAppend a' b' - where - a' = subst x e a - b' = subst x e b -subst _ _ TextShow = TextShow -subst _ _ List = List -subst x e (ListLit a b) = ListLit a' b' - where - a' = fmap (subst x e) a - b' = fmap (subst x e) b -subst x e (ListAppend a b) = ListAppend a' b' - where - a' = subst x e a - b' = subst x e b -subst _ _ ListBuild = ListBuild -subst _ _ ListFold = ListFold -subst _ _ ListLength = ListLength -subst _ _ ListHead = ListHead -subst _ _ ListLast = ListLast -subst _ _ ListIndexed = ListIndexed -subst _ _ ListReverse = ListReverse -subst _ _ Optional = Optional -subst x e (Some a) = Some a' - where - a' = subst x e a -subst _ _ None = None -subst _ _ OptionalFold = OptionalFold -subst _ _ OptionalBuild = OptionalBuild -subst x e (Record kts) = Record kts' - where - kts' = fmap (subst x e) kts -subst x e (RecordLit kvs) = RecordLit kvs' - where - kvs' = fmap (subst x e) kvs -subst x e (Union kts) = Union kts' - where - kts' = fmap (fmap (subst x e)) kts -subst x e (Combine a b) = Combine a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (CombineTypes a b) = CombineTypes a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (Prefer a b) = Prefer a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (RecordCompletion a b) = RecordCompletion a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (Merge a b c) = Merge a' b' c' - where - a' = subst x e a - b' = subst x e b - c' = fmap (subst x e) c -subst x e (ToMap a b) = ToMap a' b' - where - a' = subst x e a - b' = fmap (subst x e) b -subst x e (Field a b) = Field a' b - where - a' = subst x e a -subst x e (Project a b) = Project a' b' - where - a' = subst x e a - b' = fmap (subst x e) b -subst x e (Assert a) = Assert a' - where - a' = subst x e a -subst x e (Equivalent a b) = Equivalent a' b' - where - a' = subst x e a - b' = subst x e b -subst x e (Note a b) = Note a b' - where - b' = subst x e b -subst x e (ImportAlt a b) = ImportAlt a' b' - where - a' = subst x e a - b' = subst x e b --- The Dhall compiler enforces that all embedded values are closed expressions --- and `subst` does nothing to a closed expression -subst _ _ (Embed p) = Embed p - -{-| This function is used to determine whether folds like @Natural/fold@ or - @List/fold@ should be lazy or strict in their accumulator based on the type - of the accumulator - - If this function returns `True`, then they will be strict in their - accumulator since we can guarantee an upper bound on the amount of work to - normalize the accumulator on each step of the loop. If this function - returns `False` then they will be lazy in their accumulator and only - normalize the final result at the end of the fold --} -boundedType :: Expr s a -> Bool -boundedType Bool = True -boundedType Natural = True -boundedType Integer = True -boundedType Double = True -boundedType Text = True -boundedType (App List _) = False -boundedType (App Optional t) = boundedType t -boundedType (Record kvs) = all boundedType kvs -boundedType (Union kvs) = all (all boundedType) kvs -boundedType _ = False - -{-| α-normalize an expression by renaming all bound variables to @\"_\"@ and - using De Bruijn indices to distinguish them - ->>> alphaNormalize (Lam "a" (Const Type) (Lam "b" (Const Type) (Lam "x" "a" (Lam "y" "b" "x")))) -Lam "_" (Const Type) (Lam "_" (Const Type) (Lam "_" (Var (V "_" 1)) (Lam "_" (Var (V "_" 1)) (Var (V "_" 1))))) - - α-normalization does not affect free variables: - ->>> alphaNormalize "x" -Var (V "x" 0) - --} -alphaNormalize :: Expr s a -> Expr s a -alphaNormalize = Eval.alphaNormalize -{-# INLINE alphaNormalize #-} - -{-| Reduce an expression to its normal form, performing beta reduction - - `normalize` does not type-check the expression. You may want to type-check - expressions before normalizing them since normalization can convert an - ill-typed expression into a well-typed expression. - - `normalize` can also fail with `error` if you normalize an ill-typed - expression --} -normalize :: Eq a => Expr s a -> Expr t a -normalize = Eval.normalize -{-# INLINE normalize #-} - -{-| Reduce an expression to its normal form, performing beta reduction and applying - any custom definitions. - - `normalizeWith` is designed to be used with function `typeWith`. The `typeWith` - function allows typing of Dhall functions in a custom typing context whereas - `normalizeWith` allows evaluating Dhall expressions in a custom context. - - To be more precise `normalizeWith` applies the given normalizer when it finds an - application term that it cannot reduce by other means. - - Note that the context used in normalization will determine the properties of normalization. - That is, if the functions in custom context are not total then the Dhall language, evaluated - with those functions is not total either. - - `normalizeWith` can fail with an `error` if you normalize an ill-typed - expression --} -normalizeWith :: Eq a => Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a -normalizeWith (Just ctx) t = runIdentity (normalizeWithM (getReifiedNormalizer ctx) t) -normalizeWith _ t = Eval.normalize t - -{-| This function generalizes `normalizeWith` by allowing the custom normalizer - to use an arbitrary `Monad` - - `normalizeWithM` can fail with an `error` if you normalize an ill-typed - expression --} -normalizeWithM - :: (Monad m, Eq a) => NormalizerM m a -> Expr s a -> m (Expr t a) -normalizeWithM ctx e0 = loop (denote e0) - where - loop e = case e of - Const k -> pure (Const k) - Var v -> pure (Var v) - Lam x _A b -> Lam x <$> _A' <*> b' - where - _A' = loop _A - b' = loop b - Pi x _A _B -> Pi x <$> _A' <*> _B' - where - _A' = loop _A - _B' = loop _B - App f a -> do - res <- ctx (App f a) - case res of - Just e1 -> loop e1 - Nothing -> do - f' <- loop f - a' <- loop a - case f' of - Lam x _A b₀ -> do - - let a₂ = shift 1 (V x 0) a' - let b₁ = subst (V x 0) a₂ b₀ - let b₂ = shift (-1) (V x 0) b₁ - - loop b₂ - _ -> do - case App f' a' of - -- build/fold fusion for `List` - App (App ListBuild _) (App (App ListFold _) e') -> loop e' - - App NaturalFold (NaturalLit n) -> do - let natural = Var (V "natural" 0) - let go 0 x = x - go n' x = go (n'-1) (App (Var (V "succ" 0)) x) - let n' = go n (Var (V "zero" 0)) - pure - (Lam "natural" - (Const Type) - (Lam "succ" - (Pi "_" natural natural) - (Lam "zero" - natural - n'))) - - -- build/fold fusion for `Natural` - App NaturalBuild (App NaturalFold e') -> loop e' - - -- build/fold fusion for `Optional` - App (App OptionalBuild _) (App (App OptionalFold _) e') -> loop e' - - App (App (App (App NaturalFold (NaturalLit n0)) t) succ') zero -> do - t' <- loop t - if boundedType t' then strict else lazy - where - strict = strictLoop (fromIntegral n0 :: Integer) - lazy = loop ( lazyLoop (fromIntegral n0 :: Integer)) - - strictLoop !0 = loop zero - strictLoop !n = App succ' <$> strictLoop (n - 1) >>= loop - - lazyLoop !0 = zero - lazyLoop !n = App succ' (lazyLoop (n - 1)) - App NaturalBuild g -> loop (App (App (App g Natural) succ) zero) - where - succ = Lam "n" Natural (NaturalPlus "n" (NaturalLit 1)) - - zero = NaturalLit 0 - App NaturalIsZero (NaturalLit n) -> pure (BoolLit (n == 0)) - App NaturalEven (NaturalLit n) -> pure (BoolLit (even n)) - App NaturalOdd (NaturalLit n) -> pure (BoolLit (odd n)) - App NaturalToInteger (NaturalLit n) -> pure (IntegerLit (toInteger n)) - App NaturalShow (NaturalLit n) -> - pure (TextLit (Chunks [] (Data.Text.pack (show n)))) - App (App NaturalSubtract (NaturalLit x)) (NaturalLit y) - | y >= x -> pure (NaturalLit (subtract x y)) - | otherwise -> pure (NaturalLit 0) - App (App NaturalSubtract (NaturalLit 0)) y -> pure y - App (App NaturalSubtract _) (NaturalLit 0) -> pure (NaturalLit 0) - App (App NaturalSubtract x) y | Eval.judgmentallyEqual x y -> pure (NaturalLit 0) - App IntegerShow (IntegerLit n) - | 0 <= n -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n)))) - | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n)))) - -- `(read . show)` is used instead of `fromInteger` because `read` uses - -- the correct rounding rule. - -- See https://gitlab.haskell.org/ghc/ghc/issues/17231. - App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n)) - App DoubleShow (DoubleLit (DhallDouble n)) -> - pure (TextLit (Chunks [] (Data.Text.pack (show n)))) - App (App OptionalBuild _A₀) g -> - loop (App (App (App g optional) just) nothing) - where - optional = App Optional _A₀ - - just = Lam "a" _A₀ (Some "a") - - nothing = App None _A₀ - App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil) - where - _A₁ = shift 1 "a" _A₀ - - list = App List _A₀ - - cons = - Lam "a" _A₀ - (Lam "as" - (App List _A₁) - (ListAppend (ListLit Nothing (pure "a")) "as") - ) - - nil = ListLit (Just (App List _A₀)) empty - App (App ListFold t) (ListLit _ xs) -> do - t' <- loop t - let list = Var (V "list" 0) - let lam term = - Lam "list" (Const Type) - (Lam "cons" (Pi "_" t' (Pi "_" list list)) - (Lam "nil" list term)) - term <- foldrM - (\x acc -> do - x' <- loop x - pure (App (App (Var (V "cons" 0)) x') acc)) - (Var (V "nil" 0)) - xs - pure (lam term) - App (App (App (App (App ListFold _) (ListLit _ xs)) t) cons) nil -> do - t' <- loop t - if boundedType t' then strict else lazy - where - strict = foldr strictCons strictNil xs - lazy = loop (foldr lazyCons lazyNil xs) - - strictNil = loop nil - lazyNil = nil - - strictCons y ys = do - App (App cons y) <$> ys >>= loop - lazyCons y ys = App (App cons y) ys - App (App ListLength _) (ListLit _ ys) -> - pure (NaturalLit (fromIntegral (Data.Sequence.length ys))) - App (App ListHead t) (ListLit _ ys) -> loop o - where - o = case Data.Sequence.viewl ys of - y :< _ -> Some y - _ -> App None t - App (App ListLast t) (ListLit _ ys) -> loop o - where - o = case Data.Sequence.viewr ys of - _ :> y -> Some y - _ -> App None t - App (App ListIndexed _A₀) (ListLit _ as₀) -> loop (ListLit t as₁) - where - as₁ = Data.Sequence.mapWithIndex adapt as₀ - - _A₂ = Record (Dhall.Map.fromList kts) - where - kts = [ ("index", Natural) - , ("value", _A₀) - ] - - t | null as₀ = Just (App List _A₂) - | otherwise = Nothing - - adapt n a_ = - RecordLit (Dhall.Map.fromList kvs) - where - kvs = [ ("index", NaturalLit (fromIntegral n)) - , ("value", a_) - ] - App (App ListReverse _) (ListLit t xs) -> - loop (ListLit t (Data.Sequence.reverse xs)) - - App (App OptionalFold t0) x0 -> do - t1 <- loop t0 - let optional = Var (V "optional" 0) - let lam term = (Lam "optional" - (Const Type) - (Lam "some" - (Pi "_" t1 optional) - (Lam "none" optional term))) - x1 <- loop x0 - pure $ case x1 of - App None _ -> lam (Var (V "none" 0)) - Some x' -> lam (App (Var (V "some" 0)) x') - _ -> App (App OptionalFold t1) x1 - - App TextShow (TextLit (Chunks [] oldText)) -> - loop (TextLit (Chunks [] newText)) - where - newText = Eval.textShow oldText - _ -> do - res2 <- ctx (App f' a') - case res2 of - Nothing -> pure (App f' a') - Just app' -> loop app' - Let (Binding _ f _ _ _ r) b -> loop b'' - where - r' = shift 1 (V f 0) r - b' = subst (V f 0) r' b - b'' = shift (-1) (V f 0) b' - Annot x _ -> loop x - Bool -> pure Bool - BoolLit b -> pure (BoolLit b) - BoolAnd x y -> decide <$> loop x <*> loop y - where - decide (BoolLit True ) r = r - decide (BoolLit False) _ = BoolLit False - decide l (BoolLit True ) = l - decide _ (BoolLit False) = BoolLit False - decide l r - | Eval.judgmentallyEqual l r = l - | otherwise = BoolAnd l r - BoolOr x y -> decide <$> loop x <*> loop y - where - decide (BoolLit False) r = r - decide (BoolLit True ) _ = BoolLit True - decide l (BoolLit False) = l - decide _ (BoolLit True ) = BoolLit True - decide l r - | Eval.judgmentallyEqual l r = l - | otherwise = BoolOr l r - BoolEQ x y -> decide <$> loop x <*> loop y - where - decide (BoolLit True ) r = r - decide l (BoolLit True ) = l - decide l r - | Eval.judgmentallyEqual l r = BoolLit True - | otherwise = BoolEQ l r - BoolNE x y -> decide <$> loop x <*> loop y - where - decide (BoolLit False) r = r - decide l (BoolLit False) = l - decide l r - | Eval.judgmentallyEqual l r = BoolLit False - | otherwise = BoolNE l r - BoolIf bool true false -> decide <$> loop bool <*> loop true <*> loop false - where - decide (BoolLit True ) l _ = l - decide (BoolLit False) _ r = r - decide b (BoolLit True) (BoolLit False) = b - decide b l r - | Eval.judgmentallyEqual l r = l - | otherwise = BoolIf b l r - Natural -> pure Natural - NaturalLit n -> pure (NaturalLit n) - NaturalFold -> pure NaturalFold - NaturalBuild -> pure NaturalBuild - NaturalIsZero -> pure NaturalIsZero - NaturalEven -> pure NaturalEven - NaturalOdd -> pure NaturalOdd - NaturalToInteger -> pure NaturalToInteger - NaturalShow -> pure NaturalShow - NaturalSubtract -> pure NaturalSubtract - NaturalPlus x y -> decide <$> loop x <*> loop y - where - decide (NaturalLit 0) r = r - decide l (NaturalLit 0) = l - decide (NaturalLit m) (NaturalLit n) = NaturalLit (m + n) - decide l r = NaturalPlus l r - NaturalTimes x y -> decide <$> loop x <*> loop y - where - decide (NaturalLit 1) r = r - decide l (NaturalLit 1) = l - decide (NaturalLit 0) _ = NaturalLit 0 - decide _ (NaturalLit 0) = NaturalLit 0 - decide (NaturalLit m) (NaturalLit n) = NaturalLit (m * n) - decide l r = NaturalTimes l r - Integer -> pure Integer - IntegerLit n -> pure (IntegerLit n) - IntegerShow -> pure IntegerShow - IntegerToDouble -> pure IntegerToDouble - Double -> pure Double - DoubleLit n -> pure (DoubleLit n) - DoubleShow -> pure DoubleShow - Text -> pure Text - TextLit (Chunks xys z) -> do - chunks' <- mconcat <$> chunks - case chunks' of - Chunks [("", x)] "" -> pure x - c -> pure (TextLit c) - where - chunks = - ((++ [Chunks [] z]) . concat) <$> traverse process xys - - process (x, y) = do - y' <- loop y - case y' of - TextLit c -> pure [Chunks [] x, c] - _ -> pure [Chunks [(x, y')] mempty] - TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] "")) - TextShow -> pure TextShow - List -> pure List - ListLit t es - | Data.Sequence.null es -> ListLit <$> t' <*> pure Data.Sequence.empty - | otherwise -> ListLit Nothing <$> es' - where - t' = traverse loop t - es' = traverse loop es - ListAppend x y -> decide <$> loop x <*> loop y - where - decide (ListLit _ m) r | Data.Sequence.null m = r - decide l (ListLit _ n) | Data.Sequence.null n = l - decide (ListLit t m) (ListLit _ n) = ListLit t (m <> n) - decide l r = ListAppend l r - ListBuild -> pure ListBuild - ListFold -> pure ListFold - ListLength -> pure ListLength - ListHead -> pure ListHead - ListLast -> pure ListLast - ListIndexed -> pure ListIndexed - ListReverse -> pure ListReverse - Optional -> pure Optional - Some a -> Some <$> a' - where - a' = loop a - None -> pure None - OptionalFold -> pure OptionalFold - OptionalBuild -> pure OptionalBuild - Record kts -> Record . Dhall.Map.sort <$> kts' - where - kts' = traverse loop kts - RecordLit kvs -> RecordLit . Dhall.Map.sort <$> kvs' - where - kvs' = traverse loop kvs - Union kts -> Union . Dhall.Map.sort <$> kts' - where - kts' = traverse (traverse loop) kts - Combine x y -> decide <$> loop x <*> loop y - where - decide (RecordLit m) r | Data.Foldable.null m = - r - decide l (RecordLit n) | Data.Foldable.null n = - l - decide (RecordLit m) (RecordLit n) = - RecordLit (Dhall.Map.unionWith decide m n) - decide l r = - Combine l r - CombineTypes x y -> decide <$> loop x <*> loop y - where - decide (Record m) r | Data.Foldable.null m = - r - decide l (Record n) | Data.Foldable.null n = - l - decide (Record m) (Record n) = - Record (Dhall.Map.unionWith decide m n) - decide l r = - CombineTypes l r - Prefer x y -> decide <$> loop x <*> loop y - where - decide (RecordLit m) r | Data.Foldable.null m = - r - decide l (RecordLit n) | Data.Foldable.null n = - l - decide (RecordLit m) (RecordLit n) = - RecordLit (Dhall.Map.union n m) - decide l r | Eval.judgmentallyEqual l r = - l - decide l r = - Prefer l r - RecordCompletion x y -> do - loop (Annot (Prefer (Field x "default") y) (Field x "Type")) - Merge x y t -> do - x' <- loop x - y' <- loop y - case x' of - RecordLit kvsX -> - case y' of - Field (Union ktsY) kY -> - case Dhall.Map.lookup kY ktsY of - Just Nothing -> - case Dhall.Map.lookup kY kvsX of - Just vX -> return vX - Nothing -> Merge x' y' <$> t' - _ -> - Merge x' y' <$> t' - App (Field (Union ktsY) kY) vY -> - case Dhall.Map.lookup kY ktsY of - Just (Just _) -> - case Dhall.Map.lookup kY kvsX of - Just vX -> loop (App vX vY) - Nothing -> Merge x' y' <$> t' - _ -> - Merge x' y' <$> t' - _ -> Merge x' y' <$> t' - _ -> Merge x' y' <$> t' - where - t' = traverse loop t - ToMap x t -> do - x' <- loop x - t' <- traverse loop t - case x' of - RecordLit kvsX -> do - let entry (key, value) = - RecordLit - (Dhall.Map.fromList - [ ("mapKey" , TextLit (Chunks [] key)) - , ("mapValue", value ) - ] - ) - - let keyValues = Data.Sequence.fromList (map entry (Dhall.Map.toList kvsX)) - - let listType = case t' of - Just _ | null keyValues -> - t' - _ -> - Nothing - - return (ListLit listType keyValues) - _ -> do - return (ToMap x' t') - Field r x -> do - let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v) - - r' <- loop r - case r' of - RecordLit kvs -> - case Dhall.Map.lookup x kvs of - Just v -> pure v - Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x - Project r_ _ -> loop (Field r_ x) - Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x) - Nothing -> loop (Field r_ x) - Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of - Just v -> pure v - Nothing -> loop (Field l x) - Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Combine (singletonRecordLit v) r_) x) - Nothing -> loop (Field r_ x) - Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Combine l (singletonRecordLit v)) x) - Nothing -> loop (Field l x) - _ -> pure (Field r' x) - Project x (Left fields)-> do - x' <- loop x - let fieldsSet = Dhall.Set.toSet fields - case x' of - RecordLit kvs -> - pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet)) - Project y _ -> - loop (Project y (Left fields)) - Prefer l (RecordLit rKvs) -> do - let rKs = Dhall.Map.keysSet rKvs - let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs))) - let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet) - loop (Prefer l' r') - _ | null fields -> pure (RecordLit mempty) - | otherwise -> pure (Project x' (Left (Dhall.Set.sort fields))) - Project r (Right e1) -> do - e2 <- loop e1 - - case e2 of - Record kts -> do - loop (Project r (Left (Dhall.Set.fromSet (Dhall.Map.keysSet kts)))) - _ -> do - r' <- loop r - pure (Project r' (Right e2)) - Assert t -> do - t' <- loop t - - pure (Assert t') - Equivalent l r -> do - l' <- loop l - r' <- loop r - - pure (Equivalent l' r') - Note _ e' -> loop e' - ImportAlt l _r -> loop l - Embed a -> pure (Embed a) - --- | Use this to wrap you embedded functions (see `normalizeWith`) to make them --- polymorphic enough to be used. -type NormalizerM m a = forall s. Expr s a -> m (Maybe (Expr s a)) - --- | An variation on `NormalizerM` for pure normalizers -type Normalizer a = NormalizerM Identity a - --- | A reified 'Normalizer', which can be stored in structures without --- running into impredicative polymorphism. -newtype ReifiedNormalizer a = ReifiedNormalizer - { getReifiedNormalizer :: Normalizer a } - --- | Check if an expression is in a normal form given a context of evaluation. --- Unlike `isNormalized`, this will fully normalize and traverse through the expression. --- --- It is much more efficient to use `isNormalized`. --- --- `isNormalizedWith` can fail with an `error` if you check an ill-typed --- expression -isNormalizedWith :: (Eq s, Eq a) => Normalizer a -> Expr s a -> Bool -isNormalizedWith ctx e = e == normalizeWith (Just (ReifiedNormalizer ctx)) e - --- | Quickly check if an expression is in normal form --- --- Given a well-typed expression @e@, @'isNormalized' e@ is equivalent to --- @e == 'normalize' e@. --- --- Given an ill-typed expression, 'isNormalized' may fail with an error, or --- evaluate to either False or True! -isNormalized :: Eq a => Expr s a -> Bool -isNormalized e0 = loop (denote e0) - where - loop e = case e of - Const _ -> True - Var _ -> True - Lam _ a b -> loop a && loop b - Pi _ a b -> loop a && loop b - App f a -> loop f && loop a && case App f a of - App (Lam _ _ _) _ -> False - - -- build/fold fusion for `List` - App (App ListBuild _) (App (App ListFold _) _) -> False - - -- build/fold fusion for `Natural` - App NaturalBuild (App NaturalFold _) -> False - - -- build/fold fusion for `Optional` - App (App OptionalBuild _) (App (App OptionalFold _) _) -> False - - App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False - App NaturalFold (NaturalLit _) -> False - App NaturalBuild _ -> False - App NaturalIsZero (NaturalLit _) -> False - App NaturalEven (NaturalLit _) -> False - App NaturalOdd (NaturalLit _) -> False - App NaturalShow (NaturalLit _) -> False - App (App NaturalSubtract (NaturalLit _)) (NaturalLit _) -> False - App (App NaturalSubtract (NaturalLit 0)) _ -> False - App (App NaturalSubtract _) (NaturalLit 0) -> False - App (App NaturalSubtract x) y -> not (Eval.judgmentallyEqual x y) - App NaturalToInteger (NaturalLit _) -> False - App IntegerShow (IntegerLit _) -> False - App IntegerToDouble (IntegerLit _) -> False - App DoubleShow (DoubleLit _) -> False - App (App OptionalBuild _) _ -> False - App (App ListBuild _) _ -> False - App (App ListFold _) (ListLit _ _) -> False - App (App ListLength _) (ListLit _ _) -> False - App (App ListHead _) (ListLit _ _) -> False - App (App ListLast _) (ListLit _ _) -> False - App (App ListIndexed _) (ListLit _ _) -> False - App (App ListReverse _) (ListLit _ _) -> False - App (App OptionalFold _) (Some _) -> False - App (App OptionalFold _) (App None _) -> False - App TextShow (TextLit (Chunks [] _)) -> - False - _ -> True - Let _ _ -> False - Annot _ _ -> False - Bool -> True - BoolLit _ -> True - BoolAnd x y -> loop x && loop y && decide x y - where - decide (BoolLit _) _ = False - decide _ (BoolLit _) = False - decide l r = not (Eval.judgmentallyEqual l r) - BoolOr x y -> loop x && loop y && decide x y - where - decide (BoolLit _) _ = False - decide _ (BoolLit _) = False - decide l r = not (Eval.judgmentallyEqual l r) - BoolEQ x y -> loop x && loop y && decide x y - where - decide (BoolLit True) _ = False - decide _ (BoolLit True) = False - decide l r = not (Eval.judgmentallyEqual l r) - BoolNE x y -> loop x && loop y && decide x y - where - decide (BoolLit False) _ = False - decide _ (BoolLit False ) = False - decide l r = not (Eval.judgmentallyEqual l r) - BoolIf x y z -> - loop x && loop y && loop z && decide x y z - where - decide (BoolLit _) _ _ = False - decide _ (BoolLit True) (BoolLit False) = False - decide _ l r = not (Eval.judgmentallyEqual l r) - Natural -> True - NaturalLit _ -> True - NaturalFold -> True - NaturalBuild -> True - NaturalIsZero -> True - NaturalEven -> True - NaturalOdd -> True - NaturalShow -> True - NaturalSubtract -> True - NaturalToInteger -> True - NaturalPlus x y -> loop x && loop y && decide x y - where - decide (NaturalLit 0) _ = False - decide _ (NaturalLit 0) = False - decide (NaturalLit _) (NaturalLit _) = False - decide _ _ = True - NaturalTimes x y -> loop x && loop y && decide x y - where - decide (NaturalLit 0) _ = False - decide _ (NaturalLit 0) = False - decide (NaturalLit 1) _ = False - decide _ (NaturalLit 1) = False - decide (NaturalLit _) (NaturalLit _) = False - decide _ _ = True - Integer -> True - IntegerLit _ -> True - IntegerShow -> True - IntegerToDouble -> True - Double -> True - DoubleLit _ -> True - DoubleShow -> True - Text -> True - TextLit (Chunks [("", _)] "") -> False - TextLit (Chunks xys _) -> all (all check) xys - where - check y = loop y && case y of - TextLit _ -> False - _ -> True - TextAppend _ _ -> False - TextShow -> True - List -> True - ListLit t es -> all loop t && all loop es - ListAppend x y -> loop x && loop y && decide x y - where - decide (ListLit _ m) _ | Data.Sequence.null m = False - decide _ (ListLit _ n) | Data.Sequence.null n = False - decide (ListLit _ _) (ListLit _ _) = False - decide _ _ = True - ListBuild -> True - ListFold -> True - ListLength -> True - ListHead -> True - ListLast -> True - ListIndexed -> True - ListReverse -> True - Optional -> True - Some a -> loop a - None -> True - OptionalFold -> True - OptionalBuild -> True - Record kts -> Dhall.Map.isSorted kts && all loop kts - RecordLit kvs -> Dhall.Map.isSorted kvs && all loop kvs - Union kts -> Dhall.Map.isSorted kts && all (all loop) kts - Combine x y -> loop x && loop y && decide x y - where - decide (RecordLit m) _ | Data.Foldable.null m = False - decide _ (RecordLit n) | Data.Foldable.null n = False - decide (RecordLit _) (RecordLit _) = False - decide _ _ = True - CombineTypes x y -> loop x && loop y && decide x y - where - decide (Record m) _ | Data.Foldable.null m = False - decide _ (Record n) | Data.Foldable.null n = False - decide (Record _) (Record _) = False - decide _ _ = True - Prefer x y -> loop x && loop y && decide x y - where - decide (RecordLit m) _ | Data.Foldable.null m = False - decide _ (RecordLit n) | Data.Foldable.null n = False - 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 - ToMap x t -> case x of - RecordLit _ -> False - _ -> loop x && all loop t - Field r k -> case r of - RecordLit _ -> False - Project _ _ -> False - Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r - Prefer _ (RecordLit _) -> False - Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r - Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r - _ -> loop r - Project r p -> loop r && - case p of - Left s -> case r of - RecordLit _ -> False - Project _ _ -> False - Prefer _ (RecordLit _) -> False - _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s - Right e' -> case e' of - Record _ -> False - _ -> loop e' - Assert t -> loop t - Equivalent l r -> loop l && loop r - Note _ e' -> loop e' - ImportAlt _ _ -> False - Embed _ -> True - -{-| Detect if the given variable is free within the given expression - ->>> "x" `freeIn` "x" -True ->>> "x" `freeIn` "y" -False ->>> "x" `freeIn` Lam "x" (Const Type) "x" -False --} -freeIn :: Eq a => Var -> Expr s a -> Bool -variable@(V var i) `freeIn` expression = - Dhall.Core.subst variable (Var (V var (i + 1))) strippedExpression - /= strippedExpression - where - denote' :: Expr t b -> Expr () b - denote' = denote - - strippedExpression = denote' expression +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +{-| This module contains the core calculus for the Dhall language. + + Dhall is essentially a fork of the @morte@ compiler but with more built-in + functionality, better error messages, and Haskell integration +-} + +module Dhall.Core ( + -- * Syntax + Const(..) + , Directory(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportMode(..) + , ImportType(..) + , URL(..) + , Scheme(..) + , DhallDouble(..) + , Var(..) + , Binding(..) + , makeBinding + , Chunks(..) + , Expr(..) + + -- * Normalization + , alphaNormalize + , normalize + , normalizeWith + , normalizeWithM + , Normalizer + , NormalizerM + , ReifiedNormalizer (..) + , judgmentallyEqual + , subst + , shift + , isNormalized + , isNormalizedWith + , denote + , renote + , shallowDenote + , freeIn + + -- * Pretty-printing + , pretty + + -- * Optics + , subExpressions + , chunkExprs + , bindingExprs + + -- * Let-blocks + , multiLet + , wrapInLets + , MultiLet(..) + + -- * Miscellaneous + , internalError + , reservedIdentifiers + , escapeText + , pathCharacter + , throws + , Eval.textShow + , censorExpression + , censorText + ) where + +import Control.Exception (Exception) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty) +import Dhall.Normalize +import Dhall.Src (Src(..)) +import Dhall.Syntax +import Dhall.Pretty.Internal +import Instances.TH.Lift () +import Lens.Family (over) +import Prelude hiding (succ) + +import qualified Control.Exception +import qualified Dhall.Eval as Eval +import qualified Data.Text -- | Pretty-print a value pretty :: Pretty a => a -> Text diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -25,8 +25,7 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void) -import Dhall.Core (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..)) -import Dhall.Binary (ToTerm) +import Dhall.Syntax (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..)) import Dhall.Map (Map) import Dhall.Set (Set) import Dhall.Pretty.Internal (Ann) @@ -37,7 +36,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Dhall.Core +import qualified Dhall.Normalize import qualified Dhall.Map import qualified Dhall.Set import qualified Dhall.Pretty.Internal as Internal @@ -156,11 +155,11 @@ rparen = token Internal.rparen -- | Render the difference between the normal form of two expressions -diffNormalized :: (Eq a, Pretty a, ToTerm a) => Expr s a -> Expr s a -> Diff +diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff diffNormalized l0 r0 = Dhall.Diff.diff l1 r1 where - l1 = Dhall.Core.alphaNormalize (Dhall.Core.normalize l0) - r1 = Dhall.Core.alphaNormalize (Dhall.Core.normalize r0) + l1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize l0) + r1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize r0) diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff diffPrimitive f l r @@ -362,15 +361,23 @@ diffList :: (Eq a, Pretty a) => Seq (Expr Void a) -> Seq (Expr Void a) -> Diff -diffList l r = bracketed (foldMap diffPart parts) +diffList l r = bracketed (loop parts₀) where -- Sections of the list that are only in left, only in right, or in both - parts = - Algo.Diff.getGroupedDiffBy ((same .) . diff) (toList l) (toList r) + parts₀ = Algo.Diff.getGroupedDiffBy equal (toList l) (toList r) + equal a b = same (diff a b) + -- Render each element of a list using an extra rendering function f prettyElems f = map (f . token . Internal.prettyExpr) + loop [] = + mempty + loop (Algo.Diff.First as : Algo.Diff.Second bs : parts) + | length as == length bs = zipWith diff as bs <> loop parts + loop (part : parts) = + diffPart part <> loop parts + diffPart part = case part of -- Only present in left @@ -1136,6 +1143,18 @@ diffPrimitiveExpression l@Integer r = mismatch l r diffPrimitiveExpression l r@Integer = + mismatch l r +diffPrimitiveExpression IntegerClamp IntegerClamp = + "…" +diffPrimitiveExpression l@IntegerClamp r = + mismatch l r +diffPrimitiveExpression l r@IntegerClamp = + mismatch l r +diffPrimitiveExpression IntegerNegate IntegerNegate = + "…" +diffPrimitiveExpression l@IntegerNegate r = + mismatch l r +diffPrimitiveExpression l r@IntegerNegate = mismatch l r diffPrimitiveExpression IntegerShow IntegerShow = "…" diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -133,15 +133,6 @@ -- ^ Don't store any information | Typed !Text (Val a) -- ^ Store the original name and type of the variable bound by the `Lam` - | NaturalFoldCl (Val a) - -- ^ The original function was a @Natural/fold@. We need to preserve this - -- information in order to implement @Natural/{build,fold}@ fusion - | ListFoldCl (Val a) - -- ^ The original function was a @List/fold@. We need to preserve this - -- information in order to implement @List/{build,fold}@ fusion - | OptionalFoldCl (Val a) - -- ^ The original function was an @Optional/fold@. We need to preserve this - -- information in order to implement @Optional/{build,fold}@ fusion | NaturalSubtractZero -- ^ The original function was a @Natural/subtract 0@. We need to preserve -- this information in case the @Natural/subtract@ ends up not being fully @@ -192,6 +183,8 @@ | VInteger | VIntegerLit !Integer + | VIntegerClamp !(Val a) + | VIntegerNegate !(Val a) | VIntegerShow !(Val a) | VIntegerToDouble !(Val a) @@ -468,14 +461,12 @@ go acc m = go (vApp succ acc) (m - 1) in go zero (fromIntegral n :: Integer) n -> - VHLam (NaturalFoldCl n) $ \natural -> + VPrim $ \natural -> VPrim $ \succ -> VPrim $ \zero -> VNaturalFold n natural succ zero NaturalBuild -> VPrim $ \case - VHLam (NaturalFoldCl x) _ -> - x VPrimVar -> VNaturalBuild VPrimVar t -> t @@ -526,6 +517,16 @@ VInteger IntegerLit n -> VIntegerLit n + IntegerClamp -> + VPrim $ \case + VIntegerLit n + | 0 <= n -> VNaturalLit (fromInteger n) + | otherwise -> VNaturalLit 0 + n -> VIntegerClamp n + IntegerNegate -> + VPrim $ \case + VIntegerLit n -> VIntegerLit (negate n) + n -> VIntegerNegate n IntegerShow -> VPrim $ \case VIntegerLit n @@ -568,8 +569,6 @@ ListBuild -> VPrim $ \a -> VPrim $ \case - VHLam (ListFoldCl x) _ -> - x VPrimVar -> VListBuild a VPrimVar t -> t @@ -588,7 +587,7 @@ VHLam (Typed "nil" list) $ \nil -> foldr' (\x b -> cons `vApp` x `vApp` b) nil as as -> - VHLam (ListFoldCl as) $ \t -> + VPrim $ \t -> VPrim $ \c -> VPrim $ \n -> VListFold a as t c n @@ -620,14 +619,14 @@ VListLit _ as -> let a' = if null as - then Just (VList (VRecord (Map.fromList [("index", VNatural), ("value", a)]))) + then Just (VList (VRecord (Map.unorderedFromList [("index", VNatural), ("value", a)]))) else Nothing as' = Sequence.mapWithIndex (\i t -> VRecordLit - (Map.fromList + (Map.unorderedFromList [ ("index", VNaturalLit (fromIntegral i)) , ("value", t) ] @@ -667,14 +666,13 @@ VHLam (Typed "none" optional) $ \_none -> some `vApp` t opt -> - VHLam (OptionalFoldCl opt) $ \o -> + VPrim $ \o -> VPrim $ \s -> VPrim $ \n -> VOptionalFold a opt o s n OptionalBuild -> VPrim $ \ ~a -> VPrim $ \case - VHLam (OptionalFoldCl x) _ -> x VPrimVar -> VOptionalBuild a VPrimVar t -> t `vApp` VOptional a @@ -703,17 +701,17 @@ ToMap x ma -> case (eval env x, fmap (eval env) ma) of (VRecordLit m, ma'@(Just _)) | null m -> - VListLit ma' (Sequence.empty) + VListLit ma' Sequence.empty (VRecordLit m, _) -> let entry (k, v) = VRecordLit - (Map.fromList + (Map.unorderedFromList [ ("mapKey", VTextLit $ VChunks [] k) , ("mapValue", v) ] ) - s = (Sequence.fromList . map entry . Map.toList) m + s = (Sequence.fromList . map entry . Map.toAscList) m in VListLit Nothing s (x', ma') -> @@ -761,7 +759,7 @@ eqMapsBy :: Ord k => (v -> v -> Bool) -> Map k v -> Map k v -> Bool eqMapsBy f mL mR = Map.size mL == Map.size mR - && eqListBy eq (Map.toList mL) (Map.toList mR) + && eqListBy eq (Map.toAscList mL) (Map.toAscList mR) where eq (kL, vL) (kR, vR) = kL == kR && f vL vR {-# INLINE eqMapsBy #-} @@ -864,6 +862,10 @@ True (VIntegerLit t, VIntegerLit t') -> t == t' + (VIntegerClamp t, VIntegerClamp t') -> + conv env t t' + (VIntegerNegate t, VIntegerNegate t') -> + conv env t t' (VIntegerShow t, VIntegerShow t') -> conv env t t' (VIntegerToDouble t, VIntegerToDouble t') -> @@ -998,9 +1000,6 @@ case i of Typed (fresh -> (x, v)) a -> Lam x (quote env a) (quoteBind x (t v)) Prim -> quote env (t VPrimVar) - NaturalFoldCl{} -> quote env (t VPrimVar) - ListFoldCl{} -> quote env (t VPrimVar) - OptionalFoldCl{} -> quote env (t VPrimVar) NaturalSubtractZero -> App NaturalSubtract (NaturalLit 0) VPi a (freshClosure -> (x, v, b)) -> @@ -1049,6 +1048,10 @@ Integer VIntegerLit n -> IntegerLit n + VIntegerClamp t -> + IntegerClamp `qApp` t + VIntegerNegate t -> + IntegerNegate `qApp` t VIntegerShow t -> IntegerShow `qApp` t VIntegerToDouble t -> @@ -1225,6 +1228,10 @@ Integer IntegerLit n -> IntegerLit n + IntegerClamp -> + IntegerClamp + IntegerNegate -> + IntegerNegate IntegerShow -> IntegerShow IntegerToDouble -> diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -13,8 +13,8 @@ import Control.Exception (Exception) import Data.Monoid ((<>)) -import Dhall.Pretty (CharacterSet(..), annToAnsiStyle, layoutOpts) -import Dhall.Util (Censor, Input(..)) +import Dhall.Pretty (CharacterSet(..), annToAnsiStyle) +import Dhall.Util (Censor, Input(..), Header(..)) import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal @@ -23,6 +23,7 @@ import qualified Data.Text.IO import qualified Dhall.Pretty import qualified Dhall.Util +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.IO @@ -50,50 +51,49 @@ format :: Format -> IO () -format (Format {..}) = +format (Format {..}) = do + let layoutHeaderAndExpr (Header header, expr) = + Dhall.Pretty.layout + ( Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet expr + <> "\n") + + let layoutInput input = do + headerAndExpr <- Dhall.Util.getExpressionAndHeader censor input + + return (layoutHeaderAndExpr headerAndExpr) + case formatMode of - Modify {..} -> + Modify {..} -> do + docStream <- layoutInput inplace + case inplace of InputFile file -> do - (header, expr) <- Dhall.Util.getExpressionAndHeader censor (InputFile file) - - let doc = Pretty.pretty header - <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) - <> "\n" + AtomicWrite.LazyText.atomicWriteFile + file + (Pretty.Text.renderLazy docStream) - System.IO.withFile file System.IO.WriteMode (\handle -> do - Pretty.Terminal.renderIO handle (Pretty.layoutSmart layoutOpts doc)) StandardInput -> do - (header, expr) <- Dhall.Util.getExpressionAndHeader censor StandardInput - - let doc = Pretty.pretty header - <> Dhall.Pretty.prettyCharacterSet characterSet expr - <> "\n" - supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout - if supportsANSI - then - Pretty.Terminal.renderIO - System.IO.stdout - (fmap annToAnsiStyle (Pretty.layoutSmart layoutOpts doc)) - else - Pretty.Terminal.renderIO - System.IO.stdout - (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) + Pretty.Terminal.renderIO + System.IO.stdout + (if supportsANSI + then (fmap annToAnsiStyle docStream) + else (Pretty.unAnnotateS docStream)) + Check {..} -> do originalText <- case path of InputFile file -> Data.Text.IO.readFile file StandardInput -> Data.Text.IO.getContents - (header, expr) <- Dhall.Util.getExpressionAndHeader censor path - - let doc = Pretty.pretty header - <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) - <> "\n" + docStream <- case path of + InputFile _ -> layoutInput path + StandardInput -> do + headerAndExpr <- Dhall.Util.getExpressionAndHeaderFromStdinText censor originalText + return (layoutHeaderAndExpr headerAndExpr) - let formattedText = - Pretty.Text.renderStrict (Pretty.layoutSmart layoutOpts doc) + let formattedText = Pretty.Text.renderStrict docStream if originalText == formattedText then return () diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -14,13 +14,11 @@ , Intent(..) ) where -import Control.Exception (SomeException) import Data.Monoid ((<>)) import Data.Text -import Data.Void (Void) -import Dhall.Core (Expr(..), Import(..), ImportHashed(..), ImportType(..)) import Dhall.Parser (Src) -import Dhall.Pretty (CharacterSet, annToAnsiStyle, layoutOpts, prettyCharacterSet) +import Dhall.Pretty (CharacterSet) +import Dhall.Syntax (Expr(..), Import(..), ImportHashed(..), ImportType(..)) import Dhall.Util (Censor, Input(..)) import System.Console.ANSI (hSupportsANSI) @@ -28,12 +26,14 @@ import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty -import qualified Data.Text.IO +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Optics +import qualified Dhall.Pretty import qualified Dhall.TypeCheck import qualified Dhall.Util +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.FilePath import qualified System.IO @@ -54,15 +54,7 @@ let status = Dhall.Import.emptyStatus directory - let download = - State.evalStateT (Dhall.Import.loadWith (Embed import_)) status - - -- Try again without the semantic integrity check if decoding fails - let handler :: SomeException -> IO (Expr Src Void) - handler _ = do - State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status - - expression <- Control.Exception.handle handler download + expression <- State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status case Dhall.TypeCheck.typeOf expression of Left exception -> Control.Exception.throwIO exception @@ -72,7 +64,7 @@ Dhall.Core.alphaNormalize (Dhall.Core.normalize expression) -- make sure the frozen import is present in the semantic cache - Dhall.Import.writeExpressionToSemanticCache expression + Dhall.Import.writeExpressionToSemanticCache (Dhall.Core.denote expression) let expressionHash = Dhall.Import.hashExpression normalizedExpression @@ -97,20 +89,23 @@ writeExpr inplace (header, expr) characterSet = do let doc = Pretty.pretty header <> Dhall.Pretty.prettyCharacterSet characterSet expr + <> "\n" - let unAnnotated = Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc) + let stream = Dhall.Pretty.layout doc + let unAnnotated = Pretty.unAnnotateS stream + case inplace of - InputFile f -> - System.IO.withFile f System.IO.WriteMode (\handle -> do - Pretty.renderIO handle unAnnotated - Data.Text.IO.hPutStrLn handle "" ) + InputFile file -> + AtomicWrite.LazyText.atomicWriteFile + file + (Pretty.Text.renderLazy unAnnotated) StandardInput -> do supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout if supportsANSI then - Pretty.renderIO System.IO.stdout (annToAnsiStyle <$> Pretty.layoutSmart layoutOpts doc) + Pretty.renderIO System.IO.stdout (Dhall.Pretty.annToAnsiStyle <$> stream) else Pretty.renderIO System.IO.stdout unAnnotated @@ -145,7 +140,8 @@ StandardInput -> "." InputFile file -> System.FilePath.takeDirectory file - (header, parsedExpression) <- Dhall.Util.getExpressionAndHeader censor inplace + (Dhall.Util.Header header, parsedExpression) <- + Dhall.Util.getExpressionAndHeader censor inplace let freezeScope = case scope of diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -138,7 +138,6 @@ ) where import Control.Applicative (Alternative(..)) -import Codec.CBOR.Term (Term(..)) import Control.Exception (Exception, SomeException, IOException, toException) import Control.Monad (when) import Control.Monad.Catch (throwM, MonadCatch(catch), handle) @@ -158,7 +157,7 @@ import Data.Typeable (Typeable) import System.FilePath (()) import Dhall.Binary (StandardVersion(..)) -import Dhall.Core +import Dhall.Syntax ( Expr(..) , Chunks(..) , Directory(..) @@ -173,24 +172,25 @@ , chunkExprs ) #ifdef WITH_HTTP -import Dhall.Import.HTTP hiding (HTTPHeader) +import Dhall.Import.HTTP #endif import Dhall.Import.Types import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..)) import Lens.Family.State.Strict (zoom) +import qualified Codec.CBOR.Encoding as Encoding +import qualified Codec.CBOR.Write as Write import qualified Codec.Serialise -import qualified Control.Monad.Trans.Maybe as Maybe -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.State.Strict as State import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.CaseInsensitive import qualified Data.Foldable -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text.Encoding -import qualified Data.Text as Text +import qualified Data.Text as Text import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core @@ -199,11 +199,12 @@ import qualified Dhall.Parser import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck +import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary import qualified System.Environment import qualified System.Info import qualified System.IO -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath import qualified Text.Megaparsec import qualified Text.Parser.Combinators import qualified Text.Parser.Token @@ -478,11 +479,12 @@ loadImport :: Chained -> StateT Status IO ImportSemantics loadImport import_ = do Status {..} <- State.get - case Map.lookup import_ _cache of + + case Dhall.Map.lookup import_ _cache of Just importSemantics -> return importSemantics Nothing -> do importSemantics <- loadImportWithSemanticCache import_ - zoom cache (State.modify (Map.insert import_ importSemantics)) + zoom cache (State.modify (Dhall.Map.insert import_ importSemantics)) return importSemantics -- | Load an import from the 'semantic cache'. Defers to @@ -504,6 +506,7 @@ case mCached of Just bytesStrict -> do let actualHash = Dhall.Crypto.sha256Hash bytesStrict + if semanticHash == actualHash then return () else do @@ -511,13 +514,11 @@ throwMissingImport (Imported _stack (HashMismatch {expectedHash = semanticHash, ..})) let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict - term <- case Codec.Serialise.deserialiseOrFail bytesLazy of - Left err -> throwMissingImport (Imported _stack err) - Right t -> return t - importSemantics <- case Dhall.Binary.decodeExpression term of - Left err -> throwMissingImport (Imported _stack err) - Right sem -> return sem + importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of + Left err -> throwMissingImport (Imported _stack err) + Right e -> return e + return (ImportSemantics {..}) Nothing -> do @@ -544,7 +545,7 @@ -- | Ensure that the given expression is present in the semantic cache. The -- given expression should be alpha-beta-normal. -writeExpressionToSemanticCache :: Expr Src Void -> IO () +writeExpressionToSemanticCache :: Expr Void Void -> IO () writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes where bytes = encodeExpression NoVersion expression @@ -554,7 +555,7 @@ writeToSemanticCache hash bytes = do _ <- Maybe.runMaybeT $ do cacheFile <- getCacheFile "dhall" hash - liftIO (Data.ByteString.writeFile cacheFile bytes) + liftIO (AtomicWrite.Binary.atomicWriteFile cacheFile bytes) return () -- Check the "semi-semantic" disk cache, otherwise typecheck and normalise from @@ -592,18 +593,14 @@ -- Check the semi-semantic cache. See -- https://github.com/dhall-lang/dhall-haskell/issues/1098 for the reasoning -- behind semi-semantic caching. - let semisemanticHash = computeSemisemanticHash resolvedExpr + let semisemanticHash = computeSemisemanticHash (Dhall.Core.denote resolvedExpr) mCached <- lift $ fetchFromSemisemanticCache semisemanticHash importSemantics <- case mCached of Just bytesStrict -> do let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict - term <- case Codec.Serialise.deserialiseOrFail bytesLazy of - Left err -> throwMissingImport (Imported _stack err) - Right t -> return t - - importSemantics <- case Dhall.Binary.decodeExpression term of + importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of Left err -> throwMissingImport (Imported _stack err) Right sem -> return sem @@ -659,7 +656,7 @@ -- AST (without normalising or type-checking it first). See -- https://github.com/dhall-lang/dhall-haskell/issues/1098 for further -- discussion. -computeSemisemanticHash :: Expr Src Void -> Dhall.Crypto.SHA256Digest +computeSemisemanticHash :: Expr Void Void -> Dhall.Crypto.SHA256Digest computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr -- Fetch encoded normal form from "semi-semantic cache" @@ -673,7 +670,7 @@ writeToSemisemanticCache semisemanticHash bytes = do _ <- Maybe.runMaybeT $ do cacheFile <- getCacheFile "dhall-haskell" semisemanticHash - liftIO (Data.ByteString.writeFile cacheFile bytes) + liftIO (AtomicWrite.Binary.atomicWriteFile cacheFile bytes) return () -- Fetch source code directly from disk/network @@ -988,7 +985,7 @@ let local (Chained (Import (ImportHashed _ (Remote {})) _)) = False local (Chained (Import (ImportHashed _ (Local {})) _)) = True local (Chained (Import (ImportHashed _ (Env {})) _)) = True - local (Chained (Import (ImportHashed _ (Missing {})) _)) = True + local (Chained (Import (ImportHashed _ (Missing {})) _)) = False let referentiallySane = not (local child) || local parent @@ -1012,7 +1009,7 @@ ImportSemantics {..} <- loadImport child zoom stack (State.put _stack) - return importSemantics + return (Dhall.Core.renote importSemantics) ImportAlt a b -> loadWith a `catch` handler₀ where @@ -1052,6 +1049,8 @@ NaturalTimes a b -> NaturalTimes <$> loadWith a <*> loadWith b Integer -> pure Integer IntegerLit a -> pure (IntegerLit a) + IntegerClamp -> pure IntegerClamp + IntegerNegate -> pure IntegerNegate IntegerShow -> pure IntegerShow IntegerToDouble -> pure IntegerToDouble Double -> pure Double @@ -1107,33 +1106,30 @@ (emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode } encodeExpression - :: forall s - . StandardVersion + :: StandardVersion -- ^ `NoVersion` means to encode without the version tag - -> Expr s Void + -> Expr Void Void -> Data.ByteString.ByteString encodeExpression _standardVersion expression = bytesStrict where - intermediateExpression :: Expr s Import + intermediateExpression :: Expr Void Import intermediateExpression = fmap absurd expression - term :: Term - term = Dhall.Binary.encodeExpression intermediateExpression - - taggedTerm :: Term - taggedTerm = + encoding = case _standardVersion of - NoVersion -> term - s -> TList [ TString v, term ] + NoVersion -> + Codec.Serialise.encode intermediateExpression + s -> + Encoding.encodeListLen 2 + <> Encoding.encodeString v + <> Codec.Serialise.encode intermediateExpression where v = Dhall.Binary.renderStandardVersion s - bytesLazy = Codec.Serialise.serialise taggedTerm - - bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy + bytesStrict = Write.toStrictByteString encoding -- | Hash a fully resolved expression -hashExpression :: Expr s Void -> Dhall.Crypto.SHA256Digest +hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest hashExpression expression = Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression) @@ -1143,7 +1139,7 @@ In other words, the output of this function can be pasted into Dhall source code to add an integrity check to an import -} -hashExpressionToCode :: Expr s Void -> Text +hashExpressionToCode :: Expr Void Void -> Text hashExpressionToCode expr = "sha256:" <> Text.pack (show (hashExpression expr)) diff --git a/src/Dhall/Import/Types.hs b/src/Dhall/Import/Types.hs --- a/src/Dhall/Import/Types.hs +++ b/src/Dhall/Import/Types.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} + {-# OPTIONS_GHC -Wall #-} module Dhall.Import.Types where @@ -8,7 +10,7 @@ import Control.Monad.Trans.State.Strict (StateT) import Data.Dynamic import Data.List.NonEmpty (NonEmpty) -import Data.Map (Map) +import Dhall.Map (Map) import Data.Semigroup ((<>)) import Data.Text.Prettyprint.Doc (Pretty(..)) import Data.Void (Void) @@ -25,12 +27,15 @@ , ReifiedNormalizer(..) , URL ) +#ifdef WITH_HTTP +import Dhall.Import.Manager (Manager) +#endif import Dhall.Parser (Src) import Lens.Family (LensLike') import System.FilePath (isRelative, splitDirectories) import qualified Dhall.Context -import qualified Data.Map as Map +import qualified Dhall.Map as Map import qualified Data.Text -- | A fully 'chained' import, i.e. if it contains a relative path that path is @@ -49,7 +54,7 @@ -- | An import that has been fully interpeted data ImportSemantics = ImportSemantics - { importSemantics :: Expr Src Void + { importSemantics :: Expr Void Void -- ^ The fully resolved import, typechecked and beta-normal. } @@ -75,6 +80,13 @@ -- ^ Cache of imported expressions with their node id in order to avoid -- importing the same expression twice with different values +#ifdef WITH_HTTP + , _manager :: Maybe Manager +#else + , _manager :: Maybe Void +#endif + -- ^ Used to cache the `Manager` when making multiple requests + , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. @@ -95,6 +107,8 @@ _graph = [] _cache = Map.empty + + _manager = Nothing _normalizer = Nothing diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} -- | This module contains the implementation of the @dhall lint@ command @@ -6,11 +9,26 @@ ( -- * Lint lint , removeUnusedBindings + , fixAssert + , fixParentPath ) where import Control.Applicative ((<|>)) -import Dhall.Core (Binding(..), Expr(..), Import, Var(..), subExpressions) +import Dhall.Syntax + ( Binding(..) + , Directory(..) + , Expr(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportType(..) + , Var(..) + , subExpressions + ) + +import qualified Data.List.NonEmpty as NonEmpty import qualified Dhall.Core import qualified Dhall.Optics import qualified Lens.Family @@ -22,12 +40,13 @@ * removes unused @let@ bindings with 'removeUnusedBindings'. * fixes @let a = x ≡ y@ to be @let a = assert : x ≡ y@ * 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 -> fixAsserts e <|> removeUnusedBindings e) + (\e -> fixAssert e <|> removeUnusedBindings e <|> fixParentPath e) . removeLetInLet -- | Remove unused `Let` bindings. @@ -40,12 +59,41 @@ Just (Dhall.Core.shift (-1) (V a 0) d) removeUnusedBindings _ = Nothing --- Fix `Let` bindings that the user probably meant to be `assert`s -fixAsserts :: Expr s a -> Maybe (Expr s a) -fixAsserts (Let (Binding { value = Equivalent x y, ..}) body) = +-- | 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) -fixAsserts _ = +fixAssert (Let binding (Equivalent x y)) = + Just (Let binding (Assert (Equivalent x y))) +fixAssert _ = Nothing + +-- | This transforms @.\/..\/foo@ into @..\/foo@ +fixParentPath :: Expr s Import -> Maybe (Expr s Import) +fixParentPath (Embed oldImport) = do + let Import{..} = oldImport + + let ImportHashed{..} = importHashed + + case importType of + Local Here File{ directory = Directory { components }, .. } + | Just nonEmpty <- NonEmpty.nonEmpty components + , NonEmpty.last nonEmpty == ".." -> do + let newDirectory = + Directory { components = NonEmpty.init nonEmpty } + + let newImportType = + Local Parent File{ directory = newDirectory, .. } + + let newImportHashed = + ImportHashed { importType = newImportType, .. } + + let newImport = Import { importHashed = newImportHashed, .. } + + Just (Embed newImport) + _ -> + Nothing +fixParentPath _ = Nothing isOrContainsAssert :: Expr s a -> Bool isOrContainsAssert (Assert _) = True diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -32,9 +32,9 @@ import Dhall.Freeze (Intent(..), Scope(..)) import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode) import Dhall.Parser (Src) -import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts) +import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle) import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError) -import Dhall.Util (Censor(..), Input(..), Output(..)) +import Dhall.Util (Censor(..), Header (..), Input(..), Output(..)) import Dhall.Version (dhallVersionString) import Options.Applicative (Parser, ParserInfo) import System.Exit (ExitCode, exitFailure) @@ -44,17 +44,18 @@ import qualified Codec.CBOR.JSON import qualified Codec.CBOR.Read import qualified Codec.CBOR.Write -import qualified Codec.Serialise import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Aeson import qualified Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy import qualified Data.ByteString.Lazy.Char8 +import qualified Data.Map import qualified Data.Text import qualified Data.Text.IO 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 import qualified Dhall.Binary import qualified Dhall.Core @@ -64,6 +65,7 @@ import qualified Dhall.Import import qualified Dhall.Import.Types import qualified Dhall.Lint +import qualified Dhall.Map import qualified Dhall.Tags import qualified Dhall.Pretty import qualified Dhall.Repl @@ -71,12 +73,13 @@ import qualified Dhall.Util import qualified GHC.IO.Encoding import qualified Options.Applicative +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.Exit as Exit import qualified System.IO import qualified System.FilePath import qualified Text.Dot -import qualified Data.Map +import qualified Text.Pretty.Simple -- | Top-level program options data Options = Options @@ -130,6 +133,7 @@ | Encode { file :: Input, json :: Bool } | Decode { file :: Input, json :: Bool } | Text { file :: Input } + | SyntaxTree { file :: Input } data ResolveMode = Dot @@ -158,11 +162,12 @@ f True = Censor f False = NoCensor -subcommand :: String -> String -> Parser a -> Parser a -subcommand name description parser = +subcommand' :: Bool -> String -> String -> Parser a -> Parser a +subcommand' internal name description parser = Options.Applicative.hsubparser ( Options.Applicative.command name parserInfo <> Options.Applicative.metavar name + <> if internal then Options.Applicative.internal else mempty ) where parserInfo = @@ -171,6 +176,12 @@ <> Options.Applicative.progDesc description ) +subcommand :: String -> String -> Parser a -> Parser a +subcommand = subcommand' False + +internalSubcommand :: String -> String -> Parser a -> Parser a +internalSubcommand = subcommand' True + parseMode :: Parser Mode parseMode = subcommand @@ -229,6 +240,10 @@ "text" "Render a Dhall expression that evaluates to a Text literal" (Text <$> parseFile) + <|> internalSubcommand + "haskell-syntax-tree" + "Output the parsed syntax tree (for debugging)" + (SyntaxTree <$> parseFile) <|> ( Default <$> parseFile <*> parseOutput @@ -308,7 +323,7 @@ Options.Applicative.flag' (Just ListTransitiveDependencies) ( Options.Applicative.long "transitive-dependencies" <> Options.Applicative.help - "List transitive import dependencies" + "List transitive import dependencies in post-order" ) <|> pure Nothing @@ -470,7 +485,7 @@ let renderDoc :: Handle -> Doc Ann -> IO () renderDoc h doc = do - let stream = Pretty.layoutSmart layoutOpts doc + let stream = Dhall.Pretty.layout doc supportsANSI <- System.Console.ANSI.hSupportsANSI h let ansiStream = @@ -487,6 +502,12 @@ renderDoc h doc + let writeDocToFile :: FilePath -> Doc ann -> IO () + writeDocToFile file doc = do + let stream = Dhall.Pretty.layout (doc <> "\n") + + AtomicWrite.LazyText.atomicWriteFile file (Pretty.Text.renderLazy stream) + when (not $ ignoreSemanticCache mode) Dhall.Import.warnAboutMissingCaches handle $ case mode of @@ -521,8 +542,11 @@ case output of StandardOutput -> render System.IO.stdout annotatedExpression + OutputFile file_ -> - System.IO.withFile file_ System.IO.WriteMode $ \h -> render h annotatedExpression + writeDocToFile + file_ + (Dhall.Pretty.prettyCharacterSet characterSet annotatedExpression) Resolve { resolveMode = Just Dot, ..} -> do expression <- getExpression file @@ -571,7 +595,8 @@ . Dhall.Core.importType . Dhall.Core.importHashed . Dhall.Import.chainedImport ) - . Data.Map.keys + . reverse + . Dhall.Map.keys $ _cache Resolve { resolveMode = Nothing, ..} -> do @@ -650,32 +675,22 @@ Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression) Lint {..} -> do - (header, expression) <- getExpressionAndHeader inplace - - case inplace of - InputFile file -> do - let lintedExpression = Dhall.Lint.lint expression - - let doc = Pretty.pretty header - <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression + (Header header, expression) <- getExpressionAndHeader inplace - System.IO.withFile file System.IO.WriteMode (\h -> do - renderDoc h doc ) + let lintedExpression = Dhall.Lint.lint expression - StandardInput -> do - let lintedExpression = Dhall.Lint.lint expression + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression - let doc = Pretty.pretty header - <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression + case inplace of + InputFile file -> writeDocToFile file doc - renderDoc System.IO.stdout doc + StandardInput -> renderDoc System.IO.stdout doc Encode {..} -> do expression <- getExpression file - let term = Dhall.Binary.encodeExpression expression - - let bytes = Codec.Serialise.serialise term + let bytes = Dhall.Binary.encodeExpression (Dhall.Core.denote expression) if json then do @@ -696,7 +711,7 @@ InputFile f -> Data.ByteString.Lazy.readFile f StandardInput -> Data.ByteString.Lazy.getContents - term <- do + expression <- do if json then do value <- case Data.Aeson.eitherDecode' bytes of @@ -705,15 +720,14 @@ let encoding = Codec.CBOR.JSON.encodeValue value - let cborBytes = Codec.CBOR.Write.toLazyByteString encoding - Dhall.Core.throws (Codec.Serialise.deserialiseOrFail cborBytes) + let cborgBytes = Codec.CBOR.Write.toLazyByteString encoding + + Dhall.Core.throws (Dhall.Binary.decodeExpression cborgBytes) else do - Dhall.Core.throws (Codec.Serialise.deserialiseOrFail bytes) + Dhall.Core.throws (Dhall.Binary.decodeExpression bytes) - expression <- Dhall.Core.throws (Dhall.Binary.decodeExpression term) - :: IO (Expr Src Import) - let doc = Dhall.Pretty.prettyCharacterSet characterSet expression + let doc = Dhall.Pretty.prettyCharacterSet characterSet (Dhall.Core.renote expression :: Expr Src Import) renderDoc System.IO.stdout doc @@ -731,13 +745,13 @@ Dhall.Core.TextLit (Dhall.Core.Chunks [] text) -> do Data.Text.IO.putStr text _ -> do - let invalidTypeExpected :: Expr Void Void - invalidTypeExpected = Dhall.Core.Text + let invalidDecoderExpected :: Expr Void Void + invalidDecoderExpected = Dhall.Core.Text - let invalidTypeExpression :: Expr Void Void - invalidTypeExpression = normalizedExpression + let invalidDecoderExpression :: Expr Void Void + invalidDecoderExpression = normalizedExpression - Control.Exception.throwIO (Dhall.InvalidType {..}) + Control.Exception.throwIO (Dhall.InvalidDecoder {..}) Tags {..} -> do tags <- Dhall.Tags.generate input suffixes followSymlinks @@ -747,7 +761,14 @@ System.IO.withFile file System.IO.WriteMode (`Data.Text.IO.hPutStr` tags) StandardOutput -> Data.Text.IO.putStrLn tags - + + SyntaxTree {..} -> do + expression <- getExpression file + + let denoted :: Expr Void Import + denoted = Dhall.Core.denote expression + + Text.Pretty.Simple.pPrintNoColor denoted -- | Entry point for the @dhall@ executable main :: IO () diff --git a/src/Dhall/Map.hs b/src/Dhall/Map.hs --- a/src/Dhall/Map.hs +++ b/src/Dhall/Map.hs @@ -13,6 +13,7 @@ Map -- * Construction + , empty , singleton , fromList , fromListWithKey @@ -33,6 +34,7 @@ , delete , filter , restrictKeys + , withoutKeys , mapMaybe -- * Query @@ -58,6 +60,7 @@ -- * Conversions , toList + , toAscList , toMap , keys , keysSet @@ -124,6 +127,9 @@ length m = size m {-# INLINABLE length #-} + null (Map m _) = null m + {-# INLINABLE null #-} + instance Ord k => Traversable (Map k) where traverse f m = traverseWithKey (\_ v -> f v) m {-# INLINABLE traverse #-} @@ -161,6 +167,10 @@ toList = Dhall.Map.toList +-- | Create an empty `Map` +empty :: Ord k => Map k v +empty = mempty + {-| Create a `Map` from a single key-value pair >>> singleton "A" 1 @@ -369,6 +379,23 @@ ks' = filterKeys (\k -> Data.Set.member k s) ks {-# INLINABLE restrictKeys #-} +{-| Remove all keys in a @"Data.Set".'Set'@ from a 'Map' + +>>> withoutKeys (fromList [("A",1),("B",2)]) (Data.Set.fromList ["A"]) +fromList [("B",2)] +-} +withoutKeys :: Ord k => Map k a -> Data.Set.Set k -> Map k a +withoutKeys (Map m ks) s = Map m' ks' + where +#if MIN_VERSION_containers(0,5,8) + m' = Data.Map.withoutKeys m s +#else + m' = Data.Map.filterWithKey (\k _ -> Data.Set.notMember k s) m +#endif + + ks' = filterKeys (\k -> Data.Set.notMember k s) ks +{-# INLINABLE withoutKeys #-} + {-| Transform all values in a `Map` using the supplied function, deleting the key if the function returns `Nothing` @@ -630,6 +657,12 @@ toList (Map m Sorted) = Data.Map.toList m toList (Map m (Original ks)) = fmap (\k -> (k, m Data.Map.! k)) ks {-# INLINABLE toList #-} + +{-| Convert a `Map` to a list of key-value pairs in ascending order of keys +-} +toAscList :: Map k v -> [(k, v)] +toAscList (Map m _) = Data.Map.toAscList m +{-# INLINABLE toAscList #-} {-| Convert a @"Dhall.Map".`Map`@ to a @"Data.Map".`Data.Map.Map`@ diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Normalize.hs @@ -0,0 +1,1239 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Dhall.Normalize ( + alphaNormalize + , normalize + , normalizeWith + , normalizeWithM + , Normalizer + , NormalizerM + , ReifiedNormalizer (..) + , judgmentallyEqual + , subst + , shift + , isNormalized + , isNormalizedWith + , freeIn + ) where + +import Control.Applicative (empty) +import Data.Foldable +import Data.Functor.Identity (Identity(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (ViewL(..), ViewR(..)) +import Data.Traversable +import Dhall.Syntax (Expr(..), Var(..), Binding(Binding), Chunks(..), DhallDouble(..), Const(..)) +import Instances.TH.Lift () +import Prelude hiding (succ) + +import qualified Data.Sequence +import qualified Data.Set +import qualified Data.Text +import qualified Dhall.Eval as Eval +import qualified Dhall.Map +import qualified Dhall.Set +import qualified Dhall.Syntax as Syntax + +{-| Returns `True` if two expressions are α-equivalent and β-equivalent and + `False` otherwise + + `judgmentallyEqual` can fail with an `error` if you compare ill-typed + expressions +-} +judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool +judgmentallyEqual = Eval.judgmentallyEqual +{-# INLINE judgmentallyEqual #-} + +{-| `shift` is used by both normalization and type-checking to avoid variable + capture by shifting variable indices + + For example, suppose that you were to normalize the following expression: + +> λ(a : Type) → λ(x : a) → (λ(y : a) → λ(x : a) → y) x + + If you were to substitute @y@ with @x@ without shifting any variable + indices, then you would get the following incorrect result: + +> λ(a : Type) → λ(x : a) → λ(x : a) → x -- Incorrect normalized form + + In order to substitute @x@ in place of @y@ we need to `shift` @x@ by @1@ in + order to avoid being misinterpreted as the @x@ bound by the innermost + lambda. If we perform that `shift` then we get the correct result: + +> λ(a : Type) → λ(x : a) → λ(x : a) → x@1 + + As a more worked example, suppose that you were to normalize the following + expression: + +> λ(a : Type) +> → λ(f : a → a → a) +> → λ(x : a) +> → λ(x : a) +> → (λ(x : a) → f x x@1) x@1 + + The correct normalized result would be: + +> λ(a : Type) +> → λ(f : a → a → a) +> → λ(x : a) +> → λ(x : a) +> → f x@1 x + + The above example illustrates how we need to both increase and decrease + variable indices as part of substitution: + + * We need to increase the index of the outer @x\@1@ to @x\@2@ before we + substitute it into the body of the innermost lambda expression in order + to avoid variable capture. This substitution changes the body of the + lambda expression to @(f x\@2 x\@1)@ + + * We then remove the innermost lambda and therefore decrease the indices of + both @x@s in @(f x\@2 x\@1)@ to @(f x\@1 x)@ in order to reflect that one + less @x@ variable is now bound within that scope + + Formally, @(shift d (V x n) e)@ modifies the expression @e@ by adding @d@ to + the indices of all variables named @x@ whose indices are greater than + @(n + m)@, where @m@ is the number of bound variables of the same name + within that scope + + In practice, @d@ is always @1@ or @-1@ because we either: + + * increment variables by @1@ to avoid variable capture during substitution + * decrement variables by @1@ when deleting lambdas after substitution + + @n@ starts off at @0@ when substitution begins and increments every time we + descend into a lambda or let expression that binds a variable of the same + name in order to avoid shifting the bound variables by mistake. +-} +shift :: Int -> Var -> Expr s a -> Expr s a +shift _ _ (Const a) = Const a +shift d (V x n) (Var (V x' n')) = Var (V x' n'') + where + n'' = if x == x' && n <= n' then n' + d else n' +shift d (V x n) (Lam x' _A b) = Lam x' _A' b' + where + _A' = shift d (V x n ) _A + b' = shift d (V x n') b + where + n' = if x == x' then n + 1 else n +shift d (V x n) (Pi x' _A _B) = Pi x' _A' _B' + where + _A' = shift d (V x n ) _A + _B' = shift d (V x n') _B + where + n' = if x == x' then n + 1 else n +shift d v (App f a) = App f' a' + where + f' = shift d v f + a' = shift d v a +shift d (V x n) (Let (Binding src0 f src1 mt src2 r) e) = + Let (Binding src0 f src1 mt' src2 r') e' + where + e' = shift d (V x n') e + where + n' = if x == f then n + 1 else n + + mt' = fmap (fmap (shift d (V x n))) mt + r' = shift d (V x n) r +shift d v (Annot a b) = Annot a' b' + where + a' = shift d v a + b' = shift d v b +shift _ _ Bool = Bool +shift _ _ (BoolLit a) = BoolLit a +shift d v (BoolAnd a b) = BoolAnd a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (BoolOr a b) = BoolOr a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (BoolEQ a b) = BoolEQ a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (BoolNE a b) = BoolNE a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (BoolIf a b c) = BoolIf a' b' c' + where + a' = shift d v a + b' = shift d v b + c' = shift d v c +shift _ _ Natural = Natural +shift _ _ (NaturalLit a) = NaturalLit a +shift _ _ NaturalFold = NaturalFold +shift _ _ NaturalBuild = NaturalBuild +shift _ _ NaturalIsZero = NaturalIsZero +shift _ _ NaturalEven = NaturalEven +shift _ _ NaturalOdd = NaturalOdd +shift _ _ NaturalToInteger = NaturalToInteger +shift _ _ NaturalShow = NaturalShow +shift _ _ NaturalSubtract = NaturalSubtract +shift d v (NaturalPlus a b) = NaturalPlus a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (NaturalTimes a b) = NaturalTimes a' b' + where + a' = shift d v a + b' = shift d v b +shift _ _ Integer = Integer +shift _ _ (IntegerLit a) = IntegerLit a +shift _ _ IntegerClamp = IntegerClamp +shift _ _ IntegerNegate = IntegerNegate +shift _ _ IntegerShow = IntegerShow +shift _ _ IntegerToDouble = IntegerToDouble +shift _ _ Double = Double +shift _ _ (DoubleLit a) = DoubleLit a +shift _ _ DoubleShow = DoubleShow +shift _ _ Text = Text +shift d v (TextLit (Chunks a b)) = TextLit (Chunks a' b) + where + a' = fmap (fmap (shift d v)) a +shift d v (TextAppend a b) = TextAppend a' b' + where + a' = shift d v a + b' = shift d v b +shift _ _ TextShow = TextShow +shift _ _ List = List +shift d v (ListLit a b) = ListLit a' b' + where + a' = fmap (shift d v) a + b' = fmap (shift d v) b +shift _ _ ListBuild = ListBuild +shift d v (ListAppend a b) = ListAppend a' b' + where + a' = shift d v a + b' = shift d v b +shift _ _ ListFold = ListFold +shift _ _ ListLength = ListLength +shift _ _ ListHead = ListHead +shift _ _ ListLast = ListLast +shift _ _ ListIndexed = ListIndexed +shift _ _ ListReverse = ListReverse +shift _ _ Optional = Optional +shift d v (Some a) = Some a' + where + a' = shift d v a +shift _ _ None = None +shift _ _ OptionalFold = OptionalFold +shift _ _ OptionalBuild = OptionalBuild +shift d v (Record a) = Record a' + where + a' = fmap (shift d v) a +shift d v (RecordLit a) = RecordLit a' + where + a' = fmap (shift d v) a +shift d v (Union a) = Union a' + where + a' = fmap (fmap (shift d v)) a +shift d v (Combine a b) = Combine a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (CombineTypes a b) = CombineTypes a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (Prefer a b) = Prefer a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (RecordCompletion a b) = RecordCompletion a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (Merge a b c) = Merge a' b' c' + where + a' = shift d v a + b' = shift d v b + c' = fmap (shift d v) c +shift d v (ToMap a b) = ToMap a' b' + where + a' = shift d v a + b' = fmap (shift d v) b +shift d v (Field a b) = Field a' b + where + a' = shift d v a +shift d v (Assert a) = Assert a' + where + a' = shift d v a +shift d v (Equivalent a b) = Equivalent a' b' + where + a' = shift d v a + b' = shift d v b +shift d v (Project a b) = Project a' b' + where + a' = shift d v a + b' = fmap (shift d v) b +shift d v (Note a b) = Note a b' + where + b' = shift d v b +shift d v (ImportAlt a b) = ImportAlt a' b' + where + a' = shift d v a + b' = shift d v b +-- The Dhall compiler enforces that all embedded values are closed expressions +-- and `shift` does nothing to a closed expression +shift _ _ (Embed p) = Embed p + +{-| Substitute all occurrences of a variable with an expression + +> subst x C B ~ B[x := C] +-} +subst :: Var -> Expr s a -> Expr s a -> Expr s a +subst _ _ (Const a) = Const a +subst (V x n) e (Lam y _A b) = Lam y _A' b' + where + _A' = subst (V x n ) e _A + b' = subst (V x n') (shift 1 (V y 0) e) b + n' = if x == y then n + 1 else n +subst (V x n) e (Pi y _A _B) = Pi y _A' _B' + where + _A' = subst (V x n ) e _A + _B' = subst (V x n') (shift 1 (V y 0) e) _B + n' = if x == y then n + 1 else n +subst v e (App f a) = App f' a' + where + f' = subst v e f + a' = subst v e a +subst v e (Var v') = if v == v' then e else Var v' +subst (V x n) e (Let (Binding src0 f src1 mt src2 r) b) = + Let (Binding src0 f src1 mt' src2 r') b' + where + b' = subst (V x n') (shift 1 (V f 0) e) b + where + n' = if x == f then n + 1 else n + + mt' = fmap (fmap (subst (V x n) e)) mt + r' = subst (V x n) e r +subst x e (Annot a b) = Annot a' b' + where + a' = subst x e a + b' = subst x e b +subst _ _ Bool = Bool +subst _ _ (BoolLit a) = BoolLit a +subst x e (BoolAnd a b) = BoolAnd a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (BoolOr a b) = BoolOr a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (BoolEQ a b) = BoolEQ a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (BoolNE a b) = BoolNE a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (BoolIf a b c) = BoolIf a' b' c' + where + a' = subst x e a + b' = subst x e b + c' = subst x e c +subst _ _ Natural = Natural +subst _ _ (NaturalLit a) = NaturalLit a +subst _ _ NaturalFold = NaturalFold +subst _ _ NaturalBuild = NaturalBuild +subst _ _ NaturalIsZero = NaturalIsZero +subst _ _ NaturalEven = NaturalEven +subst _ _ NaturalOdd = NaturalOdd +subst _ _ NaturalToInteger = NaturalToInteger +subst _ _ NaturalShow = NaturalShow +subst _ _ NaturalSubtract = NaturalSubtract +subst x e (NaturalPlus a b) = NaturalPlus a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (NaturalTimes a b) = NaturalTimes a' b' + where + a' = subst x e a + b' = subst x e b +subst _ _ Integer = Integer +subst _ _ (IntegerLit a) = IntegerLit a +subst _ _ IntegerClamp = IntegerClamp +subst _ _ IntegerNegate = IntegerNegate +subst _ _ IntegerShow = IntegerShow +subst _ _ IntegerToDouble = IntegerToDouble +subst _ _ Double = Double +subst _ _ (DoubleLit a) = DoubleLit a +subst _ _ DoubleShow = DoubleShow +subst _ _ Text = Text +subst x e (TextLit (Chunks a b)) = TextLit (Chunks a' b) + where + a' = fmap (fmap (subst x e)) a +subst x e (TextAppend a b) = TextAppend a' b' + where + a' = subst x e a + b' = subst x e b +subst _ _ TextShow = TextShow +subst _ _ List = List +subst x e (ListLit a b) = ListLit a' b' + where + a' = fmap (subst x e) a + b' = fmap (subst x e) b +subst x e (ListAppend a b) = ListAppend a' b' + where + a' = subst x e a + b' = subst x e b +subst _ _ ListBuild = ListBuild +subst _ _ ListFold = ListFold +subst _ _ ListLength = ListLength +subst _ _ ListHead = ListHead +subst _ _ ListLast = ListLast +subst _ _ ListIndexed = ListIndexed +subst _ _ ListReverse = ListReverse +subst _ _ Optional = Optional +subst x e (Some a) = Some a' + where + a' = subst x e a +subst _ _ None = None +subst _ _ OptionalFold = OptionalFold +subst _ _ OptionalBuild = OptionalBuild +subst x e (Record kts) = Record kts' + where + kts' = fmap (subst x e) kts +subst x e (RecordLit kvs) = RecordLit kvs' + where + kvs' = fmap (subst x e) kvs +subst x e (Union kts) = Union kts' + where + kts' = fmap (fmap (subst x e)) kts +subst x e (Combine a b) = Combine a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (CombineTypes a b) = CombineTypes a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (Prefer a b) = Prefer a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (RecordCompletion a b) = RecordCompletion a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (Merge a b c) = Merge a' b' c' + where + a' = subst x e a + b' = subst x e b + c' = fmap (subst x e) c +subst x e (ToMap a b) = ToMap a' b' + where + a' = subst x e a + b' = fmap (subst x e) b +subst x e (Field a b) = Field a' b + where + a' = subst x e a +subst x e (Project a b) = Project a' b' + where + a' = subst x e a + b' = fmap (subst x e) b +subst x e (Assert a) = Assert a' + where + a' = subst x e a +subst x e (Equivalent a b) = Equivalent a' b' + where + a' = subst x e a + b' = subst x e b +subst x e (Note a b) = Note a b' + where + b' = subst x e b +subst x e (ImportAlt a b) = ImportAlt a' b' + where + a' = subst x e a + b' = subst x e b +-- The Dhall compiler enforces that all embedded values are closed expressions +-- and `subst` does nothing to a closed expression +subst _ _ (Embed p) = Embed p + +{-| This function is used to determine whether folds like @Natural/fold@ or + @List/fold@ should be lazy or strict in their accumulator based on the type + of the accumulator + + If this function returns `True`, then they will be strict in their + accumulator since we can guarantee an upper bound on the amount of work to + normalize the accumulator on each step of the loop. If this function + returns `False` then they will be lazy in their accumulator and only + normalize the final result at the end of the fold +-} +boundedType :: Expr s a -> Bool +boundedType Bool = True +boundedType Natural = True +boundedType Integer = True +boundedType Double = True +boundedType Text = True +boundedType (App List _) = False +boundedType (App Optional t) = boundedType t +boundedType (Record kvs) = all boundedType kvs +boundedType (Union kvs) = all (all boundedType) kvs +boundedType _ = False + +{-| α-normalize an expression by renaming all bound variables to @\"_\"@ and + using De Bruijn indices to distinguish them + +>>> alphaNormalize (Lam "a" (Const Type) (Lam "b" (Const Type) (Lam "x" "a" (Lam "y" "b" "x")))) +Lam "_" (Const Type) (Lam "_" (Const Type) (Lam "_" (Var (V "_" 1)) (Lam "_" (Var (V "_" 1)) (Var (V "_" 1))))) + + α-normalization does not affect free variables: + +>>> alphaNormalize "x" +Var (V "x" 0) + +-} +alphaNormalize :: Expr s a -> Expr s a +alphaNormalize = Eval.alphaNormalize +{-# INLINE alphaNormalize #-} + +{-| Reduce an expression to its normal form, performing beta reduction + + `normalize` does not type-check the expression. You may want to type-check + expressions before normalizing them since normalization can convert an + ill-typed expression into a well-typed expression. + + `normalize` can also fail with `error` if you normalize an ill-typed + expression +-} +normalize :: Eq a => Expr s a -> Expr t a +normalize = Eval.normalize +{-# INLINE normalize #-} + +{-| Reduce an expression to its normal form, performing beta reduction and applying + any custom definitions. + + `normalizeWith` is designed to be used with function `typeWith`. The `typeWith` + function allows typing of Dhall functions in a custom typing context whereas + `normalizeWith` allows evaluating Dhall expressions in a custom context. + + To be more precise `normalizeWith` applies the given normalizer when it finds an + application term that it cannot reduce by other means. + + Note that the context used in normalization will determine the properties of normalization. + That is, if the functions in custom context are not total then the Dhall language, evaluated + with those functions is not total either. + + `normalizeWith` can fail with an `error` if you normalize an ill-typed + expression +-} +normalizeWith :: Eq a => Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a +normalizeWith (Just ctx) t = runIdentity (normalizeWithM (getReifiedNormalizer ctx) t) +normalizeWith _ t = Eval.normalize t + +{-| This function generalizes `normalizeWith` by allowing the custom normalizer + to use an arbitrary `Monad` + + `normalizeWithM` can fail with an `error` if you normalize an ill-typed + expression +-} +normalizeWithM + :: (Monad m, Eq a) => NormalizerM m a -> Expr s a -> m (Expr t a) +normalizeWithM ctx e0 = loop (Syntax.denote e0) + where + loop e = case e of + Const k -> pure (Const k) + Var v -> pure (Var v) + Lam x _A b -> Lam x <$> _A' <*> b' + where + _A' = loop _A + b' = loop b + Pi x _A _B -> Pi x <$> _A' <*> _B' + where + _A' = loop _A + _B' = loop _B + App f a -> do + res <- ctx (App f a) + case res of + Just e1 -> loop e1 + Nothing -> do + f' <- loop f + a' <- loop a + case f' of + Lam x _A b₀ -> do + + let a₂ = shift 1 (V x 0) a' + let b₁ = subst (V x 0) a₂ b₀ + let b₂ = shift (-1) (V x 0) b₁ + + loop b₂ + _ -> do + case App f' a' of + App NaturalFold (NaturalLit n) -> do + let natural = Var (V "natural" 0) + let go 0 x = x + go n' x = go (n'-1) (App (Var (V "succ" 0)) x) + let n' = go n (Var (V "zero" 0)) + pure + (Lam "natural" + (Const Type) + (Lam "succ" + (Pi "_" natural natural) + (Lam "zero" + natural + n'))) + + App (App (App (App NaturalFold (NaturalLit n0)) t) succ') zero -> do + t' <- loop t + if boundedType t' then strict else lazy + where + strict = strictLoop (fromIntegral n0 :: Integer) + lazy = loop ( lazyLoop (fromIntegral n0 :: Integer)) + + strictLoop !0 = loop zero + strictLoop !n = App succ' <$> strictLoop (n - 1) >>= loop + + lazyLoop !0 = zero + lazyLoop !n = App succ' (lazyLoop (n - 1)) + App NaturalBuild g -> loop (App (App (App g Natural) succ) zero) + where + succ = Lam "n" Natural (NaturalPlus "n" (NaturalLit 1)) + + zero = NaturalLit 0 + App NaturalIsZero (NaturalLit n) -> pure (BoolLit (n == 0)) + App NaturalEven (NaturalLit n) -> pure (BoolLit (even n)) + App NaturalOdd (NaturalLit n) -> pure (BoolLit (odd n)) + App NaturalToInteger (NaturalLit n) -> pure (IntegerLit (toInteger n)) + App NaturalShow (NaturalLit n) -> + pure (TextLit (Chunks [] (Data.Text.pack (show n)))) + App (App NaturalSubtract (NaturalLit x)) (NaturalLit y) + | y >= x -> pure (NaturalLit (subtract x y)) + | otherwise -> pure (NaturalLit 0) + App (App NaturalSubtract (NaturalLit 0)) y -> pure y + App (App NaturalSubtract _) (NaturalLit 0) -> pure (NaturalLit 0) + App (App NaturalSubtract x) y | Eval.judgmentallyEqual x y -> pure (NaturalLit 0) + App IntegerClamp (IntegerLit n) + | 0 <= n -> pure (NaturalLit (fromInteger n)) + | otherwise -> pure (NaturalLit 0) + App IntegerNegate (IntegerLit n) -> + pure (IntegerLit (negate n)) + App IntegerShow (IntegerLit n) + | 0 <= n -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n)))) + | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n)))) + -- `(read . show)` is used instead of `fromInteger` because `read` uses + -- the correct rounding rule. + -- See https://gitlab.haskell.org/ghc/ghc/issues/17231. + App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n)) + App DoubleShow (DoubleLit (DhallDouble n)) -> + pure (TextLit (Chunks [] (Data.Text.pack (show n)))) + App (App OptionalBuild _A₀) g -> + loop (App (App (App g optional) just) nothing) + where + optional = App Optional _A₀ + + just = Lam "a" _A₀ (Some "a") + + nothing = App None _A₀ + App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil) + where + _A₁ = shift 1 "a" _A₀ + + list = App List _A₀ + + cons = + Lam "a" _A₀ + (Lam "as" + (App List _A₁) + (ListAppend (ListLit Nothing (pure "a")) "as") + ) + + nil = ListLit (Just (App List _A₀)) empty + App (App ListFold t) (ListLit _ xs) -> do + t' <- loop t + let list = Var (V "list" 0) + let lam term = + Lam "list" (Const Type) + (Lam "cons" (Pi "_" t' (Pi "_" list list)) + (Lam "nil" list term)) + term <- foldrM + (\x acc -> do + x' <- loop x + pure (App (App (Var (V "cons" 0)) x') acc)) + (Var (V "nil" 0)) + xs + pure (lam term) + App (App (App (App (App ListFold _) (ListLit _ xs)) t) cons) nil -> do + t' <- loop t + if boundedType t' then strict else lazy + where + strict = foldr strictCons strictNil xs + lazy = loop (foldr lazyCons lazyNil xs) + + strictNil = loop nil + lazyNil = nil + + strictCons y ys = do + App (App cons y) <$> ys >>= loop + lazyCons y ys = App (App cons y) ys + App (App ListLength _) (ListLit _ ys) -> + pure (NaturalLit (fromIntegral (Data.Sequence.length ys))) + App (App ListHead t) (ListLit _ ys) -> loop o + where + o = case Data.Sequence.viewl ys of + y :< _ -> Some y + _ -> App None t + App (App ListLast t) (ListLit _ ys) -> loop o + where + o = case Data.Sequence.viewr ys of + _ :> y -> Some y + _ -> App None t + App (App ListIndexed _A₀) (ListLit _ as₀) -> loop (ListLit t as₁) + where + as₁ = Data.Sequence.mapWithIndex adapt as₀ + + _A₂ = Record (Dhall.Map.fromList kts) + where + kts = [ ("index", Natural) + , ("value", _A₀) + ] + + t | null as₀ = Just (App List _A₂) + | otherwise = Nothing + + adapt n a_ = + RecordLit (Dhall.Map.fromList kvs) + where + kvs = [ ("index", NaturalLit (fromIntegral n)) + , ("value", a_) + ] + App (App ListReverse _) (ListLit t xs) -> + loop (ListLit t (Data.Sequence.reverse xs)) + + App (App OptionalFold t0) x0 -> do + t1 <- loop t0 + let optional = Var (V "optional" 0) + let lam term = (Lam "optional" + (Const Type) + (Lam "some" + (Pi "_" t1 optional) + (Lam "none" optional term))) + x1 <- loop x0 + pure $ case x1 of + App None _ -> lam (Var (V "none" 0)) + Some x' -> lam (App (Var (V "some" 0)) x') + _ -> App (App OptionalFold t1) x1 + + App TextShow (TextLit (Chunks [] oldText)) -> + loop (TextLit (Chunks [] newText)) + where + newText = Eval.textShow oldText + _ -> do + res2 <- ctx (App f' a') + case res2 of + Nothing -> pure (App f' a') + Just app' -> loop app' + Let (Binding _ f _ _ _ r) b -> loop b'' + where + r' = shift 1 (V f 0) r + b' = subst (V f 0) r' b + b'' = shift (-1) (V f 0) b' + Annot x _ -> loop x + Bool -> pure Bool + BoolLit b -> pure (BoolLit b) + BoolAnd x y -> decide <$> loop x <*> loop y + where + decide (BoolLit True ) r = r + decide (BoolLit False) _ = BoolLit False + decide l (BoolLit True ) = l + decide _ (BoolLit False) = BoolLit False + decide l r + | Eval.judgmentallyEqual l r = l + | otherwise = BoolAnd l r + BoolOr x y -> decide <$> loop x <*> loop y + where + decide (BoolLit False) r = r + decide (BoolLit True ) _ = BoolLit True + decide l (BoolLit False) = l + decide _ (BoolLit True ) = BoolLit True + decide l r + | Eval.judgmentallyEqual l r = l + | otherwise = BoolOr l r + BoolEQ x y -> decide <$> loop x <*> loop y + where + decide (BoolLit True ) r = r + decide l (BoolLit True ) = l + decide l r + | Eval.judgmentallyEqual l r = BoolLit True + | otherwise = BoolEQ l r + BoolNE x y -> decide <$> loop x <*> loop y + where + decide (BoolLit False) r = r + decide l (BoolLit False) = l + decide l r + | Eval.judgmentallyEqual l r = BoolLit False + | otherwise = BoolNE l r + BoolIf bool true false -> decide <$> loop bool <*> loop true <*> loop false + where + decide (BoolLit True ) l _ = l + decide (BoolLit False) _ r = r + decide b (BoolLit True) (BoolLit False) = b + decide b l r + | Eval.judgmentallyEqual l r = l + | otherwise = BoolIf b l r + Natural -> pure Natural + NaturalLit n -> pure (NaturalLit n) + NaturalFold -> pure NaturalFold + NaturalBuild -> pure NaturalBuild + NaturalIsZero -> pure NaturalIsZero + NaturalEven -> pure NaturalEven + NaturalOdd -> pure NaturalOdd + NaturalToInteger -> pure NaturalToInteger + NaturalShow -> pure NaturalShow + NaturalSubtract -> pure NaturalSubtract + NaturalPlus x y -> decide <$> loop x <*> loop y + where + decide (NaturalLit 0) r = r + decide l (NaturalLit 0) = l + decide (NaturalLit m) (NaturalLit n) = NaturalLit (m + n) + decide l r = NaturalPlus l r + NaturalTimes x y -> decide <$> loop x <*> loop y + where + decide (NaturalLit 1) r = r + decide l (NaturalLit 1) = l + decide (NaturalLit 0) _ = NaturalLit 0 + decide _ (NaturalLit 0) = NaturalLit 0 + decide (NaturalLit m) (NaturalLit n) = NaturalLit (m * n) + decide l r = NaturalTimes l r + Integer -> pure Integer + IntegerLit n -> pure (IntegerLit n) + IntegerClamp -> pure IntegerClamp + IntegerNegate -> pure IntegerNegate + IntegerShow -> pure IntegerShow + IntegerToDouble -> pure IntegerToDouble + Double -> pure Double + DoubleLit n -> pure (DoubleLit n) + DoubleShow -> pure DoubleShow + Text -> pure Text + TextLit (Chunks xys z) -> do + chunks' <- mconcat <$> chunks + case chunks' of + Chunks [("", x)] "" -> pure x + c -> pure (TextLit c) + where + chunks = + ((++ [Chunks [] z]) . concat) <$> traverse process xys + + process (x, y) = do + y' <- loop y + case y' of + TextLit c -> pure [Chunks [] x, c] + _ -> pure [Chunks [(x, y')] mempty] + TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] "")) + TextShow -> pure TextShow + List -> pure List + ListLit t es + | Data.Sequence.null es -> ListLit <$> t' <*> pure Data.Sequence.empty + | otherwise -> ListLit Nothing <$> es' + where + t' = traverse loop t + es' = traverse loop es + ListAppend x y -> decide <$> loop x <*> loop y + where + decide (ListLit _ m) r | Data.Sequence.null m = r + decide l (ListLit _ n) | Data.Sequence.null n = l + decide (ListLit t m) (ListLit _ n) = ListLit t (m <> n) + decide l r = ListAppend l r + ListBuild -> pure ListBuild + ListFold -> pure ListFold + ListLength -> pure ListLength + ListHead -> pure ListHead + ListLast -> pure ListLast + ListIndexed -> pure ListIndexed + ListReverse -> pure ListReverse + Optional -> pure Optional + Some a -> Some <$> a' + where + a' = loop a + None -> pure None + OptionalFold -> pure OptionalFold + OptionalBuild -> pure OptionalBuild + Record kts -> Record . Dhall.Map.sort <$> kts' + where + kts' = traverse loop kts + RecordLit kvs -> RecordLit . Dhall.Map.sort <$> kvs' + where + kvs' = traverse loop kvs + Union kts -> Union . Dhall.Map.sort <$> kts' + where + kts' = traverse (traverse loop) kts + Combine x y -> decide <$> loop x <*> loop y + where + decide (RecordLit m) r | Data.Foldable.null m = + r + decide l (RecordLit n) | Data.Foldable.null n = + l + decide (RecordLit m) (RecordLit n) = + RecordLit (Dhall.Map.unionWith decide m n) + decide l r = + Combine l r + CombineTypes x y -> decide <$> loop x <*> loop y + where + decide (Record m) r | Data.Foldable.null m = + r + decide l (Record n) | Data.Foldable.null n = + l + decide (Record m) (Record n) = + Record (Dhall.Map.unionWith decide m n) + decide l r = + CombineTypes l r + Prefer x y -> decide <$> loop x <*> loop y + where + decide (RecordLit m) r | Data.Foldable.null m = + r + decide l (RecordLit n) | Data.Foldable.null n = + l + decide (RecordLit m) (RecordLit n) = + RecordLit (Dhall.Map.union n m) + decide l r | Eval.judgmentallyEqual l r = + l + decide l r = + Prefer l r + RecordCompletion x y -> do + loop (Annot (Prefer (Field x "default") y) (Field x "Type")) + Merge x y t -> do + x' <- loop x + y' <- loop y + case x' of + RecordLit kvsX -> + case y' of + Field (Union ktsY) kY -> + case Dhall.Map.lookup kY ktsY of + Just Nothing -> + case Dhall.Map.lookup kY kvsX of + Just vX -> return vX + Nothing -> Merge x' y' <$> t' + _ -> + Merge x' y' <$> t' + App (Field (Union ktsY) kY) vY -> + case Dhall.Map.lookup kY ktsY of + Just (Just _) -> + case Dhall.Map.lookup kY kvsX of + Just vX -> loop (App vX vY) + Nothing -> Merge x' y' <$> t' + _ -> + Merge x' y' <$> t' + _ -> Merge x' y' <$> t' + _ -> Merge x' y' <$> t' + where + t' = traverse loop t + ToMap x t -> do + x' <- loop x + t' <- traverse loop t + case x' of + RecordLit kvsX -> do + let entry (key, value) = + RecordLit + (Dhall.Map.fromList + [ ("mapKey" , TextLit (Chunks [] key)) + , ("mapValue", value ) + ] + ) + + let keyValues = Data.Sequence.fromList (map entry (Dhall.Map.toList kvsX)) + + let listType = case t' of + Just _ | null keyValues -> + t' + _ -> + Nothing + + return (ListLit listType keyValues) + _ -> do + return (ToMap x' t') + Field r x -> do + let singletonRecordLit v = RecordLit (Dhall.Map.singleton x v) + + r' <- loop r + case r' of + RecordLit kvs -> + case Dhall.Map.lookup x kvs of + Just v -> pure v + Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x + Project r_ _ -> loop (Field r_ x) + Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x) + Nothing -> loop (Field r_ x) + Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of + Just v -> pure v + Nothing -> loop (Field l x) + Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Combine (singletonRecordLit v) r_) x) + Nothing -> loop (Field r_ x) + Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Combine l (singletonRecordLit v)) x) + Nothing -> loop (Field l x) + _ -> pure (Field r' x) + Project x (Left fields)-> do + x' <- loop x + let fieldsSet = Dhall.Set.toSet fields + case x' of + RecordLit kvs -> + pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet)) + Project y _ -> + loop (Project y (Left fields)) + Prefer l (RecordLit rKvs) -> do + let rKs = Dhall.Map.keysSet rKvs + let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs))) + let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet) + loop (Prefer l' r') + _ | null fields -> pure (RecordLit mempty) + | otherwise -> pure (Project x' (Left (Dhall.Set.sort fields))) + Project r (Right e1) -> do + e2 <- loop e1 + + case e2 of + Record kts -> do + loop (Project r (Left (Dhall.Set.fromSet (Dhall.Map.keysSet kts)))) + _ -> do + r' <- loop r + pure (Project r' (Right e2)) + Assert t -> do + t' <- loop t + + pure (Assert t') + Equivalent l r -> do + l' <- loop l + r' <- loop r + + pure (Equivalent l' r') + Note _ e' -> loop e' + ImportAlt l _r -> loop l + Embed a -> pure (Embed a) + +-- | Use this to wrap you embedded functions (see `normalizeWith`) to make them +-- polymorphic enough to be used. +type NormalizerM m a = forall s. Expr s a -> m (Maybe (Expr s a)) + +-- | An variation on `NormalizerM` for pure normalizers +type Normalizer a = NormalizerM Identity a + +-- | A reified 'Normalizer', which can be stored in structures without +-- running into impredicative polymorphism. +newtype ReifiedNormalizer a = ReifiedNormalizer + { getReifiedNormalizer :: Normalizer a } + +-- | Check if an expression is in a normal form given a context of evaluation. +-- Unlike `isNormalized`, this will fully normalize and traverse through the expression. +-- +-- It is much more efficient to use `isNormalized`. +-- +-- `isNormalizedWith` can fail with an `error` if you check an ill-typed +-- expression +isNormalizedWith :: (Eq s, Eq a) => Normalizer a -> Expr s a -> Bool +isNormalizedWith ctx e = e == normalizeWith (Just (ReifiedNormalizer ctx)) e + +-- | Quickly check if an expression is in normal form +-- +-- Given a well-typed expression @e@, @'isNormalized' e@ is equivalent to +-- @e == 'normalize' e@. +-- +-- Given an ill-typed expression, 'isNormalized' may fail with an error, or +-- evaluate to either False or True! +isNormalized :: Eq a => Expr s a -> Bool +isNormalized e0 = loop (Syntax.denote e0) + where + loop e = case e of + Const _ -> True + Var _ -> True + Lam _ a b -> loop a && loop b + Pi _ a b -> loop a && loop b + App f a -> loop f && loop a && case App f a of + App (Lam _ _ _) _ -> False + App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False + App NaturalFold (NaturalLit _) -> False + App NaturalBuild _ -> False + App NaturalIsZero (NaturalLit _) -> False + App NaturalEven (NaturalLit _) -> False + App NaturalOdd (NaturalLit _) -> False + App NaturalShow (NaturalLit _) -> False + App (App NaturalSubtract (NaturalLit _)) (NaturalLit _) -> False + App (App NaturalSubtract (NaturalLit 0)) _ -> False + App (App NaturalSubtract _) (NaturalLit 0) -> False + App (App NaturalSubtract x) y -> not (Eval.judgmentallyEqual x y) + App NaturalToInteger (NaturalLit _) -> False + App IntegerNegate (IntegerLit _) -> False + App IntegerClamp (IntegerLit _) -> False + App IntegerShow (IntegerLit _) -> False + App IntegerToDouble (IntegerLit _) -> False + App DoubleShow (DoubleLit _) -> False + App (App OptionalBuild _) _ -> False + App (App ListBuild _) _ -> False + App (App ListFold _) (ListLit _ _) -> False + App (App ListLength _) (ListLit _ _) -> False + App (App ListHead _) (ListLit _ _) -> False + App (App ListLast _) (ListLit _ _) -> False + App (App ListIndexed _) (ListLit _ _) -> False + App (App ListReverse _) (ListLit _ _) -> False + App (App OptionalFold _) (Some _) -> False + App (App OptionalFold _) (App None _) -> False + App TextShow (TextLit (Chunks [] _)) -> + False + _ -> True + Let _ _ -> False + Annot _ _ -> False + Bool -> True + BoolLit _ -> True + BoolAnd x y -> loop x && loop y && decide x y + where + decide (BoolLit _) _ = False + decide _ (BoolLit _) = False + decide l r = not (Eval.judgmentallyEqual l r) + BoolOr x y -> loop x && loop y && decide x y + where + decide (BoolLit _) _ = False + decide _ (BoolLit _) = False + decide l r = not (Eval.judgmentallyEqual l r) + BoolEQ x y -> loop x && loop y && decide x y + where + decide (BoolLit True) _ = False + decide _ (BoolLit True) = False + decide l r = not (Eval.judgmentallyEqual l r) + BoolNE x y -> loop x && loop y && decide x y + where + decide (BoolLit False) _ = False + decide _ (BoolLit False ) = False + decide l r = not (Eval.judgmentallyEqual l r) + BoolIf x y z -> + loop x && loop y && loop z && decide x y z + where + decide (BoolLit _) _ _ = False + decide _ (BoolLit True) (BoolLit False) = False + decide _ l r = not (Eval.judgmentallyEqual l r) + Natural -> True + NaturalLit _ -> True + NaturalFold -> True + NaturalBuild -> True + NaturalIsZero -> True + NaturalEven -> True + NaturalOdd -> True + NaturalShow -> True + NaturalSubtract -> True + NaturalToInteger -> True + NaturalPlus x y -> loop x && loop y && decide x y + where + decide (NaturalLit 0) _ = False + decide _ (NaturalLit 0) = False + decide (NaturalLit _) (NaturalLit _) = False + decide _ _ = True + NaturalTimes x y -> loop x && loop y && decide x y + where + decide (NaturalLit 0) _ = False + decide _ (NaturalLit 0) = False + decide (NaturalLit 1) _ = False + decide _ (NaturalLit 1) = False + decide (NaturalLit _) (NaturalLit _) = False + decide _ _ = True + Integer -> True + IntegerLit _ -> True + IntegerClamp -> True + IntegerNegate -> True + IntegerShow -> True + IntegerToDouble -> True + Double -> True + DoubleLit _ -> True + DoubleShow -> True + Text -> True + TextLit (Chunks [("", _)] "") -> False + TextLit (Chunks xys _) -> all (all check) xys + where + check y = loop y && case y of + TextLit _ -> False + _ -> True + TextAppend _ _ -> False + TextShow -> True + List -> True + ListLit t es -> all loop t && all loop es + ListAppend x y -> loop x && loop y && decide x y + where + decide (ListLit _ m) _ | Data.Sequence.null m = False + decide _ (ListLit _ n) | Data.Sequence.null n = False + decide (ListLit _ _) (ListLit _ _) = False + decide _ _ = True + ListBuild -> True + ListFold -> True + ListLength -> True + ListHead -> True + ListLast -> True + ListIndexed -> True + ListReverse -> True + Optional -> True + Some a -> loop a + None -> True + OptionalFold -> True + OptionalBuild -> True + Record kts -> Dhall.Map.isSorted kts && all loop kts + RecordLit kvs -> Dhall.Map.isSorted kvs && all loop kvs + Union kts -> Dhall.Map.isSorted kts && all (all loop) kts + Combine x y -> loop x && loop y && decide x y + where + decide (RecordLit m) _ | Data.Foldable.null m = False + decide _ (RecordLit n) | Data.Foldable.null n = False + decide (RecordLit _) (RecordLit _) = False + decide _ _ = True + CombineTypes x y -> loop x && loop y && decide x y + where + decide (Record m) _ | Data.Foldable.null m = False + decide _ (Record n) | Data.Foldable.null n = False + decide (Record _) (Record _) = False + decide _ _ = True + Prefer x y -> loop x && loop y && decide x y + where + decide (RecordLit m) _ | Data.Foldable.null m = False + decide _ (RecordLit n) | Data.Foldable.null n = False + 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 + ToMap x t -> case x of + RecordLit _ -> False + _ -> loop x && all loop t + Field r k -> case r of + RecordLit _ -> False + Project _ _ -> False + Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r + Prefer _ (RecordLit _) -> False + Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r + Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r + _ -> loop r + Project r p -> loop r && + case p of + Left s -> case r of + RecordLit _ -> False + Project _ _ -> False + Prefer _ (RecordLit _) -> False + _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s + Right e' -> case e' of + Record _ -> False + _ -> loop e' + Assert t -> loop t + Equivalent l r -> loop l && loop r + Note _ e' -> loop e' + ImportAlt _ _ -> False + Embed _ -> True + +{-| Detect if the given variable is free within the given expression + +>>> "x" `freeIn` "x" +True +>>> "x" `freeIn` "y" +False +>>> "x" `freeIn` Lam "x" (Const Type) "x" +False +-} +freeIn :: Eq a => Var -> Expr s a -> Bool +variable@(V var i) `freeIn` expression = + subst variable (Var (V var (i + 1))) strippedExpression + /= strippedExpression + where + denote' :: Expr t b -> Expr () b + denote' = Syntax.denote + + strippedExpression = denote' expression diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -8,11 +8,13 @@ exprFromText , exprAndHeaderFromText , censor + , createHeader -- * Parsers , expr, exprA -- * Types + , Header(..) , Src(..) , SourcedException(..) , ParseError(..) @@ -23,7 +25,7 @@ import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Void (Void) -import Dhall.Core +import Dhall.Syntax import Dhall.Src (Src(..)) import Prelude hiding (const, pi) import Text.Megaparsec (ParseErrorBundle(..), PosState(..)) @@ -34,7 +36,7 @@ import qualified Text.Megaparsec import Dhall.Parser.Combinators -import Dhall.Parser.Token +import Dhall.Parser.Token hiding (text) import Dhall.Parser.Expression -- | Parser for a top-level Dhall expression @@ -48,11 +50,7 @@ -- | A parsing error data ParseError = ParseError { -#if MIN_VERSION_megaparsec(7, 0, 0) unwrap :: Text.Megaparsec.ParseErrorBundle Text Void -#else - unwrap :: Text.Megaparsec.ParseError Char Void -#endif , input :: Text } @@ -76,11 +74,7 @@ instance Show ParseError where show (ParseError {..}) = -#if MIN_VERSION_megaparsec(7, 0, 0) "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.errorBundlePretty unwrap -#else - "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.parseErrorPretty unwrap -#endif instance Exception ParseError @@ -92,6 +86,17 @@ -> Either ParseError (Expr Src Import) exprFromText delta text = fmap snd (exprAndHeaderFromText delta text) +-- | A header corresponds to the leading comment at the top of a Dhall file. +-- +-- The header includes comment characters but is stripped of leading spaces and +-- trailing newlines +newtype Header = Header Text deriving Show + +-- | Create a header with stripped leading spaces and trailing newlines +createHeader :: Text -> Header +createHeader = + Header . Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n') + {-| Like `exprFromText` but also returns the leading comments and whitespace (i.e. header) up to the last newline before the code begins @@ -108,10 +113,10 @@ :: String -- ^ User-friendly name describing the input expression, -- used in parsing error messages -> Text -- ^ Input expression to parse - -> Either ParseError (Text, Expr Src Import) + -> Either ParseError (Header, Expr Src Import) exprAndHeaderFromText delta text = case result of Left errInfo -> Left (ParseError { unwrap = errInfo, input = text }) - Right (txt, r) -> Right (stripHeader txt, r) + Right (txt, r) -> Right (createHeader txt, r) where parser = do (bytes, _) <- Text.Megaparsec.match whitespace @@ -120,5 +125,3 @@ return (bytes, r) result = Text.Megaparsec.parse (unParser parser) delta text - - stripHeader = Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n') diff --git a/src/Dhall/Parser/Combinators.hs b/src/Dhall/Parser/Combinators.hs --- a/src/Dhall/Parser/Combinators.hs +++ b/src/Dhall/Parser/Combinators.hs @@ -24,15 +24,11 @@ import qualified Data.Char import qualified Data.Set import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Set import qualified Text.Megaparsec -#if !MIN_VERSION_megaparsec(7, 0, 0) -import qualified Text.Megaparsec.Char as Text.Megaparsec (satisfy) -#endif import qualified Text.Megaparsec.Char import qualified Text.Parser.Char import qualified Text.Parser.Combinators @@ -49,7 +45,7 @@ <> "\n" <> "\n" <> Pretty.renderString - (Pretty.layoutPretty Dhall.Pretty.layoutOpts (pretty source)) + (Dhall.Pretty.layout (pretty source)) -- | Doesn't force the 'Text' part laxSrcEq :: Src -> Src -> Bool @@ -127,9 +123,13 @@ -- {-# INLINE mplus #-} instance Text.Megaparsec.MonadParsec Void Text Parser where +#if MIN_VERSION_megaparsec(8, 0, 0) + parseError e = Parser (Text.Megaparsec.parseError e) +#else failure u e = Parser (Text.Megaparsec.failure u e) fancyFailure e = Parser (Text.Megaparsec.fancyFailure e) +#endif label l (Parser p) = Parser (Text.Megaparsec.label l p) @@ -197,11 +197,7 @@ notChar = Text.Megaparsec.Char.char -#if MIN_VERSION_megaparsec(7, 0, 0) anyChar = Text.Megaparsec.anySingle -#else - anyChar = Text.Megaparsec.Char.anyChar -#endif string = fmap Data.Text.unpack . Text.Megaparsec.Char.string . fromString 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 @@ -10,11 +10,12 @@ import Control.Applicative (Alternative(..), optional) 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.Core +import Dhall.Syntax import Dhall.Src (Src(..)) import Prelude hiding (const, pi) import Text.Parser.Combinators (choice, try, ()) @@ -31,10 +32,6 @@ import qualified Data.Text.Encoding import qualified Dhall.Crypto import qualified Text.Megaparsec -#if !MIN_VERSION_megaparsec(7, 0, 0) -import qualified Text.Megaparsec.Char as Text.Megaparsec -#endif -import qualified Text.Parser.Char import Dhall.Parser.Combinators import Dhall.Parser.Token @@ -43,31 +40,19 @@ getSourcePos :: Text.Megaparsec.MonadParsec e s m => m Text.Megaparsec.SourcePos getSourcePos = -#if MIN_VERSION_megaparsec(7, 0, 0) Text.Megaparsec.getSourcePos -#else - Text.Megaparsec.getPosition -#endif {-# INLINE getSourcePos #-} -- | Get the current source offset (in tokens) getOffset :: Text.Megaparsec.MonadParsec e s m => m Int -#if MIN_VERSION_megaparsec(7, 0, 0) getOffset = Text.Megaparsec.stateOffset <$> Text.Megaparsec.getParserState -#else -getOffset = Text.Megaparsec.stateTokensProcessed <$> Text.Megaparsec.getParserState -#endif {-# INLINE getOffset #-} -- | Set the current source offset setOffset :: Text.Megaparsec.MonadParsec e s m => Int -> m () -#if MIN_VERSION_megaparsec(7, 0, 0) -setOffset o = Text.Megaparsec.updateParserState $ \(Text.Megaparsec.State s _ pst) -> - Text.Megaparsec.State s o pst -#else -setOffset o = Text.Megaparsec.updateParserState $ \(Text.Megaparsec.State s p _ stw) -> - Text.Megaparsec.State s p o stw -#endif +setOffset o = Text.Megaparsec.updateParserState $ \state -> + state + { Text.Megaparsec.stateOffset = o } {-# INLINE setOffset #-} {-| Wrap a `Parser` to still match the same text but return only the `Src` @@ -129,9 +114,7 @@ parsers :: Parser a -> Parsers a parsers embedded = Parsers {..} where - completeExpression_ = do - whitespace - expression + completeExpression_ = whitespace *> expression <* whitespace expression = noted @@ -147,53 +130,65 @@ where alternative0 = do _lambda + whitespace _openParens + whitespace a <- label + whitespace _colon + nonemptyWhitespace b <- expression + whitespace _closeParens + whitespace _arrow + whitespace c <- expression return (Lam a b c) alternative1 = do - _if + try (_if *> nonemptyWhitespace) a <- expression - _then + whitespace + try (_then *> nonemptyWhitespace) b <- expression - _else + whitespace + try (_else *> nonemptyWhitespace) c <- expression return (BoolIf a b c) alternative2 = do let binding = do - _letOnly - - src0 <- src nonemptyWhitespace + src0 <- try (_let *> src nonemptyWhitespace) - c <- labelOnly + c <- label src1 <- src whitespace d <- optional (do - _colonOnly + _colon src2 <- src nonemptyWhitespace e <- expression + + whitespace + return (Just src2, e) ) - _equalOnly + _equal src3 <- src whitespace f <- expression + whitespace + return (Binding (Just src0) c (Just src1) d (Just src3) f) as <- Data.List.NonEmpty.some1 binding - _in + try (_in *> nonemptyWhitespace) b <- expression @@ -214,22 +209,27 @@ -- (Let y … -- (Note … -- (Let z … - return (Dhall.Core.wrapInLets as b) + return (Dhall.Syntax.wrapInLets as b) alternative3 = do - _forall - _openParens + try (_forall *> whitespace *> _openParens) + whitespace a <- label + whitespace _colon + nonemptyWhitespace b <- expression + whitespace _closeParens + whitespace _arrow + whitespace c <- expression return (Pi a b c) alternative4 = do - _assert - _colon + try (_assert *> whitespace *> _colon) + nonemptyWhitespace a <- expression return (Assert a) @@ -238,81 +238,78 @@ let alternative4A = do _arrow + whitespace b <- expression + whitespace return (Pi "_" a b) let alternative4B = do _colon - + nonemptyWhitespace b <- expression - case shallowDenote a of - ListLit _ [] -> + ListLit Nothing [] -> return (ListLit (Just b) []) - Merge c d _ -> + Merge c d Nothing -> return (Merge c d (Just b)) - ToMap c _ -> + ToMap c Nothing -> return (ToMap c (Just b)) _ -> return (Annot a b) alternative4A <|> alternative4B <|> pure a - operatorExpression = precedence0Expression + operatorExpression = + foldr makeOperatorExpression applicationExpression operatorParsers - makeOperatorExpression subExpression operatorParser = + makeOperatorExpression operatorParser subExpression = noted (do a <- subExpression - b <- Text.Megaparsec.many $ do - op <- operatorParser - r <- subExpression - return (\l -> l `op` r) - return (foldl (\x f -> f x) a b) ) - - precedence0Operator = - ImportAlt <$ _importAlt - <|> BoolOr <$ _or - <|> TextAppend <$ _textAppend - <|> NaturalPlus <$ _plus - <|> ListAppend <$ _listAppend - - precedence1Operator = - BoolAnd <$ _and - <|> Combine <$ _combine - - precedence2Operator = - CombineTypes <$ _combineTypes - <|> Prefer <$ _prefer - <|> NaturalTimes <$ _times - <|> BoolEQ <$ _doubleEqual + whitespace - precedence3Operator - = BoolNE <$ _notEqual - <|> Equivalent <$ _equivalent + b <- Text.Megaparsec.many $ do + op <- operatorParser - precedence0Expression = - makeOperatorExpression precedence1Expression precedence0Operator + r <- subExpression - precedence1Expression = - makeOperatorExpression precedence2Expression precedence1Operator + whitespace - precedence2Expression = - makeOperatorExpression precedence3Expression precedence2Operator + return (\l -> l `op` r) + return (foldl' (\x f -> f x) a b)) - precedence3Expression = - makeOperatorExpression applicationExpression precedence3Operator + operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)] + operatorParsers = + [ ImportAlt <$ _importAlt <* nonemptyWhitespace + , BoolOr <$ _or <* whitespace + , NaturalPlus <$ _plus <* nonemptyWhitespace + , TextAppend <$ _textAppend <* whitespace + , ListAppend <$ _listAppend <* whitespace + , BoolAnd <$ _and <* whitespace + , Combine <$ _combine <* whitespace + , Prefer <$ _prefer <* whitespace + , CombineTypes <$ _combineTypes <* whitespace + , NaturalTimes <$ _times <* whitespace + , BoolEQ <$ _doubleEqual <* whitespace + , BoolNE <$ _notEqual <* whitespace + , Equivalent <$ _equivalent <* whitespace + ] applicationExpression = do - f <- (do _Some; return Some) + f <- (Some <$ try (_Some <* nonemptyWhitespace)) <|> return id a <- noted importExpression_ - b <- Text.Megaparsec.many (noted importExpression_) - return (foldl app (f a) b) + bs <- Text.Megaparsec.many . try $ do + (sep, _) <- Text.Megaparsec.match nonemptyWhitespace + b <- importExpression_ + return (sep, b) + return (foldl' app (f a) bs) where - app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = - Note (Src before after (bytesL <> bytesR)) (App nL nR) - app nL nR = - App nL nR + app a (sep, b) + | Note (Src left _ bytesL) _ <- a + , Note (Src _ right bytesR) _ <- b + = Note (Src left right (bytesL <> sep <> bytesR)) (App a b) + app a (_, b) = + App a b importExpression_ = noted (choice [ alternative0, alternative1 ]) where @@ -326,8 +323,10 @@ a <- selectorExpression mb <- optional (do - _doubleColon + try (whitespace *> _doubleColon) + whitespace + selectorExpression ) case mb of @@ -337,7 +336,7 @@ selectorExpression = noted (do a <- primitiveExpression - let recordType = _openParens *> expression <* _closeParens + let recordType = _openParens *> whitespace *> expression <* whitespace <* _closeParens let field x e = Field e x let projectBySet xs e = Project e (Left xs) @@ -348,8 +347,8 @@ <|> fmap projectBySet labels <|> fmap projectByExpression recordType - b <- Text.Megaparsec.many (try (do _dot; alternatives)) - return (foldl (\e k -> k e) a b) ) + b <- Text.Megaparsec.many (try (whitespace *> _dot *> whitespace *> alternatives)) + return (foldl' (\e k -> k e) a b) ) primitiveExpression = noted @@ -365,8 +364,7 @@ , alternative08 , alternative37 , alternative09 - - , builtin "built-in expression" + , builtin ] ) <|> alternative38 @@ -392,26 +390,31 @@ alternative04 = (do _openBrace - _ <- optional _comma + whitespace + _ <- optional (_comma *> whitespace) + a <- recordTypeOrLiteral + whitespace + _closeBrace - return a ) "record type or literal" + return a ) "literal" alternative05 = unionType alternative06 = listLiteral alternative07 = do - _merge + try (_merge *> nonemptyWhitespace) a <- importExpression_ + nonemptyWhitespace b <- importExpression_ "second argument to ❰merge❱" return (Merge a b Nothing) alternative08 = do - _toMap + try (_toMap *> nonemptyWhitespace) a <- importExpression_ return (ToMap a Nothing) @@ -453,7 +456,9 @@ ] 'I' -> choice - [ IntegerShow <$ _IntegerShow + [ IntegerClamp <$ _IntegerClamp + , IntegerNegate <$ _IntegerNegate + , IntegerShow <$ _IntegerShow , IntegerToDouble <$ _IntegerToDouble , Integer <$ _Integer ] @@ -499,7 +504,9 @@ alternative38 = do _openParens + whitespace a <- expression + whitespace _closeParens return a @@ -512,9 +519,9 @@ ] where interpolation = do - _ <- Text.Parser.Char.text "${" + _ <- text "${" e <- completeExpression_ - _ <- Text.Parser.Char.char '}' + _ <- char '}' return (Chunks [(mempty, e)] mempty) unescapedCharacterFast = do @@ -528,11 +535,11 @@ ) && c /= '$' unescapedCharacterSlow = do - _ <- Text.Parser.Char.char '$' + _ <- char '$' return (Chunks [] "$") escapedCharacter = do - _ <- Text.Parser.Char.char '\\' + _ <- char '\\' c <- choice [ quotationMark , dollarSign @@ -547,53 +554,60 @@ ] return (Chunks [] (Data.Text.singleton c)) where - quotationMark = Text.Parser.Char.char '"' + quotationMark = char '"' - dollarSign = Text.Parser.Char.char '$' + dollarSign = char '$' - backSlash = Text.Parser.Char.char '\\' + backSlash = char '\\' - forwardSlash = Text.Parser.Char.char '/' + forwardSlash = char '/' - backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b' + backSpace = do _ <- char 'b'; return '\b' - formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f' + formFeed = do _ <- char 'f'; return '\f' - lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n' + lineFeed = do _ <- char 'n'; return '\n' - carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r' + carriageReturn = do _ <- char 'r'; return '\r' - tab = do _ <- Text.Parser.Char.char 't'; return '\t' + tab = do _ <- char 't'; return '\t' unicode = do - _ <- Text.Parser.Char.char 'u'; + _ <- char 'u'; let toNumber = Data.List.foldl' (\x y -> x * 16 + y) 0 - let fourCharacterEscapeSequence = - fmap toNumber (Control.Monad.replicateM 4 hexNumber) + let fourCharacterEscapeSequence = do + ns <- Control.Monad.replicateM 4 hexNumber + + let number = toNumber ns + Control.Monad.guard (validCodepoint number) + <|> fail "Invalid Unicode code point" + + return number + let bracedEscapeSequence = do - _ <- Text.Parser.Char.char '{' + _ <- char '{' ns <- some hexNumber let number = toNumber ns - Control.Monad.guard (number <= 0x10FFFF && validCodepoint (Char.chr number)) + Control.Monad.guard (number <= 0x10FFFD && validCodepoint number) <|> fail "Invalid Unicode code point" - _ <- Text.Parser.Char.char '}' + _ <- char '}' - return (toNumber ns) + return number n <- bracedEscapeSequence <|> fourCharacterEscapeSequence return (Char.chr n) doubleQuotedLiteral = do - _ <- Text.Parser.Char.char '"' + _ <- char '"' chunks <- Text.Megaparsec.many doubleQuotedChunk - _ <- Text.Parser.Char.char '"' + _ <- char '"' return (mconcat chunks) singleQuoteContinue = @@ -614,19 +628,19 @@ return ("''" <> b) interpolation = do - _ <- Text.Parser.Char.text "${" + _ <- text "${" a <- completeExpression_ - _ <- Text.Parser.Char.char '}' + _ <- char '}' b <- singleQuoteContinue return (Chunks [(mempty, a)] mempty <> b) escapeInterpolation = do - _ <- Text.Parser.Char.text "''${" + _ <- text "''${" b <- singleQuoteContinue return ("${" <> b) endLiteral = do - _ <- Text.Parser.Char.text "''" + _ <- text "''" return mempty unescapedCharacterFast = do @@ -650,25 +664,22 @@ return (Chunks [] a <> b) tab = do - _ <- Text.Parser.Char.char '\t' + _ <- char '\t' "tab" b <- singleQuoteContinue return ("\t" <> b) singleQuoteLiteral = do - _ <- Text.Parser.Char.text "''" + _ <- text "''" _ <- endOfLine a <- singleQuoteContinue return (toDoubleQuoted a) where - endOfLine = - void (Text.Parser.Char.char '\n' ) - <|> void (Text.Parser.Char.text "\r\n") + endOfLine = (void (char '\n') <|> void (text "\r\n")) "newline" textLiteral = (do literal <- doubleQuotedLiteral <|> singleQuoteLiteral - whitespace - return (TextLit literal) ) "text literal" + return (TextLit literal) ) "literal" recordTypeOrLiteral = choice @@ -688,28 +699,70 @@ nonEmptyRecordTypeOrLiteral = do a <- anyLabel + whitespace + let nonEmptyRecordType = do _colon + + nonemptyWhitespace + b <- expression + + whitespace + e <- Text.Megaparsec.many (do _comma + + whitespace + c <- anyLabel + + whitespace + _colon + + nonemptyWhitespace + d <- expression + + whitespace + return (c, d) ) + m <- toMap ((a, b) : e) + return (Record m) let nonEmptyRecordLiteral = do _equal + + whitespace + b <- expression + + whitespace + e <- Text.Megaparsec.many (do _comma + + whitespace + c <- anyLabel + + whitespace + _equal + + whitespace + d <- expression + + whitespace + return (c, d) ) + m <- toMap ((a, b) : e) + return (RecordLit m) nonEmptyRecordType <|> nonEmptyRecordLiteral @@ -717,48 +770,53 @@ unionType = (do _openAngle - _ <- optional _bar + whitespace + _ <- optional (_bar *> whitespace) + let unionTypeEntry = do a <- anyLabel - b <- optional (do _colon; expression) + whitespace + b <- optional (_colon *> nonemptyWhitespace *> expression <* whitespace) return (a, b) - kvs <- Text.Megaparsec.sepBy unionTypeEntry _bar + kvs <- Text.Megaparsec.sepBy unionTypeEntry (_bar *> whitespace) m <- toMap kvs _closeAngle - return (Union m) ) "union type" + return (Union m) ) "literal" listLiteral = (do _openBracket - _ <- optional _comma + whitespace - a <- Text.Megaparsec.sepBy expression _comma + _ <- optional (_comma *> whitespace) + a <- Text.Megaparsec.sepBy (expression <* whitespace) (_comma *> whitespace) + _closeBracket - return (ListLit Nothing (Data.Sequence.fromList a)) ) "list literal" + return (ListLit Nothing (Data.Sequence.fromList a)) ) "literal" + {-| Parse an environment variable import This corresponds to the @env@ rule from the official grammar -} env :: Parser ImportType env = do - _ <- Text.Parser.Char.text "env:" + _ <- text "env:" a <- (alternative0 <|> alternative1) - whitespace return (Env a) where alternative0 = bashEnvironmentVariable alternative1 = do - _ <- Text.Parser.Char.char '"' + _ <- char '"' a <- posixEnvironmentVariable - _ <- Text.Parser.Char.char '"' + _ <- char '"' return a -- | Parse a local import without trailing whitespace @@ -801,7 +859,6 @@ local :: Parser ImportType local = do a <- localOnly - whitespace return a {-| Parse an HTTP(S) import @@ -811,9 +868,8 @@ http :: Parser ImportType http = do url <- httpRaw - whitespace headers <- optional (do - _using + try (whitespace *> _using *> nonemptyWhitespace) importExpression import_ ) return (Remote (url { headers })) @@ -845,10 +901,9 @@ -} importHash_ :: Parser Dhall.Crypto.SHA256Digest importHash_ = do - _ <- Text.Parser.Char.text "sha256:" - text <- count 64 (satisfy hexdig "hex digit") - whitespace - let strictBytes16 = Data.Text.Encoding.encodeUtf8 text + _ <- text "sha256:" + t <- count 64 (satisfy hexdig "hex digit") + let strictBytes16 = Data.Text.Encoding.encodeUtf8 t strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of Left string -> fail string Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) @@ -863,7 +918,7 @@ importHashed_ :: Parser ImportHashed importHashed_ = do importType <- importType_ - hash <- optional importHash_ + hash <- optional (try (nonemptyWhitespace *> importHash_)) return (ImportHashed {..}) {-| Parse an `Import` @@ -877,7 +932,8 @@ return (Import {..}) ) "import" where alternative = do - _as + try (whitespace *> _as *> nonemptyWhitespace) + (_Text >> pure RawText) <|> (_Location >> pure Location) -- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result 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 @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} + -- | Parse Dhall tokens. Even though we don't have a tokenizer per-se this --- module is useful for keeping some small parsing utilities. module Dhall.Parser.Token ( @@ -9,8 +10,9 @@ bashEnvironmentVariable, posixEnvironmentVariable, ComponentType(..), + text, + char, file_, - labelOnly, label, anyLabel, labels, @@ -26,7 +28,6 @@ _if, _then, _else, - _letOnly, _let, _in, _as, @@ -44,6 +45,8 @@ _NaturalToInteger, _NaturalShow, _NaturalSubtract, + _IntegerClamp, + _IntegerNegate, _IntegerShow, _IntegerToDouble, _DoubleShow, @@ -70,7 +73,6 @@ _Kind, _Sort, _Location, - _equalOnly, _equal, _or, _plus, @@ -91,7 +93,6 @@ _comma, _openParens, _closeParens, - _colonOnly, _colon, _at, _equivalent, @@ -109,10 +110,11 @@ import Dhall.Parser.Combinators import Control.Applicative (Alternative(..), optional) +import Data.Bits ((.&.)) import Data.Functor (void) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) -import Dhall.Core +import Dhall.Syntax import Dhall.Set (Set) import Prelude hiding (const, pi) import Text.Parser.Combinators (choice, try, ()) @@ -134,12 +136,14 @@ import qualified Text.Parser.Token --- | Returns `True` if the given `Char` is a valid Unicode codepoint -validCodepoint :: Char -> Bool +-- | Returns `True` if the given `Int` is a valid Unicode codepoint +validCodepoint :: Int -> Bool validCodepoint c = - not (category == Char.Surrogate || category == Char.NotAssigned) + not (category == Char.Surrogate + || c .&. 0xFFFE == 0xFFFE + || c .&. 0xFFFF == 0xFFFF) where - category = Char.generalCategory c + category = Char.generalCategory (Char.chr c) {-| Parse 0 or more whitespace characters (including comments) @@ -176,8 +180,8 @@ signPrefix :: Num a => Parser (a -> a) signPrefix = (do - let positive = fmap (\_ -> id ) (Text.Parser.Char.char '+') - let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') + let positive = fmap (\_ -> id ) (char '+') + let negative = fmap (\_ -> negate) (char '-') positive <|> negative ) "sign" {-| Parse a `Double` literal @@ -188,7 +192,7 @@ doubleLiteral = (do sign <- signPrefix <|> pure id a <- Text.Parser.Token.double - return (sign a) ) "double literal" + return (sign a) ) "literal" {-| Parse a signed @Infinity@ @@ -197,10 +201,10 @@ -} doubleInfinity :: Parser Double doubleInfinity = (do - let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') + let negative = fmap (\_ -> negate) (char '-') sign <- negative <|> pure id - a <- Text.Parser.Char.text "Infinity" >> whitespace >> return (1.0/0.0) - return (sign a) ) "double infinity" + a <- text "Infinity" >> return (1.0/0.0) + return (sign a) ) "literal" {-| Parse an `Integer` literal @@ -210,8 +214,7 @@ integerLiteral = (do sign <- signPrefix a <- Text.Megaparsec.Char.Lexer.decimal - whitespace - return (sign a) ) "integer literal" + return (sign a) ) "literal" {-| Parse a `Natural` literal @@ -220,8 +223,7 @@ naturalLiteral :: Parser Natural naturalLiteral = (do a <- Text.Megaparsec.Char.Lexer.decimal - whitespace - return a ) "natural literal" + return a ) "literal" {-| Parse an identifier (i.e. a variable or built-in) @@ -233,10 +235,11 @@ identifier = do x <- label - let indexed = do - _ <- Text.Parser.Char.char '@' - n <- Text.Megaparsec.Char.Lexer.decimal + let indexed = try $ do whitespace + _at + whitespace + n <- Text.Megaparsec.Char.Lexer.decimal return n n <- indexed <|> pure 0 @@ -246,7 +249,7 @@ whitespaceChunk = choice [ void (Dhall.Parser.Combinators.takeWhile1 predicate) - , void (Text.Parser.Char.text "\r\n") + , void (Text.Parser.Char.text "\r\n" "newline") , lineComment , blockComment ] "whitespace" @@ -277,7 +280,7 @@ lineComment :: Parser () lineComment = do - _ <- Text.Parser.Char.text "--" + _ <- text "--" let predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' @@ -288,12 +291,13 @@ return () where endOfLine = - void (Text.Parser.Char.char '\n' ) + ( void (Text.Parser.Char.char '\n' ) <|> void (Text.Parser.Char.text "\r\n") + ) "newline" blockComment :: Parser () blockComment = do - _ <- Text.Parser.Char.text "{-" + _ <- text "{-" blockCommentContinue blockCommentChunk :: Parser () @@ -316,12 +320,12 @@ where predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' - endOfLine = void (Text.Parser.Char.text "\r\n") + endOfLine = void (Text.Parser.Char.text "\r\n" "newline") blockCommentContinue :: Parser () blockCommentContinue = endOfComment <|> continue where - endOfComment = void (Text.Parser.Char.text "-}") + endOfComment = void (text "-}") continue = do blockCommentChunk @@ -331,9 +335,9 @@ simpleLabel allowReserved = try (do c <- Text.Parser.Char.satisfy headCharacter rest <- Dhall.Parser.Combinators.takeWhile tailCharacter - let text = Data.Text.cons c rest - Control.Monad.guard (allowReserved || not (Data.HashSet.member text reservedIdentifiers)) - return text ) + let t = Data.Text.cons c rest + Control.Monad.guard (allowReserved || not (Data.HashSet.member t reservedIdentifiers)) + return t ) where headCharacter c = alpha c || c == '_' @@ -341,9 +345,9 @@ backtickLabel :: Parser Text backtickLabel = do - _ <- Text.Parser.Char.char '`' + _ <- char '`' t <- takeWhile1 predicate - _ <- Text.Parser.Char.char '`' + _ <- char '`' return t where predicate c = @@ -359,6 +363,7 @@ labels :: Parser (Set Text) labels = do _openBrace + whitespace xs <- nonEmptyLabels <|> emptyLabels _closeBrace return xs @@ -367,13 +372,10 @@ nonEmptyLabels = do x <- anyLabel - xs <- many (do _ <- _comma; anyLabel) + whitespace + xs <- many (do _comma; whitespace; l <- anyLabel; whitespace; return l) noDuplicates (x : xs) --- | Parse a label without parsing trailing whitespace -labelOnly :: Parser Text -labelOnly = backtickLabel <|> simpleLabel False "label" - {-| Parse a label (e.g. a variable\/field\/alternative name) Rejects labels that match built-in names (e.g. @Natural/even@) @@ -381,10 +383,7 @@ This corresponds to the @nonreserved-label@ rule in the official grammar -} label :: Parser Text -label = (do - t <- backtickLabel <|> simpleLabel False - whitespace - return t ) "label" +label = backtickLabel <|> simpleLabel False "label" {-| Same as `label` except that built-in names are allowed @@ -393,7 +392,6 @@ anyLabel :: Parser Text anyLabel = (do t <- backtickLabel <|> simpleLabel True - whitespace return t ) "any label" {-| Parse a valid Bash environment variable name @@ -422,7 +420,7 @@ escapeCharacter <|> satisfy predicate1 where escapeCharacter = do - _ <- Text.Parser.Char.char '\\' + _ <- char '\\' c <- Text.Parser.Char.satisfy (`elem` ("\"\\abfnrtv" :: String)) @@ -463,20 +461,20 @@ let pathData = case componentType of FileComponent -> do - Text.Megaparsec.takeWhile1P Nothing Dhall.Core.pathCharacter + Text.Megaparsec.takeWhile1P Nothing Dhall.Syntax.pathCharacter URLComponent -> do star pchar let quotedPathData = do - _ <- Text.Parser.Char.char '"' - text <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter - _ <- Text.Parser.Char.char '"' + _ <- char '"' + t <- Text.Megaparsec.takeWhile1P Nothing quotedPathCharacter + _ <- char '"' case componentType of FileComponent -> do - return text + return t URLComponent -> do - return (URI.Encode.encodeText text) + return (URI.Encode.encodeText t) quotedPathData <|> pathData @@ -649,20 +647,40 @@ unreserved c = alphaNum c || c == '-' || c == '.' || c == '_' || c == '~' -reserved :: Data.Text.Text -> Parser () -reserved x = do _ <- Text.Parser.Char.text x; whitespace +{-| A variation on `Text.Parser.Char.text` that doesn't quote the expected + in error messages +-} +text :: Data.Text.Text -> Parser Text +text t = Text.Parser.Char.text t Data.Text.unpack t +{-# INLINE text #-} -reservedCharOnly :: Char -> Parser () -reservedCharOnly c = do _ <- Text.Parser.Char.char c; return () +{-| A variation on `Text.Parser.Char.char` that doesn't quote the expected + token in error messages +-} +char :: Char -> Parser Char +char c = Text.Parser.Char.char c [ c ] +{-# INLINE char #-} +reserved :: Data.Text.Text -> Parser () +reserved x = void (text x) + reservedChar :: Char -> Parser () -reservedChar c = do _ <- Text.Parser.Char.char c; whitespace +reservedChar c = void (char c) -keywordOnly :: Data.Text.Text -> Parser () -keywordOnly x = try (do _ <- Text.Parser.Char.text x; return ()) +builtin :: Data.Text.Text -> Parser () +builtin x = reserved x "built-in" +{-# INLINE builtin #-} +operator :: Data.Text.Text -> Parser () +operator x = reserved x "operator" +{-# INLINE operator #-} + +operatorChar :: Char -> Parser () +operatorChar x = reservedChar x "operator" +{-# INLINE operatorChar #-} + keyword :: Data.Text.Text -> Parser () -keyword x = try (do _ <- Text.Parser.Char.text x; nonemptyWhitespace) +keyword x = try (void (text x)) "keyword" {-| Parse the @if@ keyword @@ -685,10 +703,6 @@ _else :: Parser () _else = keyword "else" --- | Parse the @let@ keyword without trailing whitespace -_letOnly :: Parser () -_letOnly = keywordOnly "let" - {-| Parse the @let@ keyword This corresponds to the @let@ rule from the official grammar @@ -750,256 +764,266 @@ This corresponds to the @None@ rule from the official grammar -} _None :: Parser () -_None = reserved "None" +_None = builtin "None" {-| Parse the @Natural/fold@ built-in This corresponds to the @Natural-fold@ rule from the official grammar -} _NaturalFold :: Parser () -_NaturalFold = reserved "Natural/fold" +_NaturalFold = builtin "Natural/fold" {-| Parse the @Natural/build@ built-in This corresponds to the @Natural-build@ rule from the official grammar -} _NaturalBuild :: Parser () -_NaturalBuild = reserved "Natural/build" +_NaturalBuild = builtin "Natural/build" {-| Parse the @Natural/isZero@ built-in This corresponds to the @Natural-isZero@ rule from the official grammar -} _NaturalIsZero :: Parser () -_NaturalIsZero = reserved "Natural/isZero" +_NaturalIsZero = builtin "Natural/isZero" {-| Parse the @Natural/even@ built-in This corresponds to the @Natural-even@ rule from the official grammar -} _NaturalEven :: Parser () -_NaturalEven = reserved "Natural/even" +_NaturalEven = builtin "Natural/even" {-| Parse the @Natural/odd@ built-in This corresponds to the @Natural-odd@ rule from the official grammar -} _NaturalOdd :: Parser () -_NaturalOdd = reserved "Natural/odd" +_NaturalOdd = builtin "Natural/odd" {-| Parse the @Natural/toInteger@ built-in This corresponds to the @Natural-toInteger@ rule from the official grammar -} _NaturalToInteger :: Parser () -_NaturalToInteger = reserved "Natural/toInteger" +_NaturalToInteger = builtin "Natural/toInteger" {-| Parse the @Natural/show@ built-in This corresponds to the @Natural-show@ rule from the official grammar -} _NaturalShow :: Parser () -_NaturalShow = reserved "Natural/show" +_NaturalShow = builtin "Natural/show" {-| Parse the @Natural/subtract@ built-in This corresponds to the @Natural-subtract@ rule from the official grammar -} _NaturalSubtract :: Parser () -_NaturalSubtract = reserved "Natural/subtract" +_NaturalSubtract = builtin "Natural/subtract" +{-| Parse the @Integer/clamp@ built-in + + This corresponds to the @Integer-clamp@ rule from the official grammar +-} +_IntegerClamp :: Parser () +_IntegerClamp = builtin "Integer/clamp" + +{-| Parse the @Integer/negate@ built-in + + This corresponds to the @Integer-negate@ rule from the official grammar +-} +_IntegerNegate :: Parser () +_IntegerNegate = builtin "Integer/negate" + {-| Parse the @Integer/show@ built-in This corresponds to the @Integer-show@ rule from the official grammar -} _IntegerShow :: Parser () -_IntegerShow = reserved "Integer/show" +_IntegerShow = builtin "Integer/show" {-| Parse the @Integer/toDouble@ built-in This corresponds to the @Integer-toDouble@ rule from the official grammar -} _IntegerToDouble :: Parser () -_IntegerToDouble = reserved "Integer/toDouble" +_IntegerToDouble = builtin "Integer/toDouble" {-| Parse the @Double/show@ built-in This corresponds to the @Double-show@ rule from the official grammar -} _DoubleShow :: Parser () -_DoubleShow = reserved "Double/show" +_DoubleShow = builtin "Double/show" {-| Parse the @List/build@ built-in This corresponds to the @List-build@ rule from the official grammar -} _ListBuild :: Parser () -_ListBuild = reserved "List/build" +_ListBuild = builtin "List/build" {-| Parse the @List/fold@ built-in This corresponds to the @List-fold@ rule from the official grammar -} _ListFold :: Parser () -_ListFold = reserved "List/fold" +_ListFold = builtin "List/fold" {-| Parse the @List/length@ built-in This corresponds to the @List-length@ rule from the official grammar -} _ListLength :: Parser () -_ListLength = reserved "List/length" +_ListLength = builtin "List/length" {-| Parse the @List/head@ built-in This corresponds to the @List-head@ rule from the official grammar -} _ListHead :: Parser () -_ListHead = reserved "List/head" +_ListHead = builtin "List/head" {-| Parse the @List/last@ built-in This corresponds to the @List-last@ rule from the official grammar -} _ListLast :: Parser () -_ListLast = reserved "List/last" +_ListLast = builtin "List/last" {-| Parse the @List/indexed@ built-in This corresponds to the @List-indexed@ rule from the official grammar -} _ListIndexed :: Parser () -_ListIndexed = reserved "List/indexed" +_ListIndexed = builtin "List/indexed" {-| Parse the @List/reverse@ built-in This corresponds to the @List-reverse@ rule from the official grammar -} _ListReverse :: Parser () -_ListReverse = reserved "List/reverse" +_ListReverse = builtin "List/reverse" {-| Parse the @Optional/fold@ built-in This corresponds to the @Optional-fold@ rule from the official grammar -} _OptionalFold :: Parser () -_OptionalFold = reserved "Optional/fold" +_OptionalFold = builtin "Optional/fold" {-| Parse the @Optional/build@ built-in This corresponds to the @Optional-build@ rule from the official grammar -} _OptionalBuild :: Parser () -_OptionalBuild = reserved "Optional/build" +_OptionalBuild = builtin "Optional/build" {-| Parse the @Bool@ built-in This corresponds to the @Bool@ rule from the official grammar -} _Bool :: Parser () -_Bool = reserved "Bool" +_Bool = builtin "Bool" {-| Parse the @Optional@ built-in This corresponds to the @Optional@ rule from the official grammar -} _Optional :: Parser () -_Optional = reserved "Optional" +_Optional = builtin "Optional" {-| Parse the @Natural@ built-in This corresponds to the @Natural@ rule from the official grammar -} _Natural :: Parser () -_Natural = reserved "Natural" +_Natural = builtin "Natural" {-| Parse the @Integer@ built-in This corresponds to the @Integer@ rule from the official grammar -} _Integer :: Parser () -_Integer = reserved "Integer" +_Integer = builtin "Integer" {-| Parse the @Double@ built-in This corresponds to the @Double@ rule from the official grammar -} _Double :: Parser () -_Double = reserved "Double" +_Double = builtin "Double" {-| Parse the @Text@ built-in This corresponds to the @Text@ rule from the official grammar -} _Text :: Parser () -_Text = reserved "Text" +_Text = builtin "Text" {-| Parse the @Text/show@ built-in This corresponds to the @Text-show@ rule from the official grammar -} _TextShow :: Parser () -_TextShow = reserved "Text/show" +_TextShow = builtin "Text/show" {-| Parse the @List@ built-in This corresponds to the @List@ rule from the official grammar -} _List :: Parser () -_List = reserved "List" +_List = builtin "List" {-| Parse the @True@ built-in This corresponds to the @True@ rule from the official grammar -} _True :: Parser () -_True = reserved "True" +_True = builtin "True" {-| Parse the @False@ built-in This corresponds to the @False@ rule from the official grammar -} _False :: Parser () -_False = reserved "False" +_False = builtin "False" {-| Parse a @NaN@ literal This corresponds to the @NaN@ rule from the official grammar -} _NaN :: Parser () -_NaN = reserved "NaN" +_NaN = builtin "NaN" {-| Parse the @Type@ built-in This corresponds to the @Type@ rule from the official grammar -} _Type :: Parser () -_Type = reserved "Type" +_Type = builtin "Type" {-| Parse the @Kind@ built-in This corresponds to the @Kind@ rule from the official grammar -} _Kind :: Parser () -_Kind = reserved "Kind" +_Kind = builtin "Kind" {-| Parse the @Sort@ built-in This corresponds to the @Sort@ rule from the official grammar -} _Sort :: Parser () -_Sort = reserved "Sort" +_Sort = builtin "Sort" {-| Parse the @Location@ keyword This corresponds to the @Location@ rule from the official grammar -} _Location :: Parser () -_Location = reserved "Location" - --- | Parse the @=@ symbol without trailing whitespace -_equalOnly :: Parser () -_equalOnly = reservedCharOnly '=' +_Location = builtin "Location" -- | Parse the @=@ symbol _equal :: Parser () @@ -1007,39 +1031,39 @@ -- | Parse the @||@ symbol _or :: Parser () -_or = reserved "||" +_or = operator "||" -- | Parse the @+@ symbol _plus :: Parser () -_plus = reservedChar '+' +_plus = operatorChar '+' -- | Parse the @++@ symbol _textAppend :: Parser () -_textAppend = reserved "++" +_textAppend = operator "++" -- | Parse the @#@ symbol _listAppend :: Parser () -_listAppend = reservedChar '#' +_listAppend = operatorChar '#' -- | Parse the @&&@ symbol _and :: Parser () -_and = reserved "&&" +_and = operator "&&" -- | Parse the @*@ symbol _times :: Parser () -_times = reservedChar '*' +_times = operatorChar '*' -- | Parse the @==@ symbol _doubleEqual :: Parser () -_doubleEqual = reserved "==" +_doubleEqual = operator "==" -- | Parse the @!=@ symbol _notEqual :: Parser () -_notEqual = reserved "!=" +_notEqual = operator "!=" -- | Parse the @.@ symbol _dot :: Parser () -_dot = reservedChar '.' +_dot = operatorChar '.' -- | Parse the @{@ symbol _openBrace :: Parser () @@ -1071,7 +1095,7 @@ -- | Parse the @,@ symbol _comma :: Parser () -_comma = reservedChar ',' +_comma = reservedChar ',' "\',\'" -- | Parse the @(@ symbol _openParens :: Parser () @@ -1081,23 +1105,17 @@ _closeParens :: Parser () _closeParens = reservedChar ')' --- | Parse the @:@ symbol without trailing whitespace -_colonOnly :: Parser () -_colonOnly = reservedCharOnly ':' - -- | Parse the @:@ symbol _colon :: Parser () _colon = reservedChar ':' -- | Parse the @\@@ symbol _at :: Parser () -_at = reservedChar '@' +_at = reservedChar '@' "\"@\"" -- | Parse the equivalence symbol (@===@ or @≡@) _equivalent :: Parser () -_equivalent = do - void (Text.Parser.Char.char '≡' "\"≡\"") <|> void (Text.Parser.Char.text "===") - whitespace +_equivalent = (void (char '≡' "\"≡\"") <|> void (text "===")) "operator" -- | Parse the @missing@ keyword _missing :: Parser () @@ -1105,31 +1123,23 @@ -- | Parse the @?@ symbol _importAlt :: Parser () -_importAlt = reservedChar '?' +_importAlt = operatorChar '?' -- | Parse the record combine operator (@/\\@ or @∧@) _combine :: Parser () -_combine = do - void (Text.Parser.Char.char '∧' "\"∧\"") <|> void (Text.Parser.Char.text "/\\") - whitespace +_combine = (void (char '∧' "\"∧\"") <|> void (text "/\\")) "operator" -- | Parse the record type combine operator (@//\\\\@ or @⩓@) _combineTypes :: Parser () -_combineTypes = do - void (Text.Parser.Char.char '⩓' "\"⩓\"") <|> void (Text.Parser.Char.text "//\\\\") - whitespace +_combineTypes = (void (char '⩓' "\"⩓\"") <|> void (text "//\\\\")) "operator" -- | Parse the record \"prefer\" operator (@//@ or @⫽@) _prefer :: Parser () -_prefer = do - void (Text.Parser.Char.char '⫽' "\"⫽\"") <|> void (Text.Parser.Char.text "//") - whitespace +_prefer = (void (char '⫽' "\"⫽\"") <|> void (text "//")) "operator" -- | Parse a lambda (@\\@ or @λ@) _lambda :: Parser () -_lambda = do - _ <- Text.Parser.Char.satisfy predicate - whitespace +_lambda = void (Text.Parser.Char.satisfy predicate) "\\" where predicate 'λ' = True predicate '\\' = True @@ -1137,16 +1147,12 @@ -- | Parse a forall (@forall@ or @∀@) _forall :: Parser () -_forall = do - void (Text.Parser.Char.char '∀' "\"∀\"") <|> void (Text.Parser.Char.text "forall") - whitespace +_forall = (void (char '∀' "\"∀\"") <|> void (text "forall")) "forall" -- | Parse a right arrow (@->@ or @→@) _arrow :: Parser () -_arrow = do - void (Text.Parser.Char.char '→' "\"→\"") <|> void (Text.Parser.Char.text "->") - whitespace +_arrow = (void (char '→' "\"→\"") <|> void (text "->")) "->" -- | Parse a double colon (@::@) _doubleColon :: Parser () -_doubleColon = reserved "::" +_doubleColon = operator "::" diff --git a/src/Dhall/Pretty.hs b/src/Dhall/Pretty.hs --- a/src/Dhall/Pretty.hs +++ b/src/Dhall/Pretty.hs @@ -10,14 +10,8 @@ , CharacterSet(..) , prettyCharacterSet - , layoutOpts + , Dhall.Pretty.Internal.layout + , Dhall.Pretty.Internal.layoutOpts ) where import Dhall.Pretty.Internal -import qualified Data.Text.Prettyprint.Doc as Pretty - --- | Default layout options -layoutOpts :: Pretty.LayoutOptions -layoutOpts = - Pretty.defaultLayoutOptions - { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } 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,6 +21,7 @@ , prettyVar , pretty_ , escapeText_ + , prettyEnvironmentVariable , prettyConst , prettyLabel @@ -32,6 +33,8 @@ , prettyDouble , prettyToStrictText , prettyToString + , layout + , layoutOpts , docToStrictText @@ -96,6 +99,7 @@ | Literal -- ^ Literals such as integers and strings | Builtin -- ^ Builtin types and values | Operator -- ^ Operators + deriving Show {-| Convert annotations to their corresponding color for syntax highlighting purposes @@ -109,7 +113,7 @@ annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green -- | This type determines whether to render code as `ASCII` or `Unicode` -data CharacterSet = ASCII | Unicode +data CharacterSet = ASCII | Unicode deriving Show -- | Pretty print an expression prettyExpr :: Pretty a => Expr s a -> Doc Ann @@ -407,11 +411,14 @@ digit :: Char -> Bool digit c = '\x30' <= c && c <= '\x39' +alphaNum :: Char -> Bool +alphaNum c = alpha c || digit c + headCharacter :: Char -> Bool headCharacter c = alpha c || c == '_' tailCharacter :: Char -> Bool -tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/' +tailCharacter c = alphaNum c || c == '_' || c == '-' || c == '/' prettyLabelShared :: Bool -> Text -> Doc Ann prettyLabelShared allowReserved a = label doc @@ -457,6 +464,17 @@ prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) 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 <> "\"") + where + validBashEnvVar v = case Text.uncons v of + Nothing -> False + Just (c, v') -> + (alpha c || c == '_') + && Text.all (\c' -> alphaNum c' || c' == '_') v' + {- There is a close correspondence between the pretty-printers in 'prettyCharacterSet' and the sub-parsers in 'Dhall.Parser.Expression.parsers'. Most pretty-printers are named after the corresponding parser and the relationship between pretty-printers @@ -954,6 +972,10 @@ builtin "Natural/subtract" prettyPrimitiveExpression Integer = builtin "Integer" + prettyPrimitiveExpression IntegerClamp = + builtin "Integer/clamp" + prettyPrimitiveExpression IntegerNegate = + builtin "Integer/negate" prettyPrimitiveExpression IntegerShow = builtin "Integer/show" prettyPrimitiveExpression IntegerToDouble = @@ -1066,37 +1088,48 @@ angles . map prettyAlternative . Dhall.Map.toList prettyChunks :: Pretty a => Chunks Src a -> Doc Ann - prettyChunks (Chunks a b) = - if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b - then Pretty.flatAlt long short - else short + prettyChunks chunks@(Chunks a b) + | anyText (== '\n') = + if not (null a) || anyText (/= '\n') + then long + else Pretty.group (Pretty.flatAlt long short) + | otherwise = + short where long = Pretty.align - ( literal ("''" <> Pretty.hardline) + ( literal "''" <> Pretty.hardline <> Pretty.align - (foldMap prettyMultilineChunk a <> prettyMultilineBuilder b) + (foldMap prettyMultilineChunk a' <> prettyMultilineText b') <> literal "''" ) + where + Chunks a' b' = multilineChunks chunks short = literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") - hasNewLine = Text.any (== '\n') + anyText predicate = any (\(text, _) -> Text.any predicate text) a || Text.any predicate b prettyMultilineChunk (c, d) = - prettyMultilineBuilder c + prettyMultilineText c <> dollar <> lbrace <> prettyExpression d <> rbrace - prettyMultilineBuilder builder = literal (mconcat docs) + prettyMultilineText text = mconcat docs where - lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder) + lines_ = Text.splitOn "\n" (escapeSingleQuotedText text) + -- Annotate only non-empty lines so trailing whitespace can be + -- removed on empty ones. + prettyLine line = + (if Text.null line then id else literal) + (Pretty.pretty line) + docs = - Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines) + Data.List.intersperse Pretty.hardline (map prettyLine lines_) prettyChunk (c, d) = prettyText c @@ -1106,20 +1139,125 @@ prettyText t = literal (Pretty.pretty (escapeText_ t)) + +-- | Prepare 'Chunks' for multi-line formatting by escaping problematic +-- character sequences via string interpolations +-- +-- >>> multilineChunks (Chunks [] "\n \tx") +-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x" +-- >>> multilineChunks (Chunks [] "\n\NUL\b\f\t") +-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t" +multilineChunks :: Chunks s a -> Chunks s a +multilineChunks = + escapeTrailingSingleQuote + . escapeControlCharacters + . escapeLastLineLeadingWhitespace + +-- | Escape leading whitespace on the last line by moving it into a string +-- interpolation +-- +-- This ensures that the parser can find the correct indentation level, no matter +-- what the other lines contain.- +-- +-- >>> escapeLastLineLeadingWhitespace (Chunks [] "\n \tx") +-- Chunks [("\n",TextLit (Chunks [] " \t"))] "x" +-- >>> escapeLastLineLeadingWhitespace (Chunks [("\n",Var (V "x" 0))] " ") +-- Chunks [("\n",Var (V "x" 0))] " " +-- >>> escapeLastLineLeadingWhitespace (Chunks [("\n ",Var (V "x" 0))] "") +-- Chunks [("\n",TextLit (Chunks [] " ")),("",Var (V "x" 0))] "" +-- >>> escapeLastLineLeadingWhitespace (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 + 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 + + predicate c = c == ' ' || c == '\t' + + escapeChunks = snd . foldr f (NotDone, []) + + 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) + +data Done = NotDone | Done + +-- | Escape control characters by moving them into string interpolations +-- +-- >>> escapeControlCharacters (Chunks [] "\n\NUL\b\f\t") +-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t" +escapeControlCharacters :: Chunks s a -> Chunks s a +escapeControlCharacters (Chunks as0 b0) = Chunks as1 b1 + where + as1 = foldr f (map toChunk bs) as0 + + (bs, b1) = splitOnPredicate predicate b0 + + f (t0, e) chunks = map toChunk ts1 ++ (t1, e) : chunks + where + (ts1, t1) = splitOnPredicate predicate t0 + + predicate c = Data.Char.isControl c && c /= ' ' && c /= '\t' && c /= '\n' + + toChunk (t0, t1) = (t0, TextLit (Chunks [] t1)) + +-- | Split `Text` on a predicate, preserving all parts of the original string. +-- +-- >>> splitOnPredicate (== 'x') "" +-- ([],"") +-- >>> splitOnPredicate (== 'x') " xx " +-- ([(" ","xx")]," ") +-- >>> splitOnPredicate (== 'x') "xx" +-- ([("","xx")],"") +-- +-- prop> \(Fun _ p) s -> let {t = Text.pack s; (as, b) = splitOnPredicate p t} in foldMap (uncurry (<>)) as <> b == t +splitOnPredicate :: (Char -> Bool) -> Text -> ([(Text, Text)], Text) +splitOnPredicate p t = case Text.break p t of + (a, "") -> ([], a) + (a, b) -> case Text.span p b of + (c, d) -> case splitOnPredicate p d of + (e, f) -> ((a, c) : e, f) + +-- | Escape a trailing single quote by moving it into a string interpolation +-- +-- Otherwise the multiline-string would end with @'''@, which would be parsed +-- as an escaped @''@. +-- +-- >>> escapeTrailingSingleQuote (Chunks [] "\n'") +-- Chunks [("\n",TextLit (Chunks [] "'"))] "" +escapeTrailingSingleQuote :: Chunks s a -> Chunks s a +escapeTrailingSingleQuote chunks@(Chunks as b) = + case Text.unsnoc b of + Just (b', '\'') -> Chunks (as ++ [(b', TextLit (Chunks [] "'"))]) "" + _ -> chunks + -- | Pretty-print a value pretty_ :: Pretty a => a -> Text -pretty_ = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty - where - options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } +pretty_ = prettyToStrictText -- | Escape a `Text` literal using Dhall's escaping rules for single-quoted -- @Text@ escapeSingleQuotedText :: Text -> Text -escapeSingleQuotedText inputBuilder = outputBuilder +escapeSingleQuotedText inputText = outputText where - outputText = substitute "${" "''${" (substitute "''" "'''" inputBuilder) - - outputBuilder = outputText + outputText = substitute "${" "''${" (substitute "''" "'''" inputText) substitute before after = Text.intercalate after . Text.splitOn before @@ -1160,14 +1298,30 @@ prettyToString :: Pretty a => a -> String prettyToString = - Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty - where - options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } + Pretty.renderString . layout . Pretty.pretty docToStrictText :: Doc ann -> Text.Text -docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options - where - options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } +docToStrictText = Pretty.renderStrict . layout prettyToStrictText :: Pretty a => a -> Text.Text prettyToStrictText = docToStrictText . Pretty.pretty + +-- | Layout using 'layoutOpts' +-- +-- Tries hard to fit the document into 80 columns. +-- +-- This also removes trailing space characters (@' '@) /unless/ +-- they are enclosed in an annotation. +layout :: Pretty.Doc ann -> Pretty.SimpleDocStream ann +layout = Pretty.removeTrailingWhitespace . Pretty.layoutSmart layoutOpts + +-- | Default layout options +layoutOpts :: Pretty.LayoutOptions +layoutOpts = + Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } + + +{- $setup +>>> import Test.QuickCheck (Fun(..)) +-} diff --git a/src/Dhall/Pretty/Internal.hs-boot b/src/Dhall/Pretty/Internal.hs-boot --- a/src/Dhall/Pretty/Internal.hs-boot +++ b/src/Dhall/Pretty/Internal.hs-boot @@ -1,5 +1,6 @@ module Dhall.Pretty.Internal where +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty, Doc) import {-# SOURCE #-} Dhall.Syntax @@ -11,3 +12,5 @@ prettyConst :: Const -> Doc Ann prettyExpr :: Pretty a => Expr s a -> Doc Ann + +prettyEnvironmentVariable :: Text -> Doc ann diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -25,6 +25,7 @@ import Data.Void (Void) import Dhall.Context (Context) import Dhall.Import (hashExpressionToCode) +import Dhall.Parser (Parser(..)) import Dhall.Src (Src) import Dhall.Pretty (CharacterSet(..)) import System.Console.Haskeline (Interrupt(..)) @@ -43,18 +44,21 @@ import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Core as Dhall ( Var(V), Expr, normalize ) +import qualified Dhall.Parser.Token as Parser.Token import qualified Dhall.Pretty +import qualified Dhall.Pretty.Internal import qualified Dhall.Core as Expr ( Expr(..) ) -import qualified Dhall.Import as Dhall -import qualified Dhall.Map as Map -import qualified Dhall.Parser as Dhall -import qualified Dhall.TypeCheck as Dhall -import qualified Dhall.Version as Meta +import qualified Dhall.Import as Dhall +import qualified Dhall.Map as Map +import qualified Dhall.Parser as Dhall +import qualified Dhall.TypeCheck as Dhall +import qualified Dhall.Version as Meta import qualified System.Console.ANSI -import qualified System.Console.Haskeline.Completion as Haskeline +import qualified System.Console.Haskeline.Completion as Haskeline import qualified System.Console.Haskeline.MonadException as Haskeline -import qualified System.Console.Repline as Repline +import qualified System.Console.Repline as Repline import qualified System.IO +import qualified Text.Megaparsec as Megaparsec type Repl = Repline.HaskelineT (State.StateT Env IO) @@ -212,23 +216,19 @@ addBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => [String] -> m () addBinding (k : "=" : srcs) = do - let - varName = - Text.pack k + varName <- case Megaparsec.parse (unParser Parser.Token.label) "(stdin)" (Text.pack k) of + Left _ -> Fail.fail "Invalid variable name" + Right varName -> return varName - loaded <- - parseAndLoad ( unwords srcs ) + loaded <- parseAndLoad ( unwords srcs ) - t <- - typeCheck loaded + t <- typeCheck loaded - expr <- - normalize loaded + expr <- normalize loaded modify ( \e -> - e - { envBindings = + e { envBindings = Dhall.Context.insert varName Binding { bindingType = t, bindingExpr = expr } @@ -351,7 +351,11 @@ handler handle = State.evalStateT (forM_ bindings $ \(name, expr) -> do - liftIO (System.IO.hPutStr handle $ ":let " <> Text.unpack name <> " = ") + let doc = Dhall.Pretty.Internal.prettyLabel name + + let label = Dhall.Pretty.Internal.docToStrictText doc + + liftIO (System.IO.hPutStr handle $ ":let " <> Text.unpack label <> " = ") outputWithoutSpacing expr) (env { outputHandle = Just handle }) @@ -608,9 +612,7 @@ case outputHandle of Nothing -> pure () Just handle -> do - let stream = - Pretty.layoutSmart Dhall.Pretty.layoutOpts - (Dhall.Pretty.prettyCharacterSet characterSet expr) + let stream = Dhall.Pretty.layout (Dhall.Pretty.prettyCharacterSet characterSet expr) supportsANSI <- liftIO (System.Console.ANSI.hSupportsANSI handle) let ansiStream = diff --git a/src/Dhall/Set.hs b/src/Dhall/Set.hs --- a/src/Dhall/Set.hs +++ b/src/Dhall/Set.hs @@ -10,6 +10,7 @@ module Dhall.Set ( Set(..) , toList + , toAscList , toSet , toSeq , fromList @@ -20,6 +21,7 @@ , sort , isSorted , null + , size ) where import Prelude hiding (null) @@ -57,6 +59,15 @@ foldMap f (Set _ x) = foldMap f x {-# INLINABLE foldMap #-} + toList = Dhall.Set.toList + {-# INLINABLE toList #-} + + null = Dhall.Set.null + {-# INLINABLE null #-} + + length = Dhall.Set.size + {-# INLINABLE length #-} + -- | Convert to an unordered @"Data.Set".`Data.Set.Set`@ toSet :: Set a -> Data.Set.Set a toSet (Set s _) = s @@ -67,8 +78,12 @@ -- | Convert a `Set` to a list, preserving the original order of the elements toList :: Set a -> [a] -toList = Data.Foldable.toList +toList (Set _ xs) = Data.Foldable.toList xs +-- | Convert a `Set` to a list of ascending elements +toAscList :: Set a -> [a] +toAscList (Set s _) = Data.Set.toAscList s + -- | Convert a list to a `Set`, remembering the element order fromList :: Ord a => [a] -> Set a fromList = foldl' (flip append) empty @@ -103,7 +118,7 @@ True -} sort :: Ord a => Set a -> Set a -sort (Set s xs) = Set s (Data.Sequence.sort xs) +sort (Set s _) = Set s (Data.Sequence.fromList (Data.Set.toList s)) {-| >>> isSorted (fromList [2, 1]) @@ -122,3 +137,10 @@ -} null :: Set a -> Bool null (Set s _) = Data.Set.null s + +{-| +>>> size (fromList [1]) +1 +-} +size :: Set a -> Int +size (Set s _) = Data.Set.size s diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -211,7 +211,7 @@ -- -- This instance is also consistent with with the binary encoding of Dhall @Double@s: -- --- >>> toBytes n = Codec.Serialise.serialise (Dhall.Binary.encode (n :: DhallDouble)) +-- >>> toBytes n = Dhall.Binary.encodeExpression (DoubleLit n :: Expr Void Import) -- -- prop> \a b -> (a == b) == (toBytes a == toBytes b) instance Eq DhallDouble where @@ -338,6 +338,10 @@ | Integer -- | > IntegerLit n ~ ±n | IntegerLit Integer + -- | IntegerClamp ~ Integer/clamp + | IntegerClamp + -- | IntegerNegate ~ Integer/negate + | IntegerNegate -- | > IntegerShow ~ Integer/show | IntegerShow -- | > IntegerToDouble ~ Integer/toDouble @@ -486,6 +490,8 @@ fmap f (NaturalTimes e1 e2) = NaturalTimes (fmap f e1) (fmap f e2) fmap _ Integer = Integer fmap _ (IntegerLit i) = IntegerLit i + fmap _ IntegerClamp = IntegerClamp + fmap _ IntegerNegate = IntegerNegate fmap _ IntegerShow = IntegerShow fmap _ IntegerToDouble = IntegerToDouble fmap _ Double = Double @@ -569,6 +575,8 @@ NaturalTimes a b >>= k = NaturalTimes (a >>= k) (b >>= k) Integer >>= _ = Integer IntegerLit a >>= _ = IntegerLit a + IntegerClamp >>= _ = IntegerClamp + IntegerNegate >>= _ = IntegerNegate IntegerShow >>= _ = IntegerShow IntegerToDouble >>= _ = IntegerToDouble Double >>= _ = Double @@ -639,6 +647,8 @@ first k (NaturalTimes a b ) = NaturalTimes (first k a) (first k b) first _ Integer = Integer first _ (IntegerLit a ) = IntegerLit a + first _ IntegerClamp = IntegerClamp + first _ IntegerNegate = IntegerNegate first _ IntegerShow = IntegerShow first _ IntegerToDouble = IntegerToDouble first _ Double = Double @@ -769,6 +779,8 @@ subExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b subExpressions _ Integer = pure Integer subExpressions _ (IntegerLit n) = pure (IntegerLit n) +subExpressions _ IntegerClamp = pure IntegerClamp +subExpressions _ IntegerNegate = pure IntegerNegate subExpressions _ IntegerShow = pure IntegerShow subExpressions _ IntegerToDouble = pure IntegerToDouble subExpressions _ Double = pure Double @@ -977,7 +989,7 @@ pretty (Remote url) = Pretty.pretty url - pretty (Env env) = "env:" <> Pretty.pretty env + pretty (Env env) = "env:" <> prettyEnvironmentVariable env pretty Missing = "missing" @@ -1074,6 +1086,8 @@ denote (NaturalTimes a b ) = NaturalTimes (denote a) (denote b) denote Integer = Integer denote (IntegerLit a ) = IntegerLit a +denote IntegerClamp = IntegerClamp +denote IntegerNegate = IntegerNegate denote IntegerShow = IntegerShow denote IntegerToDouble = IntegerToDouble denote Double = Double @@ -1132,23 +1146,24 @@ reservedIdentifiers :: HashSet Text reservedIdentifiers = Data.HashSet.fromList - [ "let" - , "in" - , "Type" - , "Kind" - , "Sort" - , "forall" - , "Bool" - , "True" - , "False" - , "merge" - , "toMap" - , "if" + [ -- Keywords according to the `keyword` rule in the grammar + "if" , "then" , "else" - , "as" + , "let" + , "in" , "using" - , "Natural" + , "missing" + , "as" + , "Infinity" + , "NaN" + , "merge" + , "Some" + , "toMap" + , "assert" + , "forall" + + -- Builtins according to the `builtin` rule in the grammar , "Natural/fold" , "Natural/build" , "Natural/isZero" @@ -1158,13 +1173,13 @@ , "Natural/show" , "Natural/subtract" , "Integer" + , "Integer/clamp" + , "Integer/negate" , "Integer/show" , "Integer/toDouble" - , "Double" + , "Integer/show" + , "Natural/subtract" , "Double/show" - , "Text" - , "Text/show" - , "List" , "List/build" , "List/fold" , "List/length" @@ -1172,11 +1187,20 @@ , "List/last" , "List/indexed" , "List/reverse" + , "Optional/fold" + , "Optional/build" + , "Text/show" + , "Bool" + , "True" + , "False" , "Optional" - , "Some" , "None" - , "Optional/build" - , "Optional/fold" - , "NaN" - , "Infinity" + , "Natural" + , "Integer" + , "Double" + , "Text" + , "List" + , "Type" + , "Kind" + , "Sort" ] diff --git a/src/Dhall/Tags.hs b/src/Dhall/Tags.hs --- a/src/Dhall/Tags.hs +++ b/src/Dhall/Tags.hs @@ -9,14 +9,14 @@ ) where import Control.Exception (handle, SomeException(..)) -import Data.List (isSuffixOf) +import Data.List (isSuffixOf, foldl') import Data.Maybe (fromMaybe) import Data.Semigroup (Semigroup(..)) import Dhall.Map (foldMapWithKey) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Dhall.Util (Input(..)) -import Dhall.Core (Expr(..), Binding(..)) +import Dhall.Syntax (Expr(..), Binding(..)) import Dhall.Src (Src(srcStart)) import Dhall.Parser (exprFromText) import System.FilePath ((), takeFileName) @@ -144,7 +144,7 @@ -- In example above, first line is 15 bytes long and '\n', mls contain: -- (1, (16, "let foo = "bar"") -- That allow us to get byte offset easier. - mls = M.fromList . fst . foldl processLine ([], 0) . zip [1..] $ T.lines t + mls = M.fromList . fst . foldl' processLine ([], 0) . zip [1..] $ T.lines t {-| processLine is a worker for `foldl` that generates the list of lines with byte offsets from the start of the first line from a list of lines diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -1498,7 +1498,7 @@ -- We'll use this trick to test changes to the protected import in the following -- examples. -- --- Now, supose you add a comment to the @./bar@ file: +-- Now, suppose you add a comment to the @./bar@ file: -- -- > $ cat ./bar -- > -- This comment does not change the hash diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -37,12 +37,11 @@ import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) import Data.Typeable (Typeable) import Data.Void (Void, absurd) -import Dhall.Binary (ToTerm(..)) import Dhall.Context (Context) -import Dhall.Core (Binding(..), Const(..), Chunks(..), Expr(..), Var(..)) +import Dhall.Syntax (Binding(..), Const(..), Chunks(..), Expr(..), Var(..)) import Dhall.Eval (Environment(..), Names(..), Val(..), (~>)) -import Dhall.Pretty (Ann, layoutOpts) +import Dhall.Pretty (Ann) import Dhall.Src (Src) import Lens.Family (over) @@ -60,6 +59,7 @@ import qualified Dhall.Eval as Eval import qualified Dhall.Map import qualified Dhall.Set +import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal import qualified Dhall.Util import qualified Lens.Family @@ -510,6 +510,12 @@ IntegerLit _ -> do return VInteger + IntegerClamp -> do + return (VInteger ~> VNatural) + + IntegerNegate -> do + return (VInteger ~> VInteger) + IntegerShow -> do return (VInteger ~> VText) @@ -588,7 +594,7 @@ -- Carefully note that we don't use `die` -- here so that the source span is narrowed -- to just the offending element - let err = MismatchedListElements i _T₀'' t₁ _T₁'' + let err = MismatchedListElements (i+1) _T₀'' t₁ _T₁'' let context = ctxToContext ctx @@ -678,7 +684,7 @@ VList a ~> VList (VRecord - (Dhall.Map.fromList + (Dhall.Map.unorderedFromList [ ("index", VNatural) , ("value", a ) ] @@ -897,8 +903,18 @@ return (VRecord (Dhall.Map.union xRs' xLs')) RecordCompletion l r -> do - loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type")) + _L' <- loop ctx l + case _L' of + VRecord xLs' + | not (Dhall.Map.member "default" xLs') + -> die (InvalidRecordCompletion "default" l) + | not (Dhall.Map.member "Type" xLs') + -> die (InvalidRecordCompletion "Type" l) + | otherwise + -> loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type")) + _ -> die (CompletionSchemaMustBeARecord l (quote names _L')) + Merge t u mT₁ -> do _T' <- loop ctx t @@ -934,7 +950,8 @@ if Data.Set.null diffU then return () - else die (MissingHandler diffU) + else let (exemplar,rest) = Data.Set.deleteFindMin diffU + in die (MissingHandler exemplar rest) let match _y _T₀' Nothing = return _T₀' @@ -1067,7 +1084,7 @@ let mapType _T' = VList (VRecord - (Dhall.Map.fromList + (Dhall.Map.unorderedFromList [("mapKey", VText), ("mapValue", _T')] ) ) @@ -1133,9 +1150,9 @@ Just _T' -> return (x, _T') Nothing -> die (MissingField x _E'') - let adapt = VRecord . Dhall.Map.fromList + let adapt = VRecord . Dhall.Map.unorderedFromList - fmap adapt (traverse process (Dhall.Set.toList (Dhall.Set.sort xs))) + fmap adapt (traverse process (Dhall.Set.toAscList xs)) _ -> do let text = @@ -1284,6 +1301,8 @@ | AlternativeAnnotationMismatch Text (Expr s a) Const Text (Expr s a) Const | ListAppendMismatch (Expr s a) (Expr s a) | MustCombineARecord Char (Expr s a) (Expr s a) + | InvalidRecordCompletion Text (Expr s a) + | CompletionSchemaMustBeARecord (Expr s a) (Expr s a) | CombineTypesRequiresRecordType (Expr s a) (Expr s a) | RecordTypeMismatch Const Const (Expr s a) (Expr s a) | FieldCollision Text @@ -1296,7 +1315,7 @@ | MapTypeMismatch (Expr s a) (Expr s a) | MissingToMapType | UnusedHandler (Set Text) - | MissingHandler (Set Text) + | MissingHandler Text (Set Text) | HandlerInputTypeMismatch Text (Expr s a) (Expr s a) | DisallowedHandlerType Text (Expr s a) (Expr s a) Text | HandlerOutputTypeMismatch Text (Expr s a) Text (Expr s a) @@ -1324,13 +1343,13 @@ | CantMultiply (Expr s a) (Expr s a) deriving (Show) -shortTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann +shortTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann shortTypeMessage msg = "\ESC[1;31mError\ESC[0m: " <> short <> "\n" where ErrorMessages {..} = prettyTypeMessage msg -longTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann +longTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann longTypeMessage msg = "\ESC[1;31mError\ESC[0m: " <> short <> "\n" <> "\n" @@ -1351,8 +1370,7 @@ insert :: Pretty a => a -> Doc Ann insert = Dhall.Util.insert -prettyTypeMessage - :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> 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: -- https://github.com/dhall-lang/dhall-haskell/pull/116 @@ -2023,7 +2041,9 @@ prettyTypeMessage (InvalidPredicate expr0 expr1) = ErrorMessages {..} where - short = "Invalid predicate for ❰if❱" + short = "Invalid predicate for ❰if❱: " + <> "\n" + <> Dhall.Diff.doc (Dhall.Diff.diffNormalized Bool expr1) long = "Explanation: Every ❰if❱ expression begins with a predicate which must have type \n\ @@ -2672,6 +2692,55 @@ txt0 = insert expr0 txt1 = insert expr1 +prettyTypeMessage (CompletionSchemaMustBeARecord expr0 expr1) = ErrorMessages {..} + where + short = "The completion schema must be a record" + + long = + "Explanation: You can complete records using the ❰::❱ operator: \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────────┐ \n\ + \ │ {Type = {foo : Bool, bar : Natural}, default = {bar = 2}::{foo = True}} │ \n\ + \ └─────────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \... The left-hand side of :: must be a record with 'Type' and 'default' keys \n\ + \ \n\ + \You tried to record complete the following value: \n\ + \ \n\ + \" <> txt0 <> "\n\ + \ \n\ + \... which is not a record. It is: \n\ + \ \n\ + \" <> txt1 <> "\n" + where + txt0 = insert expr0 + txt1 = insert expr1 + +prettyTypeMessage (InvalidRecordCompletion fieldName expr0) = ErrorMessages {..} + where + short = "Completion schema is missing a field: " <> pretty fieldName + + long = + "Explanation: You can complete records using the ❰::❱ operator like this:\n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────────────┐ \n\ + \ │ {Type = {foo : Bool, bar : Natural}, default = {bar = 2}::{foo = True}} │ \n\ + \ └─────────────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \... but you need to have both Type and default fields in the completion schema \n\ + \ (the record on the left of the the ::). \n\ + \ \n\ + \You tried to do record completion using the schema: \n\ + \ \n\ + \" <> txt0 <> "\n\ + \ \n\ + \... which is missing the key: \n\ + \ \n\ + \" <> txt1 <> "\n" + where + txt0 = insert expr0 + txt1 = pretty fieldName + prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..} where short = "You can only combine records" @@ -2820,7 +2889,7 @@ prettyTypeMessage (FieldCollision k) = ErrorMessages {..} where - short = "Field collision" + short = "Field collision on: " <> Dhall.Pretty.Internal.prettyLabel k long = "Explanation: You can combine records or record types if they don't share any \n\ @@ -3030,9 +3099,12 @@ where txt0 = insert (Text.intercalate ", " (Data.Set.toList ks)) -prettyTypeMessage (MissingHandler ks) = ErrorMessages {..} +prettyTypeMessage (MissingHandler exemplar ks) = ErrorMessages {..} where - short = "Missing handler" + short = case Data.Set.toList ks of + [] -> "Missing handler: " <> Dhall.Pretty.Internal.prettyLabel exemplar + xs@(_:_) -> "Missing handlers: " <> (Pretty.hsep . Pretty.punctuate Pretty.comma + . map Dhall.Pretty.Internal.prettyLabel $ exemplar:xs) long = "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ @@ -3068,7 +3140,7 @@ \ \n\ \" <> txt0 <> "\n" where - txt0 = insert (Text.intercalate ", " (Data.Set.toList ks)) + txt0 = insert (Text.intercalate ", " (exemplar : Data.Set.toList ks)) prettyTypeMessage MissingMergeType = ErrorMessages {..} @@ -3331,7 +3403,7 @@ prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..} where - short = "Handler is not a function" + 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\ @@ -3682,7 +3754,7 @@ prettyTypeMessage (MissingField k expr0) = ErrorMessages {..} where - short = "Missing record field" + short = "Missing record field: " <> Dhall.Pretty.Internal.prettyLabel k long = "Explanation: You can only access fields on records, like this: \n\ @@ -3724,7 +3796,7 @@ prettyTypeMessage (MissingConstructor k expr0) = ErrorMessages {..} where - short = "Missing constructor" + short = "Missing constructor: " <> Dhall.Pretty.Internal.prettyLabel k long = "Explanation: You can access constructors from unions, like this: \n\ @@ -4246,35 +4318,24 @@ , typeMessage :: TypeMessage s a } -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (TypeError s a) where - show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty - -instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (TypeError s a) +instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where + show = Pretty.renderString . Dhall.Pretty.layout . prettyTypeError -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (TypeError s a) where - pretty (TypeError ctx expr msg) - = Pretty.unAnnotate - ( "\n" - <> ( if null (Dhall.Context.toList ctx) - then "" - else prettyContext ctx <> "\n\n" - ) - <> shortTypeMessage msg <> "\n" - <> source - ) - where - prettyKV (key, val) = - pretty key <> " : " <> Dhall.Util.snipDoc (pretty val) +instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (TypeError s a) - prettyContext = - Pretty.vsep - . map prettyKV - . reverse - . Dhall.Context.toList +instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where + pretty = Pretty.unAnnotate . prettyTypeError - source = case expr of - Note s _ -> pretty s - _ -> mempty +prettyTypeError :: (Eq a, Pretty s, Pretty a) => TypeError s a -> Doc Ann +prettyTypeError (TypeError _ expr msg) = + ( "\n" + <> shortTypeMessage msg <> "\n" + <> source + ) + where + source = case expr of + Note s _ -> pretty s + _ -> mempty {-| Wrap a type error in this exception type to censor source code and `Text` literals from the error message @@ -4284,7 +4345,7 @@ | Censored (TypeError Src X) instance Show Censored where - show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty + show = Pretty.renderString . Dhall.Pretty.layout . Pretty.pretty instance Exception Censored @@ -4349,6 +4410,10 @@ ListAppendMismatch <$> f a <*> f b MustCombineARecord a b c -> MustCombineARecord <$> pure a <*> f b <*> f c + InvalidRecordCompletion a l -> + InvalidRecordCompletion a <$> f l + CompletionSchemaMustBeARecord l r -> + CompletionSchemaMustBeARecord <$> f l <*> f r CombineTypesRequiresRecordType a b -> CombineTypesRequiresRecordType <$> f a <*> f b RecordTypeMismatch a b c d -> @@ -4373,8 +4438,8 @@ pure MissingToMapType UnusedHandler a -> UnusedHandler <$> pure a - MissingHandler a -> - MissingHandler <$> pure a + MissingHandler e a -> + MissingHandler <$> pure e <*> pure a HandlerInputTypeMismatch a b c -> HandlerInputTypeMismatch <$> pure a <*> f b <*> f c DisallowedHandlerType a b c d -> @@ -4432,37 +4497,40 @@ newtype DetailedTypeError s a = DetailedTypeError (TypeError s a) deriving (Typeable) -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (DetailedTypeError s a) where - show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty +instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where + show = Pretty.renderString . Dhall.Pretty.layout . prettyDetailedTypeError -instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (DetailedTypeError s a) +instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (DetailedTypeError s a) -instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (DetailedTypeError s a) where - pretty (DetailedTypeError (TypeError ctx expr msg)) - = Pretty.unAnnotate - ( "\n" - <> ( if null (Dhall.Context.toList ctx) - then "" - else prettyContext ctx <> "\n\n" - ) - <> longTypeMessage msg <> "\n" - <> "────────────────────────────────────────────────────────────────────────────────\n" - <> "\n" - <> source - ) - where - prettyKV (key, val) = - pretty key <> " : " <> Dhall.Util.snipDoc (pretty val) +instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where + pretty = Pretty.unAnnotate . prettyDetailedTypeError - prettyContext = - Pretty.vsep - . map prettyKV - . reverse - . Dhall.Context.toList +prettyDetailedTypeError :: (Eq a, Pretty s, Pretty a) => DetailedTypeError s a -> Doc Ann +prettyDetailedTypeError (DetailedTypeError (TypeError ctx expr msg)) = + ( "\n" + <> ( if null (Dhall.Context.toList ctx) + then "" + else prettyContext ctx <> "\n\n" + ) + <> longTypeMessage msg <> "\n" + <> "────────────────────────────────────────────────────────────────────────────────\n" + <> "\n" + <> source + ) + where + prettyKV (key, val) = + Dhall.Util.snipDoc + (Dhall.Pretty.Internal.prettyLabel key <> " : " <> Dhall.Pretty.prettyExpr val) - source = case expr of - Note s _ -> pretty s - _ -> mempty + prettyContext = + Pretty.vsep + . map prettyKV + . reverse + . Dhall.Context.toList + + source = case expr of + Note s _ -> pretty s + _ -> mempty {-| This function verifies that a custom context is well-formed so that type-checking will not loop diff --git a/src/Dhall/URL.hs b/src/Dhall/URL.hs --- a/src/Dhall/URL.hs +++ b/src/Dhall/URL.hs @@ -6,7 +6,7 @@ import Data.Monoid ((<>)) import Data.Text (Text) -import Dhall.Core +import Dhall.Syntax ( Scheme(..) , URL(..) , File(..) diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -12,23 +12,27 @@ , Output(..) , getExpression , getExpressionAndHeader + , getExpressionAndHeaderFromStdinText + , Header(..) ) where +import Control.Exception (Exception(..)) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (first) import Data.Monoid ((<>)) import Data.String (IsString) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Dhall.Core (Expr, Import) -import Dhall.Parser (ParseError) +import Dhall.Parser (ParseError, Header(..)) import Dhall.Pretty (Ann) +import Dhall.Syntax (Expr, Import) import Dhall.Src (Src) +import qualified Control.Exception import qualified Data.Text import qualified Data.Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty -import qualified Dhall.Core +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal import qualified Dhall.Parser import qualified Dhall.Pretty @@ -73,11 +77,11 @@ snipDoc :: Doc Ann -> Doc a snipDoc doc = Pretty.align (Pretty.pretty (snip text)) where - stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts doc + stream = Dhall.Pretty.layout doc ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream - text = Pretty.renderStrict ansiStream + text = Pretty.Terminal.renderStrict ansiStream takeEnd :: Int -> [a] -> [a] takeEnd n l = go (drop n l) l @@ -94,17 +98,19 @@ _ERROR :: IsString string => string _ERROR = "\ESC[1;31mError\ESC[0m" -get :: (String -> Text -> Either ParseError a) -> Censor -> Input -> IO a +get :: (String -> Text -> Either ParseError a) -> Censor -> InputOrTextFromStdin -> IO a get parser censor input = do inText <- do case input of - InputFile file -> Data.Text.IO.readFile file - StandardInput -> Data.Text.IO.getContents + Input_ (InputFile file) -> Data.Text.IO.readFile file + Input_ StandardInput -> Data.Text.IO.getContents + StdinText text -> pure text let name = case input of - InputFile file -> file - StandardInput -> "(stdin)" + Input_ (InputFile file) -> file + Input_ StandardInput -> "(stdin)" + StdinText _ -> "(stdin)" let result = parser name inText @@ -113,21 +119,36 @@ NoCensor -> result Censor -> first Dhall.Parser.censor result - Dhall.Core.throws censoredResult + throws censoredResult +{-| Convenience utility for converting `Either`-based exceptions to `IO`-based + exceptions +-} +throws :: (Exception e, MonadIO io) => Either e a -> io a +throws (Left e) = liftIO (Control.Exception.throwIO e) +throws (Right r) = return r + -- | Set to `Censor` if you want to censor error text that might include secrets data Censor = NoCensor | Censor -- | Path to input data Input = StandardInput | InputFile FilePath +-- | Path to input or raw input text, necessary since we can't read STDIN twice +data InputOrTextFromStdin = Input_ Input | StdinText Text + -- | Path to output data Output = StandardOutput | OutputFile FilePath -- | Convenient utility for retrieving an expression getExpression :: Censor -> Input -> IO (Expr Src Import) -getExpression = get Dhall.Parser.exprFromText +getExpression censor = get Dhall.Parser.exprFromText censor . Input_ -- | Convenient utility for retrieving an expression along with its header -getExpressionAndHeader :: Censor -> Input -> IO (Text, Expr Src Import) -getExpressionAndHeader = get Dhall.Parser.exprAndHeaderFromText +getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import) +getExpressionAndHeader censor = get Dhall.Parser.exprAndHeaderFromText censor . Input_ + +-- | Convenient utility for retrieving an expression along with its header from +-- | text already read from STDIN (so it's not re-read) +getExpressionAndHeaderFromStdinText :: Censor -> Text -> IO (Header, Expr Src Import) +getExpressionAndHeaderFromStdinText censor = get Dhall.Parser.exprAndHeaderFromText censor . StdinText 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 @@ -57,8 +57,8 @@ data MyType = MyType { foo :: String , bar :: Natural } -wrongDhallType :: Dhall.Type MyType -wrongDhallType = Dhall.Type { .. } +wrongDhallType :: Dhall.Decoder MyType +wrongDhallType = Dhall.Decoder { .. } where expected = Dhall.Core.Record ( Dhall.Map.fromList @@ -74,12 +74,12 @@ try ( Dhall.input wrongDhallType "{ bar = 0, foo = \"foo\" }") let expectedMsg = - "\ESC[1;31mError\ESC[0m: Invalid Dhall.Type \n\ + "\ESC[1;31mError\ESC[0m: Invalid Dhall.Decoder \n\ \ \n\ - \Every Type must provide an extract function that succeeds if an expression \n\ - \matches the expected type. You provided a Type that disobeys this contract \n\ + \Every Decoder must provide an extract function that succeeds if an expression \n\ + \matches the expected type. You provided a Decoder that disobeys this contract \n\ \ \n\ - \The Type provided has the expected dhall type: \n\ + \The Decoder provided has the expected dhall type: \n\ \ \n\ \↳ { bar : Natural, foo : Text }\n\ \ \n\ @@ -97,7 +97,7 @@ -- https://github.com/dhall-lang/dhall-haskell/issues/915 shouldHandleUnionLiteral :: TestTree shouldHandleUnionLiteral = testCase "Marshal union literals" $ do - let example :: Dhall.Type Bool + let example :: Dhall.Decoder Bool example = Dhall.union (Dhall.constructor "Test" Dhall.bool) _ <- Dhall.input example "< Test : Bool >.Test True" @@ -106,15 +106,15 @@ shouldTreatAConstructorStoringUnitAsEmptyAlternative :: TestTree shouldTreatAConstructorStoringUnitAsEmptyAlternative = testCase "Handle unit constructors" $ do - let exampleType :: Dhall.Type () + let exampleType :: Dhall.Decoder () exampleType = Dhall.union (Dhall.constructor "A" Dhall.unit) () <- Dhall.input exampleType "< A >.A" - let exampleInputType :: Dhall.InputType () - exampleInputType = Dhall.inputUnion (Dhall.inputConstructor "A") + let exampleEncoder :: Dhall.Encoder () + exampleEncoder = Dhall.unionEncoder (Dhall.encodeConstructor "A") - Dhall.embed exampleInputType () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A" + Dhall.embed exampleEncoder () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A" shouldHaveWorkingRecursiveFromDhall :: TestTree shouldHaveWorkingRecursiveFromDhall = testGroup "recursive FromDhall instance" diff --git a/tests/Dhall/Test/Diff.hs b/tests/Dhall/Test/Diff.hs --- a/tests/Dhall/Test/Diff.hs +++ b/tests/Dhall/Test/Diff.hs @@ -10,11 +10,11 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Core as Core import qualified Dhall.Diff as Diff import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty import qualified Dhall.Test.Util as Test.Util import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit @@ -50,13 +50,8 @@ let actualDiffDocument = Diff.doc (Diff.diffNormalized leftInput rightInput) <> "\n" - let options = - Pretty.LayoutOptions - { Pretty.layoutPageWidth = Pretty.Unbounded } - - let actualDiffText = - Pretty.Text.renderStrict - (Pretty.layoutPretty options actualDiffDocument) + let actualDiffText = Pretty.Text.renderStrict + (Dhall.Pretty.layout actualDiffDocument) let message = "The diffed expressions did not match the expected output" diff --git a/tests/Dhall/Test/Format.hs b/tests/Dhall/Test/Format.hs --- a/tests/Dhall/Test/Format.hs +++ b/tests/Dhall/Test/Format.hs @@ -4,6 +4,7 @@ import Data.Monoid (mempty, (<>)) import Data.Text (Text) +import Dhall.Parser (Header(..)) import Dhall.Pretty (CharacterSet(..)) import Test.Tasty (TestTree) @@ -43,6 +44,16 @@ return testTree +format :: CharacterSet -> (Header, Core.Expr Parser.Src Core.Import) -> Text +format characterSet (Header header, expr) = + let doc = Doc.pretty header + <> Pretty.prettyCharacterSet characterSet expr + <> "\n" + + docStream = Pretty.layout doc + in + Doc.Render.Text.renderStrict docStream + formatTest :: CharacterSet -> Text -> TestTree formatTest characterSet prefix = Tasty.HUnit.testCase (Text.unpack prefix) $ do @@ -51,14 +62,9 @@ inputText <- Text.IO.readFile inputFile - (header, expr) <- Core.throws (Parser.exprAndHeaderFromText mempty inputText) - - let doc = Doc.pretty header - <> Pretty.prettyCharacterSet characterSet expr - <> "\n" - let docStream = Doc.layoutSmart Pretty.layoutOpts doc - let actualText = Doc.Render.Text.renderStrict docStream + headerAndExpr <- Core.throws (Parser.exprAndHeaderFromText mempty inputText) + let actualText = format characterSet headerAndExpr expectedText <- Text.IO.readFile outputFile let message = 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 @@ -10,9 +10,6 @@ import Test.Tasty (TestTree) import Turtle (FilePath, ()) -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Term as CBOR -import qualified Codec.Serialise as Serialise import qualified Control.Monad as Monad import qualified Data.Bifunctor as Bifunctor import qualified Data.ByteString as ByteString @@ -26,6 +23,7 @@ import qualified Dhall.Test.Util as Test.Util import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Text.Printf as Printf import qualified Turtle parseDirectory :: FilePath @@ -91,7 +89,8 @@ (Just " ") Nothing (Just " ") - (Note "0 " (NaturalLit 0))) + (Note "0 " (Note "0" (NaturalLit 0))) + ) -- This 'Let' isn't wrapped in a 'Note'! (Let (Binding @@ -100,7 +99,7 @@ (Just " ") Nothing (Just " ") - (Note "1 " (NaturalLit 1)) + (Note "1 " (Note "1" (NaturalLit 1))) ) (Note "let z = 2 in x" (Let @@ -110,10 +109,14 @@ (Just " ") Nothing (Just " ") - (Note "2 " (NaturalLit 2)) + (Note "2 " (Note "2" (NaturalLit 2))) ) - (Note "x" - (Var (V "x" 0)))))))) + (Note "x" (Var (V "x" 0))) + ) + ) + ) + ) + ) let msg = "Unexpected parse result" @@ -124,8 +127,13 @@ let expectedFailures = -- This is a bug created by a parsing performance -- improvement - [ parseDirectory "success/unit/MergeParenAnnotation" ] + [ parseDirectory "success/unit/MergeParenAnnotation" + -- https://github.com/dhall-lang/dhall-haskell/issues/1454 + , parseDirectory "success/missingFoo" + , parseDirectory "success/missingSlash" + ] + let pathString = Text.unpack path Test.Util.testCase path expectedFailures $ do @@ -133,18 +141,20 @@ encoded <- ByteString.Lazy.readFile (pathString <> "B.dhallb") - expression <- Core.throws (Parser.exprFromText mempty text) + expression <- case Parser.exprFromText mempty text of + Left exception -> Tasty.HUnit.assertFailure (show exception) + Right expression -> return expression - let term = Binary.encodeExpression expression + let bytes = Binary.encodeExpression (Core.denote expression) - let bytes = Serialise.serialise term + let render = + concatMap (Printf.printf "%02x ") + . ByteString.Lazy.unpack Monad.unless (encoded == bytes) $ do - ("", expected) <- Core.throws (CBOR.deserialiseFromBytes CBOR.decodeTerm encoded) - let message = "The expected CBOR representation doesn't match the actual one\n" - ++ "expected: " ++ show expected ++ "\n but got: " ++ show term - ++ "\n expr: " ++ show expression + ++ "expected: " ++ render encoded ++ "\n but got: " ++ render bytes + ++ "\n expr: " ++ show (Core.denote expression :: Expr Void Import) Tasty.HUnit.assertFailure message @@ -152,35 +162,11 @@ shouldNotParse :: Text -> TestTree shouldNotParse path = do let expectedFailures = - [ -- These two unexpected successes are due to not correctly - -- requiring non-empty whitespace after the `:` in a type - -- annotation - parseDirectory "failure/unit/ImportEnvWrongEscape.dhall" - - -- Other spacing related unexpected successes: - , parseDirectory "failure/spacing/AnnotationNoSpace.dhall" - , parseDirectory "failure/spacing/ApplicationNoSpace1.dhall" - , parseDirectory "failure/spacing/ApplicationNoSpace2.dhall" - , parseDirectory "failure/spacing/AssertNoSpace.dhall" - , parseDirectory "failure/spacing/ForallNoSpace.dhall" - , parseDirectory "failure/spacing/ImportAltNoSpace.dhall" - , parseDirectory "failure/spacing/ImportHashedNoSpace.dhall" - , parseDirectory "failure/spacing/LambdaNoSpace.dhall" - , parseDirectory "failure/spacing/ListLitEmptyNoSpace.dhall" - , parseDirectory "failure/spacing/MergeAnnotationNoSpace3.dhall" - , parseDirectory "failure/spacing/MergeNoSpace2.dhall" - , parseDirectory "failure/spacing/NaturalPlusNoSpace.dhall" - , parseDirectory "failure/spacing/RecordTypeNoSpace.dhall" - , parseDirectory "failure/spacing/ToMapAnnotNoSpace.dhall" - , parseDirectory "failure/spacing/UnionTypeNoSpace.dhall" - - , parseDirectory "failure/ImportHeadersExteriorHash.dhall" - - -- For parsing performance reasons the implementation + [ -- For parsing performance reasons the implementation -- treats a missing type annotation on an empty list as -- as a type-checking failure instead of a parse failure, -- but this might be fixable. - , parseDirectory "failure/unit/ListLitEmptyMissingAnnotation.dhall" + parseDirectory "failure/unit/ListLitEmptyMissingAnnotation.dhall" , parseDirectory "failure/unit/ListLitEmptyAnnotation.dhall" -- The same performance improvements also broke the @@ -202,16 +188,29 @@ shouldDecode :: Text -> TestTree shouldDecode pathText = do - let expectedFailures = [] + let expectedFailures = + [ {- Note that this test actually successfully decodes the value, but + mistakenly decodes the value to `_` instead of `x`. This is + because the 55799 tag causes normal decoding to fail, so it falls + back to treating the `"x"` as a version tag instead of a label. + Either way, fixing 55799 decoding would cause this test to pass + again. + -} + binaryDecodeDirectory "success/unit/SelfDescribeCBORX2" + , binaryDecodeDirectory "success/unit/SelfDescribeCBORX3" + ] + let pathString = Text.unpack pathText Test.Util.testCase pathText expectedFailures (do bytes <- ByteString.Lazy.readFile (pathString <> "A.dhallb") - term <- Core.throws (Serialise.deserialiseOrFail bytes) - - decodedExpression <- Core.throws (Binary.decodeExpression term) + decodedExpression <- case Binary.decodeExpression bytes of + Left exception -> + Tasty.HUnit.assertFailure (show exception) + Right decodedExpression -> + return decodedExpression text <- Text.IO.readFile (pathString <> "B.dhall") @@ -223,7 +222,7 @@ let message = "The decoded expression didn't match the parsed expression" - Tasty.HUnit.assertEqual message decodedExpression strippedExpression ) + Tasty.HUnit.assertEqual message strippedExpression decodedExpression ) shouldNotDecode :: Text -> TestTree shouldNotDecode pathText = do @@ -234,8 +233,6 @@ Test.Util.testCase pathText expectedFailures (do bytes <- ByteString.Lazy.readFile (pathString <> ".dhallb") - term <- Core.throws (Serialise.deserialiseOrFail bytes) - - case Binary.decodeExpression term :: Either Binary.DecodingFailure (Expr Void Import) of + case Binary.decodeExpression bytes :: Either Binary.DecodingFailure (Expr Void Import) of Left _ -> return () Right _ -> Tasty.HUnit.assertFailure "Unexpected successful decode" ) diff --git a/tests/Dhall/Test/QuickCheck.hs b/tests/Dhall/Test/QuickCheck.hs --- a/tests/Dhall/Test/QuickCheck.hs +++ b/tests/Dhall/Test/QuickCheck.hs @@ -1,18 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Dhall.Test.QuickCheck where -import Codec.Serialise (DeserialiseFailure(..)) import Data.Either (isRight) import Data.Either.Validation (Validation(..)) +import Data.Monoid ((<>)) +import Data.Void (Void) import Dhall (ToDhall(..), FromDhall(..), auto, extract, inject, embed, Vector) import Dhall.Map (Map) import Dhall.Core @@ -37,19 +38,21 @@ import Data.Typeable (Typeable, typeRep) import Data.Proxy (Proxy(..)) import Dhall.Set (Set) +import Dhall.Parser (Header(..), createHeader) +import Dhall.Pretty (CharacterSet(..)) import Dhall.Src (Src(..)) +import Dhall.Test.Format (format) import Dhall.TypeCheck (Typer, TypeError) import Generic.Random (Weights, W, (%), (:+)(..)) import Test.QuickCheck - (Arbitrary(..), Gen, Positive(..), Property, NonNegative(..), genericShrink, (===), (==>)) + ( Arbitrary(..), Gen, Positive(..), Property, NonNegative(..) + , genericShrink, suchThat, (===), (==>)) import Test.QuickCheck.Instances () import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (QuickCheckTests(..)) import Text.Megaparsec (SourcePos(..), Pos) import qualified Control.Spoon -import qualified Codec.Serialise -import qualified Data.Coerce import qualified Data.List import qualified Data.Sequence import qualified Data.SpecialValues @@ -63,6 +66,7 @@ import qualified Dhall.Core import qualified Dhall.Diff import qualified Dhall.Map +import qualified Dhall.Parser as Parser import qualified Dhall.Set import qualified Dhall.TypeCheck import qualified Generic.Random @@ -72,13 +76,6 @@ import qualified Test.Tasty.QuickCheck import qualified Text.Megaparsec as Megaparsec -newtype DeserialiseFailureWithEq = D DeserialiseFailure - deriving (Show) - -instance Eq DeserialiseFailureWithEq where - D (DeserialiseFailure aL bL) == D (DeserialiseFailure aR bR) = - aL == aR && bL == bR - instance (Arbitrary a, Ord a) => Arbitrary (Set a) where arbitrary = Dhall.Set.fromList <$> arbitrary shrink = map Dhall.Set.fromList . shrink . Dhall.Set.toList @@ -140,6 +137,42 @@ , (1, fmap (\x -> x - (2 ^ (64 :: Int))) arbitrary) ] +instance Arbitrary CharacterSet where + arbitrary = Test.QuickCheck.elements [ ASCII, Unicode ] + +instance Arbitrary Header where + arbitrary = do + let commentChar = + Test.QuickCheck.frequency + [ (20, Test.QuickCheck.elements [' ' .. '\DEL']) + , ( 1, arbitrary) + ] + + commentText = Text.pack <$> Test.QuickCheck.listOf commentChar + + multiline = do + txt <- commentText + pure $ "{-" <> txt <> "-}" + + singleline = do + txt <- commentText `suchThat` (not . Text.isInfixOf "\n") + endOfLine <- Test.QuickCheck.elements ["\n", "\r\n"] + pure $ "--" <> txt <> endOfLine + + newlines = Text.concat <$> Test.QuickCheck.listOf (pure "\n") + + comments <- do + n <- Test.QuickCheck.choose (0, 2) + Test.QuickCheck.vectorOf n $ Test.QuickCheck.oneof + [ multiline + , singleline + , newlines + ] + + pure . createHeader $ Text.unlines comments + + shrink (Header txt) = createHeader . Text.pack <$> shrink (Text.unpack txt) + instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where arbitrary = do n <- Test.QuickCheck.choose (0, 2) @@ -241,6 +274,8 @@ % (1 :: W "NaturalTimes") % (1 :: W "Integer") % (7 :: W "IntegerLit") + % (1 :: W "IntegerClamp") + % (1 :: W "IntegerNegate") % (1 :: W "IntegerShow") % (1 :: W "IntegerToDouble") % (1 :: W "Double") @@ -368,21 +403,11 @@ binaryRoundtrip :: Expr () Import -> Property binaryRoundtrip expression = - wrap - (fmap - Dhall.Binary.decodeExpression - (Codec.Serialise.deserialiseOrFail - (Codec.Serialise.serialise - (Dhall.Binary.encodeExpression expression) - ) - ) - ) - === wrap (Right (Right (Dhall.Core.denote expression :: Expr () Import))) + Dhall.Binary.decodeExpression (Dhall.Binary.encodeExpression denotedExpression) + === Right denotedExpression where - wrap - :: Either DeserialiseFailure a - -> Either DeserialiseFailureWithEq a - wrap = Data.Coerce.coerce + denotedExpression :: Expr Void Import + denotedExpression = Dhall.Core.denote expression everythingWellTypedNormalizes :: Expr () () -> Property everythingWellTypedNormalizes expression = @@ -450,17 +475,23 @@ embedThenExtractIsIdentity :: forall a. (ToDhall a, FromDhall a, Eq a, Typeable a, Arbitrary a, Show a) => Proxy a - -> (String, Property, QuickCheckTests) + -> (String, Property, TestTree -> TestTree) embedThenExtractIsIdentity p = ( "Embedding then extracting is identity for " ++ show (typeRep p) , Test.QuickCheck.property (prop :: a -> Bool) - , QuickCheckTests 1000 + , adjustQuickCheckTests 1000 ) where prop a = case extract auto (embed inject a) of Success a' -> a == a' Failure _ -> False +idempotenceTest :: CharacterSet -> Header -> Expr Src Import -> Property +idempotenceTest characterSet header expr = + let once = format characterSet (header, expr) + in case Parser.exprAndHeaderFromText mempty once of + Right (format characterSet -> twice) -> once === twice + Left _ -> Test.QuickCheck.discard tests :: TestTree tests = @@ -468,31 +499,31 @@ "QuickCheck" [ ( "Binary serialization should round-trip" , Test.QuickCheck.property binaryRoundtrip - , QuickCheckTests 100 + , adjustQuickCheckTests 100 ) , ( "everything well-typed should normalize" , Test.QuickCheck.property everythingWellTypedNormalizes - , QuickCheckTests 100000 + , adjustQuickCheckTests 100000 ) , ( "isNormalized should be consistent with normalize" , Test.QuickCheck.property isNormalizedIsConsistentWithNormalize - , QuickCheckTests 10000 + , adjustQuickCheckTests 10000 ) , ( "normalizeWithM should be consistent with normalize" , Test.QuickCheck.property normalizeWithMIsConsistentWithNormalize - , QuickCheckTests 10000 + , adjustQuickCheckTests 10000 ) , ( "An expression should have no difference with itself" , Test.QuickCheck.property isSameAsSelf - , QuickCheckTests 10000 + , adjustQuickCheckTests 10000 ) , ( "Inferred types should be normalized" , Test.QuickCheck.property inferredTypesAreNormalized - , QuickCheckTests 10000 + , adjustQuickCheckTests 10000 ) , ( "Normalizing an expression doesn't change its inferred type" , Test.QuickCheck.property normalizingAnExpressionDoesntChangeItsInferredType - , QuickCheckTests 10000 + , adjustQuickCheckTests 10000 ) , embedThenExtractIsIdentity (Proxy :: Proxy (Text.Text)) , embedThenExtractIsIdentity (Proxy :: Proxy [Nat.Natural]) @@ -504,13 +535,28 @@ , embedThenExtractIsIdentity (Proxy :: Proxy (Vector Double)) , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Map.Map Double Bool)) , embedThenExtractIsIdentity (Proxy :: Proxy (HashMap.HashMap Double Bool)) + , ( "Formatting should be idempotent" + , Test.QuickCheck.property idempotenceTest + + -- FIXME: While this test is flaky, we set the number of test cases + -- to 0 by subtracting the default number of tests (100). + -- To run the test manually, use e.g. + -- --quickcheck-tests 1000 + , Test.Tasty.adjustOption (subtract (QuickCheckTests 100)) + ) ] +adjustQuickCheckMaxRatio :: Int -> TestTree -> TestTree +adjustQuickCheckMaxRatio maxSize = + Test.Tasty.adjustOption (max $ Test.Tasty.QuickCheck.QuickCheckMaxRatio maxSize) +adjustQuickCheckTests :: Int -> TestTree -> TestTree +adjustQuickCheckTests nTests = + -- Using adjustOption instead of withMaxSuccess allows us to override the number of tests + -- with the --quickcheck-tests CLI option. + Test.Tasty.adjustOption (max $ QuickCheckTests nTests) -testProperties' :: String -> [(String, Property, QuickCheckTests)] -> TestTree +testProperties' :: String -> [(String, Property, TestTree -> TestTree)] -> TestTree testProperties' name = Test.Tasty.testGroup name . map f where - -- Using adjustOption instead of withMaxSuccess allows us to override the number of tests - -- with the --quickcheck-tests CLI option. - f (n, p, nTests) = Test.Tasty.adjustOption (max nTests) (Test.Tasty.QuickCheck.testProperty n p) + f (n, p, adjust) = adjust (Test.Tasty.QuickCheck.testProperty n p) 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 @@ -42,6 +42,7 @@ , issue1131a , issue1131b , issue1341 + , issue1584 , parsing0 , typeChecking0 , typeChecking1 @@ -55,7 +56,7 @@ unnamedFields :: TestTree unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do - let ty = Dhall.auto :: Dhall.Type Foo + let ty = Dhall.auto :: Dhall.Decoder Foo Test.Tasty.HUnit.assertEqual "Good type" (Dhall.expected ty) (Dhall.Core.Union (Dhall.Map.fromList @@ -69,14 +70,14 @@ ) ) - let inj = Dhall.inject :: Dhall.InputType Foo + let inj = Dhall.inject :: Dhall.Encoder Foo Test.Tasty.HUnit.assertEqual "Good ToDhall" (Dhall.declared inj) (Dhall.expected ty) - let tu_ty = Dhall.auto :: Dhall.Type (Integer, Bool) + let tu_ty = Dhall.auto :: Dhall.Decoder (Integer, Bool) Test.Tasty.HUnit.assertEqual "Auto Tuple" (Dhall.expected tu_ty) (Dhall.Core.Record ( Dhall.Map.fromList [ ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool) ])) - let tu_in = Dhall.inject :: Dhall.InputType (Integer, Bool) + let tu_in = Dhall.inject :: Dhall.Encoder (Integer, Bool) Test.Tasty.HUnit.assertEqual "Inj. Tuple" (Dhall.declared tu_in) (Dhall.expected tu_ty) return () ) @@ -90,7 +91,7 @@ issue126 :: TestTree issue126 = Test.Tasty.HUnit.testCase "Issue #126" (do e <- Util.code "''\nfoo\nbar\n''" - Util.normalize' e @?= "\"foo\\nbar\\n\"" ) + Util.normalize' e @?= "''\nfoo\nbar\n''" ) issue151 :: TestTree issue151 = Test.Tasty.HUnit.testCase "Issue #151" (do @@ -147,7 +148,7 @@ source <- Data.Text.IO.readFile "./tests/regression/issue216b.dhall" e <- Util.code source let doc = Data.Text.Prettyprint.Doc.pretty e - let docStream = Data.Text.Prettyprint.Doc.layoutSmart Dhall.Pretty.layoutOpts doc + let docStream = Dhall.Pretty.layout doc let text0 = Data.Text.Prettyprint.Doc.Render.Text.renderLazy docStream text1 <- Data.Text.Lazy.IO.readFile "./tests/regression/issue216b.dhall" @@ -179,6 +180,13 @@ let actual = Dhall.Core.V "x" 0 `Dhall.Core.freeIn` nan let msg = "NaN shouldn't contain any free variables" Test.Tasty.HUnit.assertEqual msg False actual) + +issue1584 :: TestTree +issue1584 = Test.Tasty.HUnit.testCase "Issue #1584" (do + -- This test ensures that we can parse variables with keyword prefixes + -- (e.g. `ifX`) + _ <- Util.code "./tests/regression/issue1584.dhall" + return () ) parsing0 :: TestTree parsing0 = Test.Tasty.HUnit.testCase "Parsing regression #0" (do diff --git a/tests/diff/function.txt b/tests/diff/function.txt --- a/tests/diff/function.txt +++ b/tests/diff/function.txt @@ -2,5 +2,5 @@ → … → …@- 1 + 0 - + → … diff --git a/tests/diff/insideList.txt b/tests/diff/insideList.txt new file mode 100644 --- /dev/null +++ b/tests/diff/insideList.txt @@ -0,0 +1,7 @@ +[ … +, { y = - 4 + + 5 + , … + } +] + diff --git a/tests/diff/insideListA.dhall b/tests/diff/insideListA.dhall new file mode 100644 --- /dev/null +++ b/tests/diff/insideListA.dhall @@ -0,0 +1,3 @@ +[ { x = 1, y = 2 } +, { x = 3, y = 4 } +] diff --git a/tests/diff/insideListB.dhall b/tests/diff/insideListB.dhall new file mode 100644 --- /dev/null +++ b/tests/diff/insideListB.dhall @@ -0,0 +1,3 @@ +[ { x = 1, y = 2 } +, { x = 3, y = 5 } +] diff --git a/tests/format/concatSepB.dhall b/tests/format/concatSepB.dhall --- a/tests/format/concatSepB.dhall +++ b/tests/format/concatSepB.dhall @@ -23,7 +23,7 @@ status ) Status.Empty - + in merge { Empty = "", NonEmpty = λ(result : Text) → result } status let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI" diff --git a/tests/format/envVarsA.dhall b/tests/format/envVarsA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/envVarsA.dhall @@ -0,0 +1,1 @@ +[ env:x, env:"1", env:" ", env:"\\", env:"." ] diff --git a/tests/format/envVarsB.dhall b/tests/format/envVarsB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/envVarsB.dhall @@ -0,0 +1,1 @@ +[ env:x, env:"1", env:" ", env:"\\", env:"." ] diff --git a/tests/format/escapeSingleQuotedOpenInterpolationB.dhall b/tests/format/escapeSingleQuotedOpenInterpolationB.dhall --- a/tests/format/escapeSingleQuotedOpenInterpolationB.dhall +++ b/tests/format/escapeSingleQuotedOpenInterpolationB.dhall @@ -1,1 +1,3 @@ -"\${\n" +'' +''${ +'' diff --git a/tests/format/headerB.dhall b/tests/format/headerB.dhall --- a/tests/format/headerB.dhall +++ b/tests/format/headerB.dhall @@ -1,3 +1,3 @@ {- bla -} - + True diff --git a/tests/format/importAltPrecedenceA.dhall b/tests/format/importAltPrecedenceA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importAltPrecedenceA.dhall @@ -0,0 +1,1 @@ +a ? b || c diff --git a/tests/format/importAltPrecedenceB.dhall b/tests/format/importAltPrecedenceB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importAltPrecedenceB.dhall @@ -0,0 +1,1 @@ +a ? b || c diff --git a/tests/format/innerMultilineB.dhall b/tests/format/innerMultilineB.dhall --- a/tests/format/innerMultilineB.dhall +++ b/tests/format/innerMultilineB.dhall @@ -1,1 +1,11 @@ -{ inner = "\none\n\ntwo\n\nthree\n\n" } +{ inner = + '' + + one + + two + + three + + '' +} diff --git a/tests/format/interpolation0A.dhall b/tests/format/interpolation0A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/interpolation0A.dhall @@ -0,0 +1,1 @@ +"foo\n${a} bar" diff --git a/tests/format/interpolation0B.dhall b/tests/format/interpolation0B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/interpolation0B.dhall @@ -0,0 +1,3 @@ +'' +foo +${a} bar'' diff --git a/tests/format/issue1400-1A.dhall b/tests/format/issue1400-1A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1400-1A.dhall @@ -0,0 +1,14 @@ +{ 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) + '' + ] + } + ] +} diff --git a/tests/format/issue1400-1B.dhall b/tests/format/issue1400-1B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1400-1B.dhall @@ -0,0 +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) + '' + ] + } + ] +} diff --git a/tests/format/issue1400-2A.dhall b/tests/format/issue1400-2A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1400-2A.dhall @@ -0,0 +1,14 @@ +let Tagged + : Type → Type + = λ ( a + : Type + ) + → { field : + Text + , nesting : + ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ? ./Nesting + , contents : a + } + +in Tagged diff --git a/tests/format/issue1400-2B.dhall b/tests/format/issue1400-2B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1400-2B.dhall @@ -0,0 +1,11 @@ +let Tagged + : Type → Type + = λ(a : Type) + → { field : Text + , nesting : + ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 + ? ./Nesting + , contents : a + } + +in Tagged diff --git a/tests/format/issue1413B.dhall b/tests/format/issue1413B.dhall --- a/tests/format/issue1413B.dhall +++ b/tests/format/issue1413B.dhall @@ -1,5 +1,5 @@ let foo = - + {- test -} "hello" diff --git a/tests/format/issue1545-1A.dhall b/tests/format/issue1545-1A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1545-1A.dhall @@ -0,0 +1,1 @@ +"\n\tx" diff --git a/tests/format/issue1545-1B.dhall b/tests/format/issue1545-1B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1545-1B.dhall @@ -0,0 +1,3 @@ +'' + +${"\t"}x'' diff --git a/tests/format/issue1545-2A.dhall b/tests/format/issue1545-2A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1545-2A.dhall @@ -0,0 +1,1 @@ +"\n x" diff --git a/tests/format/issue1545-2B.dhall b/tests/format/issue1545-2B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1545-2B.dhall @@ -0,0 +1,3 @@ +'' + +${" "}x'' diff --git a/tests/format/issue183A.dhall b/tests/format/issue183A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue183A.dhall @@ -0,0 +1,11 @@ + let foo = 1 + +in λ(bar : Integer) + → let exposePort = + λ(portSpec : { ext : Integer, int : Integer }) + → Integer/show portSpec.ext ++ ":" ++ Integer/show portSpec.int + + in let exposeSamePort = + λ(port : Integer) → exposePort { ext = port, int = port } + + in { blah = bar } diff --git a/tests/format/issue183B.dhall b/tests/format/issue183B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue183B.dhall @@ -0,0 +1,11 @@ +let foo = 1 + +in λ(bar : Integer) + → let exposePort = + λ(portSpec : { ext : Integer, int : Integer }) + → Integer/show portSpec.ext ++ ":" ++ Integer/show portSpec.int + + in let exposeSamePort = + λ(port : Integer) → exposePort { ext = port, int = port } + + in { blah = bar } diff --git a/tests/format/letNewlineCommentsB.dhall b/tests/format/letNewlineCommentsB.dhall --- a/tests/format/letNewlineCommentsB.dhall +++ b/tests/format/letNewlineCommentsB.dhall @@ -5,5 +5,5 @@ : {- bbbbbbbbbbbbbbbbbbbbb -} Natural = {- ddddddddddddddddd -} 2 - + in x diff --git a/tests/format/multilineArgumentA.dhall b/tests/format/multilineArgumentA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineArgumentA.dhall @@ -0,0 +1,1 @@ +fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff xxxxxxxxxxxxxxxx "\n" diff --git a/tests/format/multilineArgumentB.dhall b/tests/format/multilineArgumentB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineArgumentB.dhall @@ -0,0 +1,3 @@ +fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + xxxxxxxxxxxxxxxx + "\n" diff --git a/tests/format/multilineB.dhall b/tests/format/multilineB.dhall --- a/tests/format/multilineB.dhall +++ b/tests/format/multilineB.dhall @@ -1,1 +1,3 @@ -"ABC\nDEF" +'' +ABC +DEF'' diff --git a/tests/format/multilineTrailingSingleQuoteA.dhall b/tests/format/multilineTrailingSingleQuoteA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineTrailingSingleQuoteA.dhall @@ -0,0 +1,1 @@ +"\n'" diff --git a/tests/format/multilineTrailingSingleQuoteB.dhall b/tests/format/multilineTrailingSingleQuoteB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineTrailingSingleQuoteB.dhall @@ -0,0 +1,3 @@ +'' + +${"'"}'' diff --git a/tests/format/multilineTrailingWhitespaceA.dhall b/tests/format/multilineTrailingWhitespaceA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineTrailingWhitespaceA.dhall @@ -0,0 +1,1 @@ +{ x = " \n\nfoo \n" } diff --git a/tests/format/multilineTrailingWhitespaceB.dhall b/tests/format/multilineTrailingWhitespaceB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/multilineTrailingWhitespaceB.dhall @@ -0,0 +1,7 @@ +{ x = + '' + + + foo + '' +} diff --git a/tests/format/nestedAnnotationA.dhall b/tests/format/nestedAnnotationA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/nestedAnnotationA.dhall @@ -0,0 +1,1 @@ +([] : a) : b diff --git a/tests/format/nestedAnnotationB.dhall b/tests/format/nestedAnnotationB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/nestedAnnotationB.dhall @@ -0,0 +1,1 @@ +([] : a) : b diff --git a/tests/format/stringWithNullA.dhall b/tests/format/stringWithNullA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/stringWithNullA.dhall @@ -0,0 +1,1 @@ +"\u0000 \$ \\ \n ☺" diff --git a/tests/format/stringWithNullB.dhall b/tests/format/stringWithNullB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/stringWithNullB.dhall @@ -0,0 +1,3 @@ +'' +${"\u0000"} $ \ +${" "}☺'' diff --git a/tests/format/textLitNewlinesOnlyA.dhall b/tests/format/textLitNewlinesOnlyA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/textLitNewlinesOnlyA.dhall @@ -0,0 +1,1 @@ +"\n\n" diff --git a/tests/format/textLitNewlinesOnlyB.dhall b/tests/format/textLitNewlinesOnlyB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/textLitNewlinesOnlyB.dhall @@ -0,0 +1,1 @@ +"\n\n" diff --git a/tests/regression/issue1584.dhall b/tests/regression/issue1584.dhall new file mode 100644 --- /dev/null +++ b/tests/regression/issue1584.dhall @@ -0,0 +1,19 @@ +[ let ifX = 1 in ifX +, let thenX = 1 in thenX +, let elseX = 1 in elseX +, let letX = 1 in letX +, let inX = 1 in inX +, let usingX = 1 in usingX +{- Fixing this case appears to be difficult for the current parser + implementation +-} +-- , let missingX = 1 in missingX +, let asX = 1 in asX +, let InfinityX = 1 in InfinityX +, let NaNX = 1 in NaNX +, let mergeX = 1 in mergeX +, let SomeX = 1 in SomeX +, let toMapX = 1 in toMapX +, let assertX = 1 in assertX +, let forallX = 1 in forallX +]