diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,55 @@ +1.27.0 + +* [Supports version 11.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v11.0.0) +* BREAKING CHANGE: Rename `Inject`/`Interpret` to `ToDhall`/`FromDhall` + * This change `ConstraintKinds` to minimize disruption by keeping around + `Inject`/`Interpret` as synonyms for `ToDhall`/`FromDhall` + * In other words, constraints and derived instances using `Inject` or + `Interpret` will still work + * However, manual instances using `Inject` or `Interpret` won't work + unless you rename them to `ToDhall`/`FromDhall` or enable the + `TypeSynonymInstances` extension +* BREAKING CHANGE: Fix `Eq` instance for `Expr`s with special `Double`s + * This fixes the `Eq` instance for `Expr`s to match the standard regarding + `Double` comparisons + * Specifically: `NaN == NaN` and `-0.0 /= 0.0` + * This is a breaking change because the `DoubleLit` constructor of `Expr` + now stores a `DhallDouble` instead of a `Double` +* BREAKING CHANGE: [Add `--file` option for `dhall hash`](https://github.com/dhall-lang/dhall-haskell/pull/1445) + * This is a breaking change because it also removes the `Dhall.Hash` module, + which wasn't really carrying its own weight +* [Add support for leading separators](https://github.com/dhall-lang/dhall-haskell/pull/1355) + * See the [changelog for standard version 11.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v11.0.0) for more details +* [Add record completion operator](https://github.com/dhall-lang/dhall-haskell/pull/1375) + * See the [changelog for standard version 11.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v11.0.0) for more details +* [Add `dhall tags` subcommand](https://github.com/dhall-lang/dhall-haskell/pull/1398) + * This generates an ETags file from an input file or directory +* [Add `dhall lint` support for fixing malformed assertions](https://github.com/dhall-lang/dhall-haskell/pull/1353) + * `dhall lint` now fixes `let example = foo === bar` to be + `let example = assert : foo === bar` +* Normalize inferred types [#1337](https://github.com/dhall-lang/dhall-haskell/pull/1337) +* New `FromDhall`/`ToDhall` (previously `Interpret`/`Inject`) instances for: + * [`Void`](https://github.com/dhall-lang/dhall-haskell/pull/1382) + * `Map` [#1391](https://github.com/dhall-lang/dhall-haskell/pull/1391) / [#1412](https://github.com/dhall-lang/dhall-haskell/pull/1412) + * [`HashMap`](https://github.com/dhall-lang/dhall-haskell/pull/1426) + * [`Set` and `HashSet`](https://github.com/dhall-lang/dhall-haskell/pull/1405) + * [`()`](https://github.com/dhall-lang/dhall-haskell/pull/1388) +* [Add `--output` option to `dhall`](https://github.com/dhall-lang/dhall-haskell/pull/1399) +* [Move syntax things from `Dhall.Core` to a new `Dhall.Syntax` module](https://github.com/dhall-lang/dhall-haskell/pull/1440) + * This is not a breaking change. `Dhall.Core` still re-exports the same + API as before +* Performance improvements + * [#1362](https://github.com/dhall-lang/dhall-haskell/pull/1362) + * [#1366](https://github.com/dhall-lang/dhall-haskell/pull/1366) + * [#1368](https://github.com/dhall-lang/dhall-haskell/pull/1368) + * [#1397](https://github.com/dhall-lang/dhall-haskell/pull/1397) + * [#1401](https://github.com/dhall-lang/dhall-haskell/pull/1401) +* Fixes and improvements to code formatting + * [#1360](https://github.com/dhall-lang/dhall-haskell/pull/1360) + * [#1372](https://github.com/dhall-lang/dhall-haskell/pull/1372) + * [#1380](https://github.com/dhall-lang/dhall-haskell/pull/1380) + * [#1415](https://github.com/dhall-lang/dhall-haskell/pull/1415) + 1.26.1 * TECHNICALLY BREAKING CHANGES: [Simplify `⫽` within projection](https://github.com/dhall-lang/dhall-haskell/pull/1283) / [Simplify nested record projections](https://github.com/dhall-lang/dhall-haskell/pull/1307) @@ -40,6 +92,10 @@ * This fixes `dhall type` to more accurately follow the standard * [Initial changes for GHC 8.8 support](https://github.com/dhall-lang/dhall-haskell/pull/1324) * [Fix Haddock formatting for `dhallFromJSON`](https://github.com/dhall-lang/dhall-haskell/pull/1316) +* [Improved Windows caching support](https://github.com/dhall-lang/dhall-haskell/pull/1272) + * `dhall` will now prefer the `%LOCALAPPDATA%` directory for caching if it is + available +* [Warn about missing cache directories](https://github.com/dhall-lang/dhall-haskell/pull/1320) 1.26.0 @@ -104,7 +160,7 @@ newly-added utilities * See also: [#1298](https://github.com/dhall-lang/dhall-haskell/pull/1298) * [New `:help` command for `dhall repl`](https://github.com/dhall-lang/dhall-haskell/pull/1237) -* [New `--no-cache` flag](https://github.com/dhall-lang/dhall-haskell/pull/1290) +* New `--no-cache` flag [#1290](https://github.com/dhall-lang/dhall-haskell/pull/1290) / [#1434](https://github.com/dhall-lang/dhall-haskell/pull/1434) / [#1436](https://github.com/dhall-lang/dhall-haskell/pull/1436) * You can now disable use of the cache with this flag * This comes in handy if you want to disable α-normalization for imports protected by a semantic integrity check diff --git a/dhall-lang/Prelude/Bool/not b/dhall-lang/Prelude/Bool/not --- a/dhall-lang/Prelude/Bool/not +++ b/dhall-lang/Prelude/Bool/not @@ -1,7 +1,9 @@ {- Flip the value of a `Bool` -} -let not : Bool → Bool = λ(b : Bool) → b == False +let not + : Bool → Bool + = λ(b : Bool) → b == False let example0 = assert : not True ≡ False diff --git a/dhall-lang/Prelude/Bool/show b/dhall-lang/Prelude/Bool/show --- a/dhall-lang/Prelude/Bool/show +++ b/dhall-lang/Prelude/Bool/show @@ -2,7 +2,9 @@ Render a `Bool` as `Text` using the same representation as Dhall source code (i.e. beginning with a capital letter) -} -let show : Bool → Text = λ(b : Bool) → if b then "True" else "False" +let show + : Bool → Text + = λ(b : Bool) → if b then "True" else "False" let example0 = assert : show True ≡ "True" diff --git a/dhall-lang/Prelude/Double/show b/dhall-lang/Prelude/Double/show --- a/dhall-lang/Prelude/Double/show +++ b/dhall-lang/Prelude/Double/show @@ -2,7 +2,9 @@ Render a `Double` as `Text` using the same representation as Dhall source code (i.e. a decimal floating point number with a leading `-` sign if negative) -} -let show : Double → Text = Double/show +let show + : Double → Text + = Double/show let example0 = assert : show -3.1 ≡ "-3.1" diff --git a/dhall-lang/Prelude/Integer/show b/dhall-lang/Prelude/Integer/show --- a/dhall-lang/Prelude/Integer/show +++ b/dhall-lang/Prelude/Integer/show @@ -3,7 +3,9 @@ code (i.e. a decimal number with a leading `-` sign if negative and a leading `+` sign if non-negative) -} -let show : Integer → Text = Integer/show +let show + : Integer → Text + = Integer/show let example0 = assert : show -3 ≡ "-3" diff --git a/dhall-lang/Prelude/Integer/toDouble b/dhall-lang/Prelude/Integer/toDouble --- a/dhall-lang/Prelude/Integer/toDouble +++ b/dhall-lang/Prelude/Integer/toDouble @@ -1,7 +1,9 @@ {- Convert an `Integer` to the corresponding `Double` -} -let toDouble : Integer → Double = Integer/toDouble +let toDouble + : Integer → Double + = Integer/toDouble let example0 = assert : toDouble -3 ≡ -3.0 diff --git a/dhall-lang/Prelude/JSON/Nesting b/dhall-lang/Prelude/JSON/Nesting --- a/dhall-lang/Prelude/JSON/Nesting +++ b/dhall-lang/Prelude/JSON/Nesting @@ -28,4 +28,8 @@ ``` -} -let Nesting : Type = < Inline | Nested : Text > in Nesting +let Nesting + : Type + = < Inline | Nested : Text > + +in Nesting 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 @@ -70,8 +70,7 @@ , nesting : ./Nesting sha256:6284802edd41d5d725aa1ec7687e614e21ad1be7e14dd10996bfa9625105c335 ? ./Nesting - , contents : - a + , contents : a } in Tagged diff --git a/dhall-lang/Prelude/JSON/Type b/dhall-lang/Prelude/JSON/Type --- a/dhall-lang/Prelude/JSON/Type +++ b/dhall-lang/Prelude/JSON/Type @@ -57,18 +57,12 @@ : 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 + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → JSON diff --git a/dhall-lang/Prelude/JSON/array b/dhall-lang/Prelude/JSON/array --- a/dhall-lang/Prelude/JSON/array +++ b/dhall-lang/Prelude/JSON/array @@ -24,18 +24,12 @@ = λ(x : List JSON) → λ(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 + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.array (List/map JSON@1 JSON (λ(j : JSON@1) → j JSON json) x) diff --git a/dhall-lang/Prelude/JSON/bool b/dhall-lang/Prelude/JSON/bool --- a/dhall-lang/Prelude/JSON/bool +++ b/dhall-lang/Prelude/JSON/bool @@ -19,18 +19,12 @@ = λ(x : Bool) → λ(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 + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.bool x diff --git a/dhall-lang/Prelude/JSON/keyText b/dhall-lang/Prelude/JSON/keyText --- a/dhall-lang/Prelude/JSON/keyText +++ b/dhall-lang/Prelude/JSON/keyText @@ -1,14 +1,2 @@ -{- -Builds a key-value record such that a List of them will be converted to a -homogeneous record by dhall-to-json and dhall-to-yaml. - -Both key and value are fixed to Text. -Take a look at `Record/keyValue` for a polymorphic version. --} -let keyText = - λ(key : Text) → λ(value : Text) → { mapKey = key, mapValue = value } - -let example0 = - assert : keyText "foo" "bar" ≡ { mapKey = "foo", mapValue = "bar" } - -in keyText + ../Map/keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc +? ../Map/keyText diff --git a/dhall-lang/Prelude/JSON/keyValue b/dhall-lang/Prelude/JSON/keyValue --- a/dhall-lang/Prelude/JSON/keyValue +++ b/dhall-lang/Prelude/JSON/keyValue @@ -1,17 +1,2 @@ -{- -Builds a key-value record such that a List of them will be converted to a -homogeneous record by dhall-to-json and dhall-to-yaml. --} -let keyValue = - λ(v : Type) - → λ(key : Text) - → λ(value : v) - → { mapKey = key, mapValue = value } - -let example0 = - assert : keyValue Natural "foo" 2 ≡ { mapKey = "foo", mapValue = 2 } - -let example1 = - assert : keyValue Text "bar" "baz" ≡ { mapKey = "bar", mapValue = "baz" } - -in keyValue + ../Map/keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c +? ../Map/keyValue diff --git a/dhall-lang/Prelude/JSON/null b/dhall-lang/Prelude/JSON/null --- a/dhall-lang/Prelude/JSON/null +++ b/dhall-lang/Prelude/JSON/null @@ -14,18 +14,12 @@ : JSON = λ(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 + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.null diff --git a/dhall-lang/Prelude/JSON/number b/dhall-lang/Prelude/JSON/number --- a/dhall-lang/Prelude/JSON/number +++ b/dhall-lang/Prelude/JSON/number @@ -19,18 +19,12 @@ = λ(x : Double) → λ(JSON : Type) → λ ( json - : { string : - Text → JSON - , number : - Double → JSON - , object : - List { mapKey : Text, mapValue : JSON } → JSON - , array : - List JSON → JSON - , bool : - Bool → JSON - , null : - JSON + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.number x diff --git a/dhall-lang/Prelude/JSON/object b/dhall-lang/Prelude/JSON/object --- a/dhall-lang/Prelude/JSON/object +++ b/dhall-lang/Prelude/JSON/object @@ -30,18 +30,12 @@ = λ(x : List { mapKey : Text, mapValue : JSON }) → λ(JSON : Type) → λ ( json - : { string : - Text → JSON - , number : - Double → JSON - , object : - List { mapKey : Text, mapValue : JSON } → JSON - , array : - List JSON → JSON - , bool : - Bool → JSON - , null : - JSON + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.object 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 @@ -32,10 +32,8 @@ = λ(j : JSON) → j Text - { string = - λ(x : Text) → Text/show x - , number = - λ(x : Double) → Double/show x + { string = λ(x : Text) → Text/show x + , number = λ(x : Double) → Double/show x , object = λ(x : List { mapKey : Text, mapValue : Text }) → let body = @@ -53,10 +51,8 @@ → let body = Text/concatMapSep "," Text (λ(y : Text) → " ${y}") x in "[${body} ]" - , bool = - λ(x : Bool) → if x then "true" else "false" - , null = - "null" + , bool = λ(x : Bool) → if x then "true" else "false" + , null = "null" } in render diff --git a/dhall-lang/Prelude/JSON/string b/dhall-lang/Prelude/JSON/string --- a/dhall-lang/Prelude/JSON/string +++ b/dhall-lang/Prelude/JSON/string @@ -19,18 +19,12 @@ = λ(x : Text) → λ(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 + : { string : Text → JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , array : List JSON → JSON + , bool : Bool → JSON + , null : JSON } ) → json.string x diff --git a/dhall-lang/Prelude/List/default b/dhall-lang/Prelude/List/default new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/default @@ -0,0 +1,15 @@ +{- +Unpack an `Optional` containing a `List`, defaulting to an empty list when the +`Optional` is `None` +-} +let default + : ∀(a : Type) → Optional (List a) → List a + = λ(a : Type) + → λ(o : Optional (List a)) + → Optional/fold (List a) o (List a) (λ(l : List a) → l) ([] : List a) + +let example0 = assert : default Bool (None (List Bool)) ≡ ([] : List Bool) + +let example1 = assert : default Bool (Some [ True ]) ≡ [ True ] + +in default diff --git a/dhall-lang/Prelude/List/empty b/dhall-lang/Prelude/List/empty new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/List/empty @@ -0,0 +1,10 @@ +{- +An empty list of the given type +-} +let empty + : ∀(a : Type) → List a + = λ(a : Type) → [] : List a + +let example0 = assert : empty Bool ≡ ([] : List Bool) + +in empty diff --git a/dhall-lang/Prelude/List/head b/dhall-lang/Prelude/List/head --- a/dhall-lang/Prelude/List/head +++ b/dhall-lang/Prelude/List/head @@ -1,7 +1,9 @@ {- Retrieve the first element of the list -} -let head : ∀(a : Type) → List a → Optional a = List/head +let head + : ∀(a : Type) → List a → Optional a + = List/head let example0 = assert : head Natural [ 0, 1, 2 ] ≡ Some 0 diff --git a/dhall-lang/Prelude/List/last b/dhall-lang/Prelude/List/last --- a/dhall-lang/Prelude/List/last +++ b/dhall-lang/Prelude/List/last @@ -1,7 +1,9 @@ {- Retrieve the last element of the list -} -let last : ∀(a : Type) → List a → Optional a = List/last +let last + : ∀(a : Type) → List a → Optional a + = List/last let example0 = assert : last Natural [ 0, 1, 2 ] ≡ Some 2 diff --git a/dhall-lang/Prelude/List/length b/dhall-lang/Prelude/List/length --- a/dhall-lang/Prelude/List/length +++ b/dhall-lang/Prelude/List/length @@ -1,7 +1,9 @@ {- Returns the number of elements in a list -} -let length : ∀(a : Type) → List a → Natural = List/length +let length + : ∀(a : Type) → List a → Natural + = List/length let example0 = assert : length Natural [ 0, 1, 2 ] ≡ 3 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 @@ -13,6 +13,12 @@ , concatMap = ./concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 ? ./concatMap +, default = + ./default sha256:0ed2a04df6c1d55c08bcdbad82b30980af9ac40d2df7a1628f3663e3e8b4fe01 + ? ./default +, empty = + ./empty sha256:b2f561f35098c457353723c93a22bd5de28d26ecc5370814bef9dfda421e0147 + ? ./empty , filter = ./filter sha256:8ebfede5bbfe09675f246c33eb83964880ac615c4b1be8d856076fdbc4b26ba6 ? ./filter diff --git a/dhall-lang/Prelude/List/reverse b/dhall-lang/Prelude/List/reverse --- a/dhall-lang/Prelude/List/reverse +++ b/dhall-lang/Prelude/List/reverse @@ -1,7 +1,9 @@ {- Reverse a list -} -let reverse : ∀(a : Type) → List a → List a = List/reverse +let reverse + : ∀(a : Type) → List a → List a + = List/reverse let example0 = assert : reverse Natural [ 0, 1, 2 ] ≡ [ 2, 1, 0 ] 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 @@ -23,8 +23,7 @@ → let length = List/length { index : Natural, value : a } kvs - in { count = - y.count + length + in { count = y.count + length , diff = λ(n : Natural) → List/fold @@ -36,10 +35,8 @@ ) → λ(z : list) → let kvNew = - { index = - kvOld.index + n - , value = - kvOld.value + { index = kvOld.index + n + , value = kvOld.value } in cons kvNew z diff --git a/dhall-lang/Prelude/Location/Type b/dhall-lang/Prelude/Location/Type --- a/dhall-lang/Prelude/Location/Type +++ b/dhall-lang/Prelude/Location/Type @@ -9,13 +9,10 @@ : ( missing sha256:f428188ff9d77ea15bc2bcd0da3f8ed81b304e175b07ade42a3b0fb02941b2aa as Location ? missing as Location ) - ≡ < Environment : - Text - | Local : - Text + ≡ < Environment : Text + | Local : Text | Missing - | Remote : - Text + | Remote : Text >.Missing in Location diff --git a/dhall-lang/Prelude/Map/empty b/dhall-lang/Prelude/Map/empty new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Map/empty @@ -0,0 +1,15 @@ +{- +An empty `Map` of the given key and value types +-} +let Map = + ./Type sha256:210c7a9eba71efbb0f7a66b3dcf8b9d3976ffc2bc0e907aadfb6aa29c333e8ed + ? ./Type + +let empty + : ∀(k : Type) → ∀(v : Type) → Map k v + = λ(k : Type) → λ(v : Type) → [] : Map k v + +let example0 = + assert : empty Text Bool ≡ ([] : List { mapKey : Text, mapValue : Bool }) + +in empty diff --git a/dhall-lang/Prelude/Map/keyText b/dhall-lang/Prelude/Map/keyText new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Map/keyText @@ -0,0 +1,15 @@ +{- +Builds a key-value record such that a `List` of them will be converted to a +homogeneous record by dhall-to-json and dhall-to-yaml. + +Both key and value are fixed to `Text`. + +Take a look at `./keyValue` for a polymorphic version. +-} +let keyText = + λ(key : Text) → λ(value : Text) → { mapKey = key, mapValue = value } + +let example0 = + assert : keyText "foo" "bar" ≡ { mapKey = "foo", mapValue = "bar" } + +in keyText diff --git a/dhall-lang/Prelude/Map/keyValue b/dhall-lang/Prelude/Map/keyValue new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Map/keyValue @@ -0,0 +1,17 @@ +{- +Builds a key-value record such that a List of them will be converted to a +homogeneous record by dhall-to-json and dhall-to-yaml. +-} +let keyValue = + λ(v : Type) + → λ(key : Text) + → λ(value : v) + → { mapKey = key, mapValue = value } + +let example0 = + assert : keyValue Natural "foo" 2 ≡ { mapKey = "foo", mapValue = 2 } + +let example1 = + assert : keyValue Text "bar" "baz" ≡ { mapKey = "bar", mapValue = "baz" } + +in keyValue diff --git a/dhall-lang/Prelude/Map/package.dhall b/dhall-lang/Prelude/Map/package.dhall --- a/dhall-lang/Prelude/Map/package.dhall +++ b/dhall-lang/Prelude/Map/package.dhall @@ -4,6 +4,15 @@ , Entry = ./Entry sha256:f334283bdd9cd88e6ea510ca914bc221fc2dab5fb424d24514b2e0df600d5346 ? ./Entry +, empty = + ./empty sha256:4c612558b8bbe8f955550ed3fb295d57b1b864c85cd52615b52d0ee0e9682e52 + ? ./empty +, keyText = + ./keyText sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc + ? ./keyText +, keyValue = + ./keyValue sha256:a0a97199d280c4cce72ffcbbf93b7ceda0a569cf4d173ac98e0aaaa78034b98c + ? ./keyValue , keys = ./keys sha256:d13ec34e6acf7c349d82272ef09a37c7bdf37f0dab489e9df47a1ff215d9f5e7 ? ./keys diff --git a/dhall-lang/Prelude/Monoid b/dhall-lang/Prelude/Monoid --- a/dhall-lang/Prelude/Monoid +++ b/dhall-lang/Prelude/Monoid @@ -36,4 +36,8 @@ : ./Monoid Text ``` -} -let Monoid : ∀(m : Type) → Type = λ(m : Type) → List m → m in Monoid +let Monoid + : ∀(m : Type) → Type + = λ(m : Type) → List m → m + +in Monoid diff --git a/dhall-lang/Prelude/Natural/even b/dhall-lang/Prelude/Natural/even --- a/dhall-lang/Prelude/Natural/even +++ b/dhall-lang/Prelude/Natural/even @@ -1,7 +1,9 @@ {- Returns `True` if a number if even and returns `False` otherwise -} -let even : Natural → Bool = Natural/even +let even + : Natural → Bool + = Natural/even let example0 = assert : even 3 ≡ False diff --git a/dhall-lang/Prelude/Natural/isZero b/dhall-lang/Prelude/Natural/isZero --- a/dhall-lang/Prelude/Natural/isZero +++ b/dhall-lang/Prelude/Natural/isZero @@ -1,7 +1,9 @@ {- Returns `True` if a number is `0` and returns `False` otherwise -} -let isZero : Natural → Bool = Natural/isZero +let isZero + : Natural → Bool + = Natural/isZero let example0 = assert : isZero 2 ≡ False diff --git a/dhall-lang/Prelude/Natural/odd b/dhall-lang/Prelude/Natural/odd --- a/dhall-lang/Prelude/Natural/odd +++ b/dhall-lang/Prelude/Natural/odd @@ -1,7 +1,9 @@ {- Returns `True` if a number is odd and returns `False` otherwise -} -let odd : Natural → Bool = Natural/odd +let odd + : Natural → Bool + = Natural/odd let example0 = assert : odd 3 ≡ True diff --git a/dhall-lang/Prelude/Natural/show b/dhall-lang/Prelude/Natural/show --- a/dhall-lang/Prelude/Natural/show +++ b/dhall-lang/Prelude/Natural/show @@ -2,7 +2,9 @@ Render a `Natural` number as `Text` using the same representation as Dhall source code (i.e. a decimal number) -} -let show : Natural → Text = Natural/show +let show + : Natural → Text + = Natural/show let example0 = assert : show 3 ≡ "3" diff --git a/dhall-lang/Prelude/Natural/subtract b/dhall-lang/Prelude/Natural/subtract --- a/dhall-lang/Prelude/Natural/subtract +++ b/dhall-lang/Prelude/Natural/subtract @@ -1,7 +1,9 @@ {- `subtract m n` computes `n - m`, truncating to `0` if `m > n` -} -let subtract : Natural → Natural → Natural = Natural/subtract +let subtract + : Natural → Natural → Natural + = Natural/subtract let example0 = assert : subtract 1 2 ≡ 1 diff --git a/dhall-lang/Prelude/Natural/toInteger b/dhall-lang/Prelude/Natural/toInteger --- a/dhall-lang/Prelude/Natural/toInteger +++ b/dhall-lang/Prelude/Natural/toInteger @@ -1,7 +1,9 @@ {- Convert a `Natural` number to the corresponding `Integer` -} -let toInteger : Natural → Integer = Natural/toInteger +let toInteger + : Natural → Integer + = Natural/toInteger let example0 = assert : toInteger 3 ≡ +3 diff --git a/dhall-lang/Prelude/Optional/default b/dhall-lang/Prelude/Optional/default new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Optional/default @@ -0,0 +1,15 @@ +{- +Unpack an `Optional`, returning the default when it's `None`. +-} +let default + : ∀(a : Type) → a → Optional a → a + = λ(a : Type) + → λ(default : a) + → λ(o : Optional a) + → Optional/fold a o a (λ(x : a) → x) default + +let example0 = assert : default Bool False (None Bool) ≡ False + +let example1 = assert : default Bool False (Some True) ≡ True + +in default diff --git a/dhall-lang/Prelude/Optional/package.dhall b/dhall-lang/Prelude/Optional/package.dhall --- a/dhall-lang/Prelude/Optional/package.dhall +++ b/dhall-lang/Prelude/Optional/package.dhall @@ -10,6 +10,9 @@ , concat = ./concat sha256:b49a3b7dc49eb83d150977caa5ae347be1cbbe14e3b6d0e07349bd2e5f707d69 ? ./concat +, default = + ./default sha256:8f802473931b605422b545d7b81de20dbecb38f2ae63950c13f5381865a7f012 + ? ./default , filter = ./filter sha256:b3d5e19a6cec592a76c12167a9e5e1e76649e776229d70a11c77b76cd29f617e ? ./filter 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 @@ -18,8 +18,7 @@ ( λ(x : a) → λ(status : Status) → merge - { Empty = - Status.NonEmpty (f x) + { Empty = Status.NonEmpty (f x) , NonEmpty = λ(result : Text) → Status.NonEmpty (f x ++ separator ++ result) 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 @@ -15,8 +15,7 @@ ( λ(element : Text) → λ(status : Status) → merge - { Empty = - Status.NonEmpty element + { Empty = Status.NonEmpty element , NonEmpty = λ(result : Text) → Status.NonEmpty (element ++ separator ++ result) 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 @@ -2,7 +2,9 @@ Render a `Text` literal as its own representation as Dhall source code (i.e. a double-quoted string literal) -} -let show : Text → Text = Text/show +let show + : Text → Text + = Text/show let example0 = assert : show "ABC" ≡ "\"ABC\"" diff --git a/dhall-lang/Prelude/XML/Type b/dhall-lang/Prelude/XML/Type --- a/dhall-lang/Prelude/XML/Type +++ b/dhall-lang/Prelude/XML/Type @@ -48,15 +48,11 @@ : Type = ∀(XML : Type) → ∀ ( xml - : { text : - Text → XML + : { text : Text → XML , element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML } diff --git a/dhall-lang/Prelude/XML/element b/dhall-lang/Prelude/XML/element --- a/dhall-lang/Prelude/XML/element +++ b/dhall-lang/Prelude/XML/element @@ -28,12 +28,9 @@ ? ../List/map let Args = - { attributes : - List { mapKey : Text, mapValue : Text } - , name : - Text - , content : - List XML + { attributes : List { mapKey : Text, mapValue : Text } + , name : Text + , content : List XML } : Type @@ -42,26 +39,19 @@ = λ(elem : Args) → λ(XML : Type) → λ ( xml - : { text : - Text → XML + : { text : Text → XML , element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML } ) → xml.element - { attributes = - elem.attributes - , name = - elem.name - , content = - List/map XML@1 XML (λ(x : XML@1) → x XML xml) elem.content + { attributes = elem.attributes + , name = elem.name + , content = List/map XML@1 XML (λ(x : XML@1) → x XML xml) elem.content } in element diff --git a/dhall-lang/Prelude/XML/leaf b/dhall-lang/Prelude/XML/leaf --- a/dhall-lang/Prelude/XML/leaf +++ b/dhall-lang/Prelude/XML/leaf @@ -21,10 +21,8 @@ : { attributes : List { mapKey : Text, mapValue : Text }, name : Text } → XML = λ ( elem - : { attributes : - List { mapKey : Text, mapValue : Text } - , name : - Text + : { attributes : List { mapKey : Text, mapValue : Text } + , name : Text } ) → element (elem ⫽ { content = [] : List XML }) 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 @@ -43,16 +43,12 @@ = λ(x : XML) → x Text - { text = - λ(d : Text) → d + { text = λ(d : Text) → d , element = λ ( elem - : { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List Text - , name : - Text + : { attributes : List { mapKey : Text, mapValue : Text } + , content : List Text + , name : Text } ) → let attribs = Text/concatMap Attr renderAttr elem.attributes diff --git a/dhall-lang/Prelude/XML/text b/dhall-lang/Prelude/XML/text --- a/dhall-lang/Prelude/XML/text +++ b/dhall-lang/Prelude/XML/text @@ -23,15 +23,11 @@ = λ(d : Text) → λ(XML : Type) → λ ( xml - : { text : - Text → XML + : { text : Text → XML , element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML } 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 @@ -11,13 +11,13 @@ ./Integer/package.dhall sha256:eb464566d3192dd16ce915a9bd874aaaad612d5c69beb356e5b7d2e0c4949dcf ? ./Integer/package.dhall , List = - ./List/package.dhall sha256:108be3af5ebd465f7091039f2216c433e65ae5d25556a9a71786dd84d33ef49a + ./List/package.dhall sha256:88ae09f29981480e62a39c925011b3246d716a80871440f071cf981efea1ad5e ? ./List/package.dhall , Location = ./Location/package.dhall sha256:0eb4e4a60814018009c720f6820aaa13cf9491eb1b09afb7b832039c6ee4d470 ? ./Location/package.dhall , Map = - ./Map/package.dhall sha256:5e378b6da12f26b64f796f9c1b61d89bcc5a591f3a3dedcf85cb4637bbb8b618 + ./Map/package.dhall sha256:598e9c76103b2686fbbda6cc30078f9e60dd846d9eaf155d0149cf0ae06c21c5 ? ./Map/package.dhall , Monoid = ./Monoid sha256:26fafa098600ef7a54ef9dba5ada416bbbdd21df1af306c052420c61553ad4af @@ -26,7 +26,7 @@ ./Natural/package.dhall sha256:4574df29e6bb82fd894c311f6c2ad9a22574756eb62f06d475aa8306d25006fc ? ./Natural/package.dhall , Optional = - ./Optional/package.dhall sha256:36a366af67a3c26cd5d196e095d3023f18953c5b5db3a03956fa554609e5442a + ./Optional/package.dhall sha256:7608f2d38dabee8bfe6865b4adc11289059984220f422d2b023b15b3908f7a4c ? ./Optional/package.dhall , JSON = ./JSON/package.dhall sha256:0c3c40a63108f2e6ad59f23b789c18eb484d0e9aebc9416c5a4f338c6753084b diff --git a/dhall-lang/tests/binary-decode/failure/unit/OperatorUnknownOpcode.dhallb b/dhall-lang/tests/binary-decode/failure/unit/OperatorUnknownOpcode.dhallb Binary files a/dhall-lang/tests/binary-decode/failure/unit/OperatorUnknownOpcode.dhallb and b/dhall-lang/tests/binary-decode/failure/unit/OperatorUnknownOpcode.dhallb differ diff --git a/dhall-lang/tests/binary-decode/success/unit/CompletionA.dhallb b/dhall-lang/tests/binary-decode/success/unit/CompletionA.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/binary-decode/success/unit/CompletionA.dhallb differ diff --git a/dhall-lang/tests/binary-decode/success/unit/CompletionB.dhall b/dhall-lang/tests/binary-decode/success/unit/CompletionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/binary-decode/success/unit/CompletionB.dhall @@ -0,0 +1,1 @@ +T::r diff --git a/dhall-lang/tests/import/data/importBoundary.dhall b/dhall-lang/tests/import/data/importBoundary.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/data/importBoundary.dhall @@ -0,0 +1,3 @@ +-- This file contains a free variable. This should be a type error, even if the variable +-- is in scope in the importing expression +x diff --git a/dhall-lang/tests/import/failure/customHeadersUsingBoundVariable.dhall b/dhall-lang/tests/import/failure/customHeadersUsingBoundVariable.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/customHeadersUsingBoundVariable.dhall @@ -0,0 +1,15 @@ +{- This is a type error because the custom headers are type-checked with an + empty context. This is necessary because: + + * import resolution precedes β-normalization + * we also don't want custom headers to leak program state anyway + + This should fail due to the `x` within the custom header being an unbound + variable +-} + +let x = "Bar" + +in https://httpbin.org/headers + using [ { mapKey = "Foo", mapValue = x } ] + as Text diff --git a/dhall-lang/tests/import/failure/importBoundary.dhall b/dhall-lang/tests/import/failure/importBoundary.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/importBoundary.dhall @@ -0,0 +1,1 @@ +\(x: Bool) -> ../data/importBoundary.dhall diff --git a/dhall-lang/tests/normalization/success/simple/completionA.dhall b/dhall-lang/tests/normalization/success/simple/completionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/simple/completionA.dhall @@ -0,0 +1,10 @@ +let Example = + { Type = { name : Text, id : Optional Natural } + , default = { name = "", id = None Natural } + } + +in { example0 = Example::{=} + , example1 = Example::{ name = "John Doe" } + , example2 = Example::{ id = Some 0 } + , example3 = Example::{ name = "Mary Jane", id = Some 0 } + } diff --git a/dhall-lang/tests/normalization/success/simple/completionB.dhall b/dhall-lang/tests/normalization/success/simple/completionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/simple/completionB.dhall @@ -0,0 +1,5 @@ +{ example0 = { id = None Natural, name = "" } +, example1 = { id = None Natural, name = "John Doe" } +, example2 = { id = Some 0, name = "" } +, example3 = { id = Some 0, name = "Mary Jane" } +} diff --git a/dhall-lang/tests/normalization/success/unit/CompletionA.dhall b/dhall-lang/tests/normalization/success/unit/CompletionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/CompletionA.dhall @@ -0,0 +1,1 @@ +{ default = {=}, Type = {} }::{=} diff --git a/dhall-lang/tests/normalization/success/unit/CompletionB.dhall b/dhall-lang/tests/normalization/success/unit/CompletionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/CompletionB.dhall @@ -0,0 +1,1 @@ +{=} diff --git a/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepA.dhall b/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepA.dhall @@ -0,0 +1,1 @@ +{ a : { b : { x : Bool } } } ⩓ { a : { b : { y : Bool } } } diff --git a/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepB.dhall b/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecursiveRecordTypeMergeDeepB.dhall @@ -0,0 +1,1 @@ +{ a : { b : { x : Bool, y : Bool } } } diff --git a/dhall-lang/tests/parser/failure/nonBase16Hash.dhall b/dhall-lang/tests/parser/failure/nonBase16Hash.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/failure/nonBase16Hash.dhall @@ -0,0 +1,1 @@ +./foo sha256:d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe1g diff --git a/dhall-lang/tests/parser/success/leadingSeparatorsA.dhall b/dhall-lang/tests/parser/success/leadingSeparatorsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/leadingSeparatorsA.dhall @@ -0,0 +1,10 @@ +{ emptyRecordLiteral = { , = } +, emptyRecordType = { , } +, emptyList = [,] : List Natural +, emptyUnionType = < | > + +, recordLiteral = { , x = 1, y = True } +, recordType = { , x : Natural, y : Bool } +, list = [ , 1, 2 ] +, unionType = < | x : Natural | y : Bool > +} diff --git a/dhall-lang/tests/parser/success/leadingSeparatorsB.dhallb b/dhall-lang/tests/parser/success/leadingSeparatorsB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/leadingSeparatorsB.dhallb @@ -0,0 +1,1 @@ +‚¨iemptyList‚gNaturalremptyRecordLiteral‚ oemptyRecordType‚ nemptyUnionType‚  dlist„ö‚‚mrecordLiteral‚¢ax‚ayõjrecordType‚¢axgNaturalaydBooliunionType‚ ¢axgNaturalaydBool diff --git a/dhall-lang/tests/parser/success/lineCommentCRLFA.dhall b/dhall-lang/tests/parser/success/lineCommentCRLFA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/lineCommentCRLFA.dhall @@ -0,0 +1,3 @@ +-- foo + +1 diff --git a/dhall-lang/tests/parser/success/lineCommentCRLFB.dhallb b/dhall-lang/tests/parser/success/lineCommentCRLFB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/lineCommentCRLFB.dhallb @@ -0,0 +1,1 @@ +‚ diff --git a/dhall-lang/tests/parser/success/text/dollarSignA.dhall b/dhall-lang/tests/parser/success/text/dollarSignA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/dollarSignA.dhall @@ -0,0 +1,1 @@ +"$" diff --git a/dhall-lang/tests/parser/success/text/dollarSignB.dhallb b/dhall-lang/tests/parser/success/text/dollarSignB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/dollarSignB.dhallb @@ -0,0 +1,1 @@ +‚a$ diff --git a/dhall-lang/tests/parser/success/unit/CompletionA.dhall b/dhall-lang/tests/parser/success/unit/CompletionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/CompletionA.dhall @@ -0,0 +1,1 @@ +T::r diff --git a/dhall-lang/tests/parser/success/unit/CompletionB.dhallb b/dhall-lang/tests/parser/success/unit/CompletionB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/CompletionB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroA.dhall b/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroA.dhall @@ -0,0 +1,1 @@ +-0.0 diff --git a/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroB.dhallb b/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/DoubleLitNegZeroB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixA.dhall b/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixA.dhall --- a/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixA.dhall +++ b/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixA.dhall @@ -1,2 +1,2 @@ -- Yes, this is legal -env:"\"\\\a\b\f\n\r\t\v" +env:"\"\\\a\b\f\n\r\t\v!<[~" diff --git a/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixB.dhallb b/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixB.dhallb Binary files a/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixB.dhallb and b/dhall-lang/tests/parser/success/unit/import/environmentVariablePosixB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsA.dhall b/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsA.dhall @@ -0,0 +1,1 @@ +https://200.249.250.255/index.dhall diff --git a/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsB.dhallb b/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/import/urls/ipv4upperoctetsB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongA.dhall b/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongA.dhall @@ -0,0 +1,1 @@ +http://[AAAA:BBBB:CCCC:DDDD:EEEE:FFFF:0000::]/tutorial.dhall diff --git a/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongB.dhallb b/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/import/urls/ipv6verylongB.dhallb differ diff --git a/dhall-lang/tests/type-inference/data/importBoundary.dhall b/dhall-lang/tests/type-inference/data/importBoundary.dhall deleted file mode 100644 --- a/dhall-lang/tests/type-inference/data/importBoundary.dhall +++ /dev/null @@ -1,3 +0,0 @@ --- This file contains a free variable. This should be a type error, even if the variable --- is in scope in the importing expression -x diff --git a/dhall-lang/tests/type-inference/failure/customHeadersUsingBoundVariable.dhall b/dhall-lang/tests/type-inference/failure/customHeadersUsingBoundVariable.dhall deleted file mode 100644 --- a/dhall-lang/tests/type-inference/failure/customHeadersUsingBoundVariable.dhall +++ /dev/null @@ -1,15 +0,0 @@ -{- This is a type error because the custom headers are type-checked with an - empty context. This is necessary because: - - * import resolution precedes β-normalization - * we also don't want custom headers to leak program state anyway - - This should fail due to the `x` within the custom header being an unbound - variable --} - -let x = "Bar" - -in https://httpbin.org/headers - using [ { mapKey = "Foo", mapValue = x } ] - as Text diff --git a/dhall-lang/tests/type-inference/failure/importBoundary.dhall b/dhall-lang/tests/type-inference/failure/importBoundary.dhall deleted file mode 100644 --- a/dhall-lang/tests/type-inference/failure/importBoundary.dhall +++ /dev/null @@ -1,1 +0,0 @@ -\(x: Bool) -> ../data/importBoundary.dhall 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 @@ -1,23 +1,16 @@ { Bool : - { and : - ∀(xs : List Bool) → Bool + { and : ∀(xs : List Bool) → Bool , build : ∀(f : ∀(bool : Type) → ∀(true : bool) → ∀(false : bool) → bool) → Bool - , even : - ∀(xs : List Bool) → Bool + , even : ∀(xs : List Bool) → Bool , fold : ∀(b : Bool) → ∀(bool : Type) → ∀(true : bool) → ∀(false : bool) → bool - , not : - ∀(b : Bool) → Bool - , odd : - ∀(xs : List Bool) → Bool - , or : - ∀(xs : List Bool) → Bool - , show : - ∀(b : Bool) → Text + , not : ∀(b : Bool) → Bool + , odd : ∀(xs : List Bool) → Bool + , or : ∀(xs : List Bool) → Bool + , show : ∀(b : Bool) → Text } -, Double : - { show : Double → Text } +, Double : { show : Double → Text } , Function : { compose : ∀(A : Type) @@ -28,32 +21,23 @@ → ∀(x : A) → C } -, Integer : - { show : Integer → Text, toDouble : Integer → Double } +, Integer : { show : Integer → Text, toDouble : Integer → Double } , JSON : - { Nesting : - Type - , Tagged : - ∀(a : Type) → Type - , Type : - Type + { Nesting : Type + , Tagged : ∀(a : Type) → Type + , Type : Type , array : ∀ ( x : List ( ∀(JSON : Type) → ∀ ( json - : { array : - List JSON → JSON - , bool : - Bool → JSON - , null : - JSON - , number : - Double → JSON + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON - , string : - Text → JSON + , string : Text → JSON } ) → JSON @@ -61,18 +45,12 @@ ) → ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON @@ -80,18 +58,12 @@ ∀(x : Bool) → ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON @@ -105,18 +77,12 @@ , null : ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON @@ -124,41 +90,29 @@ ∀(x : Double) → ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON , object : ∀ ( x : List - { mapKey : - Text + { mapKey : Text , mapValue : ∀(JSON : Type) → ∀ ( json - : { array : - List JSON → JSON - , bool : - Bool → JSON - , null : - JSON - , number : - Double → JSON + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON , object : List { mapKey : Text, mapValue : JSON } → JSON - , string : - Text → JSON + , string : Text → JSON } ) → JSON @@ -166,18 +120,12 @@ ) → ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON @@ -185,18 +133,12 @@ ∀ ( j : ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON @@ -206,37 +148,29 @@ ∀(x : Text) → ∀(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 + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) → JSON } , List : - { all : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool - , any : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool + { all : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool + , any : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → Bool , build : ∀(a : Type) → (∀(list : Type) → ∀(cons : a → list → list) → ∀(nil : list) → list) → List a - , concat : - ∀(a : Type) → ∀(xss : List (List a)) → List a + , concat : ∀(a : Type) → ∀(xss : List (List a)) → List a , concatMap : ∀(a : Type) → ∀(b : Type) → ∀(f : a → List b) → ∀(xs : List a) → List b - , filter : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → List a + , default : ∀(a : Type) → ∀(o : Optional (List a)) → List a + , empty : ∀(a : Type) → List a + , filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : List a) → List a , fold : ∀(a : Type) → List a @@ -244,26 +178,16 @@ → ∀(cons : a → list → list) → ∀(nil : list) → list - , generate : - ∀(n : Natural) → ∀(a : Type) → ∀(f : Natural → a) → List a - , head : - ∀(a : Type) → List a → Optional a - , indexed : - ∀(a : Type) → List a → List { index : Natural, value : a } - , iterate : - ∀(n : Natural) → ∀(a : Type) → ∀(f : a → a) → ∀(x : a) → List a - , last : - ∀(a : Type) → List a → Optional a - , 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 - , replicate : - ∀(n : Natural) → ∀(a : Type) → ∀(x : a) → List a - , reverse : - ∀(a : Type) → List a → List a + , generate : ∀(n : Natural) → ∀(a : Type) → ∀(f : Natural → a) → List a + , head : ∀(a : Type) → List a → Optional a + , indexed : ∀(a : Type) → List a → List { index : Natural, value : a } + , iterate : ∀(n : Natural) → ∀(a : Type) → ∀(f : a → a) → ∀(x : a) → List a + , last : ∀(a : Type) → List a → Optional a + , 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 + , 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 })) @@ -274,13 +198,18 @@ → ∀(xs : List { _1 : a, _2 : b }) → { _1 : List a, _2 : List b } } -, Location : - { Type : Type } +, Location : { Type : Type } , Map : - { Entry : - ∀(k : Type) → ∀(v : Type) → Type - , Type : - ∀(k : Type) → ∀(v : Type) → Type + { Entry : ∀(k : Type) → ∀(v : Type) → Type + , Type : ∀(k : Type) → ∀(v : Type) → Type + , empty : ∀(k : Type) → ∀(v : Type) → List { mapKey : k, mapValue : v } + , keyText : + ∀(key : Text) → ∀(value : Text) → { mapKey : Text, mapValue : Text } + , keyValue : + ∀(v : Type) + → ∀(key : Text) + → ∀(value : v) + → { mapKey : Text, mapValue : v } , keys : ∀(k : Type) → ∀(v : Type) @@ -299,8 +228,7 @@ → ∀(xs : List { mapKey : k, mapValue : v }) → List v } -, Monoid : - ∀(m : Type) → Type +, Monoid : ∀(m : Type) → Type , Natural : { build : ( ∀(natural : Type) @@ -309,48 +237,31 @@ → natural ) → Natural - , enumerate : - ∀(n : Natural) → List Natural - , equal : - ∀(a : Natural) → ∀(b : Natural) → Bool - , even : - Natural → Bool + , enumerate : ∀(n : Natural) → List Natural + , equal : ∀(a : Natural) → ∀(b : Natural) → Bool + , even : Natural → Bool , fold : Natural → ∀(natural : Type) → ∀(succ : natural → natural) → ∀(zero : natural) → natural - , greaterThan : - ∀(x : Natural) → ∀(y : Natural) → Bool - , greaterThanEqual : - ∀(x : Natural) → ∀(y : Natural) → Bool - , isZero : - Natural → Bool - , lessThan : - ∀(x : Natural) → ∀(y : Natural) → Bool - , lessThanEqual : - ∀(x : Natural) → ∀(y : Natural) → Bool - , odd : - Natural → Bool - , product : - ∀(xs : List Natural) → Natural - , show : - Natural → Text - , subtract : - Natural → Natural → Natural - , sum : - ∀(xs : List Natural) → Natural - , toDouble : - ∀(n : Natural) → Double - , toInteger : - Natural → Integer + , greaterThan : ∀(x : Natural) → ∀(y : Natural) → Bool + , greaterThanEqual : ∀(x : Natural) → ∀(y : Natural) → Bool + , isZero : Natural → Bool + , lessThan : ∀(x : Natural) → ∀(y : Natural) → Bool + , lessThanEqual : ∀(x : Natural) → ∀(y : Natural) → Bool + , odd : Natural → Bool + , product : ∀(xs : List Natural) → Natural + , show : Natural → Text + , subtract : Natural → Natural → Natural + , sum : ∀(xs : List Natural) → Natural + , toDouble : ∀(n : Natural) → Double + , toInteger : Natural → Integer } , Optional : - { all : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool - , any : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool + { all : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool + , any : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool , build : ∀(a : Type) → ( ∀(optional : Type) @@ -359,10 +270,9 @@ → optional ) → Optional a - , concat : - ∀(a : Type) → ∀(x : Optional (Optional a)) → Optional a - , filter : - ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Optional a + , concat : ∀(a : Type) → ∀(x : Optional (Optional a)) → Optional a + , default : ∀(a : Type) → ∀(default : a) → ∀(o : Optional a) → a + , filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Optional a , fold : ∀(a : Type) → Optional a @@ -370,22 +280,17 @@ → ∀(just : a → optional) → ∀(nothing : optional) → optional - , head : - ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a - , last : - ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a - , length : - ∀(a : Type) → ∀(xs : Optional a) → Natural + , head : ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a + , last : ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a + , length : ∀(a : Type) → ∀(xs : Optional a) → Natural , map : ∀(a : Type) → ∀(b : Type) → ∀(f : a → b) → ∀(o : Optional a) → Optional b - , null : - ∀(a : Type) → ∀(xs : Optional a) → Bool - , toList : - ∀(a : Type) → ∀(o : Optional a) → List a + , null : ∀(a : Type) → ∀(xs : Optional a) → Bool + , toList : ∀(a : Type) → ∀(o : Optional a) → List a , unzip : ∀(a : Type) → ∀(b : Type) @@ -393,34 +298,26 @@ → { _1 : Optional a, _2 : Optional b } } , Text : - { concat : - ∀(xs : List Text) → Text - , concatMap : - ∀(a : Type) → ∀(f : a → Text) → ∀(xs : List a) → Text + { concat : ∀(xs : List Text) → Text + , concatMap : ∀(a : Type) → ∀(f : a → Text) → ∀(xs : List a) → Text , concatMapSep : ∀(separator : Text) → ∀(a : Type) → ∀(f : a → Text) → ∀(elements : List a) → Text - , concatSep : - ∀(separator : Text) → ∀(elements : List Text) → Text - , default : - ∀(o : Optional Text) → Text - , defaultMap : - ∀(a : Type) → ∀(f : a → Text) → ∀(o : Optional a) → Text - , show : - Text → Text + , concatSep : ∀(separator : Text) → ∀(elements : List Text) → Text + , default : ∀(o : Optional Text) → Text + , defaultMap : ∀(a : Type) → ∀(f : a → Text) → ∀(o : Optional a) → Text + , show : Text → Text } , XML : - { Type : - Type + { Type : Type , attribute : ∀(key : Text) → ∀(value : Text) → { mapKey : Text, mapValue : Text } , element : ∀ ( elem - : { attributes : - List { mapKey : Text, mapValue : Text } + : { attributes : List { mapKey : Text, mapValue : Text } , content : List ( ∀(XML : Type) @@ -428,61 +325,46 @@ : { element : { attributes : List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + , content : List XML + , name : Text } → XML - , text : - Text → XML + , text : Text → XML } ) → XML ) - , name : - Text + , name : Text } ) → ∀(XML : Type) → ∀ ( xml : { element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML - , text : - Text → XML + , text : Text → XML } ) → XML - , emptyAttributes : - List { mapKey : Text, mapValue : Text } + , emptyAttributes : List { mapKey : Text, mapValue : Text } , leaf : ∀ ( elem - : { attributes : - List { mapKey : Text, mapValue : Text } - , name : - Text + : { attributes : List { mapKey : Text, mapValue : Text } + , name : Text } ) → ∀(XML : Type) → ∀ ( xml : { element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML - , text : - Text → XML + , text : Text → XML } ) → XML @@ -491,16 +373,12 @@ : ∀(XML : Type) → ∀ ( xml : { element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML - , text : - Text → XML + , text : Text → XML } ) → XML @@ -511,16 +389,12 @@ → ∀(XML : Type) → ∀ ( xml : { element : - { attributes : - List { mapKey : Text, mapValue : Text } - , content : - List XML - , name : - Text + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text } → XML - , text : - Text → XML + , text : Text → XML } ) → XML diff --git a/dhall-lang/tests/type-inference/success/simple/completionA.dhall b/dhall-lang/tests/type-inference/success/simple/completionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/completionA.dhall @@ -0,0 +1,25 @@ +let Example = + { Type = { name : Text, id : Optional Natural } + , default = { name = "", id = None Natural } + } + +let ExtraFields = Example ∧ { extra = {=} } + +let RequiredFields = + { Type = { name : Text, id : Optional Natural } + , default = { id = None Natural } + } + +let WrongDefaultType = + { Type = { name : Text, id : Optional Natural } + , default = { id = True } + } + +in { example0 = Example::{=} + , example1 = Example::{ name = "John Doe" } + , example2 = Example::{ id = Some 0 } + , example3 = Example::{ name = "Mary Jane", id = Some 0 } + , example4 = ExtraFields::{=} + , example5 = RequiredFields::{ name = "Jane Smith" } + , example6 = WrongDefaultType::{ name = "Bob Roberts", id = Some 0 } + } diff --git a/dhall-lang/tests/type-inference/success/simple/completionB.dhall b/dhall-lang/tests/type-inference/success/simple/completionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/completionB.dhall @@ -0,0 +1,8 @@ +{ example0 : { id : Optional Natural, name : Text } +, example1 : { id : Optional Natural, name : Text } +, example2 : { id : Optional Natural, name : Text } +, example3 : { id : Optional Natural, name : Text } +, example4 : { id : Optional Natural, name : Text } +, example5 : { id : Optional Natural, name : Text } +, example6 : { id : Optional Natural, name : Text } +} diff --git a/dhall-lang/tests/type-inference/success/simple/orderInsensitivityA.dhall b/dhall-lang/tests/type-inference/success/simple/orderInsensitivityA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/orderInsensitivityA.dhall @@ -0,0 +1,15 @@ +{- This test caught a regression in the Haskell implementation's typechecker. + + The typechecker was not sorting the fields of a record type inferred from a + projection, meaning that it inferred that the fully normalized type of + the subexpression `{ bar = "", foo = "" }.{ foo, bar }` was + `{ foo : Text, bar : Text }` when according to the standard the inferred type + should have been `{ bar : Text, foo : Text }`. On top of that the Haskell + implementation was sensitive to field order, leading to a type mismatch + when applying a function whose input type had the fields sorted. + + This test ensures that implementations correctly handle order-insensitivity + when projecting fields and/or comparing types, just in case they are + order-sensitive like the Haskell implementation. +-} +λ(f : { bar : Text, foo : Text } → Bool) → f { bar = "", foo = "" }.{ foo, bar } diff --git a/dhall-lang/tests/type-inference/success/simple/orderInsensitivityB.dhall b/dhall-lang/tests/type-inference/success/simple/orderInsensitivityB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/orderInsensitivityB.dhall @@ -0,0 +1,1 @@ +∀(f : { bar : Text, foo : Text } → Bool) → Bool diff --git a/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationA.dhall b/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationA.dhall @@ -0,0 +1,3 @@ +toMap + { x = Bool }.{} +: List { mapKey : { t = Text }.t, mapValue : { t = Double }.t } diff --git a/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationB.dhall b/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/simple/toMapEmptyNormalizeAnnotationB.dhall @@ -0,0 +1,1 @@ +List { mapKey : Text, mapValue : Double } diff --git a/dhall-lang/tests/type-inference/success/unit/CompletionA.dhall b/dhall-lang/tests/type-inference/success/unit/CompletionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/CompletionA.dhall @@ -0,0 +1,1 @@ +{ default = {=}, Type = {} }::{=} diff --git a/dhall-lang/tests/type-inference/success/unit/CompletionB.dhall b/dhall-lang/tests/type-inference/success/unit/CompletionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/CompletionB.dhall @@ -0,0 +1,1 @@ +{} diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentA.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentA.dhall @@ -0,0 +1,1 @@ +List/length (let x = 0 in Bool) diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentB.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeArgumentB.dhall @@ -0,0 +1,1 @@ +List Bool → Natural diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultA.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultA.dhall @@ -0,0 +1,1 @@ +(λ(g : Natural → Bool) → assert : g 0 ≡ g 0) Natural/even diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultB.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionApplicationNormalizeResultB.dhall @@ -0,0 +1,1 @@ +True ≡ True diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationA.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationA.dhall @@ -0,0 +1,1 @@ +λ(x : { t = Bool }.t) → x diff --git a/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationB.dhall b/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/FunctionNormalizeTypeAnnotationB.dhall @@ -0,0 +1,1 @@ +∀(x : Bool) → Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0A.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0A.dhall @@ -0,0 +1,1 @@ +merge { x = λ(_ : Bool) → _ } (< x : Bool >.x True) : Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0B.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation0B.dhall @@ -0,0 +1,1 @@ +Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1A.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1A.dhall @@ -0,0 +1,1 @@ +merge { x = λ(y : Bool) → y } < x >.x : (Bool → Bool) diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1B.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotation1B.dhall @@ -0,0 +1,1 @@ +∀(y : Bool) → Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationA.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationA.dhall deleted file mode 100644 --- a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -merge { x = λ(_ : Bool) → _ } (< x : Bool >.x True) : Bool diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationB.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationB.dhall deleted file mode 100644 --- a/dhall-lang/tests/type-inference/success/unit/MergeOneWithAnnotationB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -Bool diff --git a/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepA.dhall b/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepA.dhall @@ -0,0 +1,1 @@ +{ a : { b : { x : Bool } } } ⩓ { a : { b : { y : Bool } } } diff --git a/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepB.dhall b/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecursiveRecordTypeMergeDeepB.dhall @@ -0,0 +1,1 @@ +Type diff --git a/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordA.dhall b/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordA.dhall @@ -0,0 +1,1 @@ +toMap { x = λ(x : Bool) → x } : List { mapKey : Text, mapValue : Bool → Bool } diff --git a/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordB.dhall b/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/ToMapInferTypeFromRecordB.dhall @@ -0,0 +1,1 @@ +List { mapKey : Text, mapValue : ∀(x : Bool) → Bool } diff --git a/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionA.dhall b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionA.dhall @@ -0,0 +1,1 @@ +(λ(x : Bool) → x) : Bool → Bool diff --git a/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionB.dhall b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationFunctionB.dhall @@ -0,0 +1,1 @@ +∀(x : Bool) → Bool diff --git a/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeA.dhall b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeA.dhall @@ -0,0 +1,1 @@ +True : { x = Bool }.x diff --git a/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeB.dhall b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/TypeAnnotationNormalizeB.dhall @@ -0,0 +1,1 @@ +Bool diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.26.1 +Version: 1.27.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 @@ -61,6 +61,8 @@ dhall-lang/Prelude/List/build dhall-lang/Prelude/List/concat dhall-lang/Prelude/List/concatMap + dhall-lang/Prelude/List/default + dhall-lang/Prelude/List/empty dhall-lang/Prelude/List/filter dhall-lang/Prelude/List/fold dhall-lang/Prelude/List/generate @@ -79,7 +81,10 @@ dhall-lang/Prelude/Location/package.dhall dhall-lang/Prelude/Location/Type dhall-lang/Prelude/Map/Entry + dhall-lang/Prelude/Map/empty dhall-lang/Prelude/Map/keys + dhall-lang/Prelude/Map/keyText + dhall-lang/Prelude/Map/keyValue dhall-lang/Prelude/Map/map dhall-lang/Prelude/Map/package.dhall dhall-lang/Prelude/Map/Type @@ -107,6 +112,7 @@ dhall-lang/Prelude/Optional/any dhall-lang/Prelude/Optional/build dhall-lang/Prelude/Optional/concat + dhall-lang/Prelude/Optional/default dhall-lang/Prelude/Optional/filter dhall-lang/Prelude/Optional/fold dhall-lang/Prelude/Optional/head @@ -295,7 +301,6 @@ dhall-lang/tests/semantic-hash/success/simple/*.hash dhall-lang/tests/semantic-hash/success/simplifications/*.dhall dhall-lang/tests/semantic-hash/success/simplifications/*.hash - dhall-lang/tests/type-inference/data/*.dhall dhall-lang/tests/type-inference/failure/*.dhall dhall-lang/tests/type-inference/success/*.dhall dhall-lang/tests/type-inference/success/prelude/Bool/and/*.dhall @@ -366,6 +371,8 @@ tests/diff/*.txt tests/recursive/*.dhall tests/regression/*.dhall + tests/tags/*.dhall + tests/tags/*.tags tests/tutorial/*.dhall Source-Repository head @@ -404,6 +411,7 @@ exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , haskeline >= 0.7.2.1 && < 0.8 , + hashable >= 1.2 && < 1.3 , lens-family-core >= 1.0.0 && < 2.1 , megaparsec >= 6.5.0 && < 7.1 , memory >= 0.14 && < 0.16, @@ -482,9 +490,9 @@ Dhall.Core, Dhall.Crypto, Dhall.Diff, + Dhall.Tags, Dhall.Format, Dhall.Freeze, - Dhall.Hash, Dhall.Import, Dhall.Lint, Dhall.Main, @@ -509,6 +517,7 @@ Dhall.Parser.Combinators, Dhall.URL, Dhall.Import.Types, + Dhall.Syntax, Dhall.Eval, Paths_dhall Autogen-Modules: @@ -535,6 +544,7 @@ Other-Modules: Dhall.Test.Dhall Dhall.Test.Diff + Dhall.Test.Tags Dhall.Test.Format Dhall.Test.Import Dhall.Test.Lint @@ -555,6 +565,7 @@ deepseq >= 1.2.0.1 && < 1.5 , dhall , directory , + either , filepath , foldl < 1.5 , generic-random >= 1.3.0.0 && < 1.4 , @@ -566,6 +577,7 @@ scientific , semigroups , serialise , + special-values < 0.2 , spoon < 0.4 , tasty >= 0.11.2 && < 1.3 , tasty-expected-failure < 0.12, @@ -574,6 +586,7 @@ text >= 0.11.1.0 && < 1.3 , transformers , turtle < 1.6 , + unordered-containers , vector >= 0.11.0.0 && < 0.13 if flag(with-http) CPP-Options: diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -17,7 +17,7 @@ prefix <- System.Directory.makeAbsolute pwd Test.Mockery.Directory.inTempDirectory $ do - writeFile "makeBools" "λ(n : Bool) → [ n && True, n && False, n || True, n || False ]" + writeFile "makeBools.dhall" "λ(n : Bool) → [ n && True, n && False, n || True, n || False ]" writeFile "bool1" "True" writeFile "bool2" "False" writeFile "both" "./bool1 && ./bool2" @@ -32,4 +32,5 @@ , prefix "src/Dhall.hs" , prefix "src/Dhall/Import.hs" , prefix "src/Dhall/Tutorial.hs" + , prefix "src/Dhall/Tags.hs" ] diff --git a/ghc-src/Dhall/Crypto.hs b/ghc-src/Dhall/Crypto.hs --- a/ghc-src/Dhall/Crypto.hs +++ b/ghc-src/Dhall/Crypto.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| This module provides implementations of cryptographic utilities that only + work for GHC (as opposed to GHCJS) +-} + module Dhall.Crypto ( SHA256Digest(..) , sha256DigestFromByteString @@ -17,17 +21,22 @@ import qualified Crypto.Hash import qualified Data.ByteString.Char8 as ByteString.Char8 +-- | A SHA256 digest newtype SHA256Digest = SHA256Digest { unSHA256Digest :: ByteString } deriving (Eq, Generic, Ord, NFData, ByteArrayAccess) instance Show SHA256Digest where show (SHA256Digest bytes) = ByteString.Char8.unpack $ convertToBase Base16 bytes +{-| Attempt to interpret a `ByteString` as a `SHA256Digest`, returning + `Nothing` if the conversion fails +-} sha256DigestFromByteString :: ByteString -> Maybe SHA256Digest sha256DigestFromByteString bytes = SHA256Digest . convert <$> mh where mh = Crypto.Hash.digestFromByteString bytes :: Maybe (Crypto.Hash.Digest SHA256) +-- | Hash a `ByteString` and return the hash as a `SHA256Digest` sha256Hash :: ByteString -> SHA256Digest sha256Hash bytes = SHA256Digest $ convert h where diff --git a/ghcjs-src/Dhall/Crypto.hs b/ghcjs-src/Dhall/Crypto.hs --- a/ghcjs-src/Dhall/Crypto.hs +++ b/ghcjs-src/Dhall/Crypto.hs @@ -2,6 +2,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE JavaScriptFFI #-} +{-| This module provides implementations of cryptographic utilities that only + work for GHCJS +-} + module Dhall.Crypto ( SHA256Digest(..) , sha256DigestFromByteString @@ -20,12 +24,16 @@ import qualified Data.ByteString.Char8 as ByteString.Char8 import qualified GHCJS.Buffer as Buffer +-- | A SHA256 digest newtype SHA256Digest = SHA256Digest { unSHA256Digest :: ByteString } deriving (Eq, Generic, Ord, NFData, ByteArrayAccess) instance Show SHA256Digest where show (SHA256Digest bytes) = ByteString.Char8.unpack $ convertToBase Base16 bytes +{-| Attempt to interpret a `ByteString` as a `SHA256Digest`, returning + `Nothing` if the conversion fails +-} sha256DigestFromByteString :: ByteString -> Maybe SHA256Digest sha256DigestFromByteString bytes | ByteString.length bytes == 32 = Just $ SHA256Digest bytes @@ -55,6 +63,7 @@ arrayBufferToByteString = Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer +-- | Hash a `ByteString` and return the hash as a `SHA256Digest` sha256Hash :: ByteString -> SHA256Digest sha256Hash bytes | ByteString.length out == 32 = SHA256Digest out diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -46,7 +46,8 @@ , RecordType(..) , UnionType(..) , InputType(..) - , Interpret(..) + , FromDhall(..) + , Interpret , InvalidType(..) , ExtractErrors(..) , Extractor @@ -71,19 +72,28 @@ , sequence , list , vector + , setFromDistinctList + , setIgnoringDuplicates + , hashSetFromDistinctList + , hashSetIgnoringDuplicates + , Dhall.map + , hashMap + , pairFromMapEntry , unit + , void , string , pair , record , field , union , constructor - , GenericInterpret(..) - , GenericInject(..) + , GenericFromDhall(..) + , GenericToDhall(..) - , Inject(..) + , ToDhall(..) + , Inject , inject - , genericInject + , genericToDhall , RecordInputType(..) , inputFieldWith , inputField @@ -116,7 +126,10 @@ import Data.Fix (Fix(..)) import Data.Functor.Contravariant (Contravariant(..), (>$<), Op(..)) import Data.Functor.Contravariant.Divisible (Divisible(..), divided) +import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty (..)) +import Data.HashMap.Strict (HashMap) +import Data.Map (Map) import Data.Monoid ((<>)) import Data.Scientific (Scientific) import Data.Semigroup (Semigroup) @@ -125,13 +138,14 @@ import Data.Text.Prettyprint.Doc (Pretty) import Data.Typeable (Typeable) import Data.Vector (Vector) +import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64) -import Dhall.Core (Expr(..), Chunks(..)) +import Dhall.Core (Expr(..), Chunks(..), DhallDouble(..)) import Dhall.Import (Imported(..)) import Dhall.Parser (Src(..)) -import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) +import Dhall.TypeCheck (DetailedTypeError(..), TypeError) import GHC.Generics -import Lens.Family (LensLike', set, view) +import Lens.Family (LensLike', view) import Numeric.Natural (Natural) import Prelude hiding (maybe, sequence) import System.FilePath (takeDirectory) @@ -142,16 +156,21 @@ import qualified Data.Foldable import qualified Data.Functor.Compose import qualified Data.Functor.Product +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map import qualified Data.Maybe +import qualified Data.List import qualified Data.List.NonEmpty import qualified Data.Semigroup import qualified Data.Scientific import qualified Data.Sequence import qualified Data.Set +import qualified Data.HashSet import qualified Data.Text import qualified Data.Text.IO import qualified Data.Text.Lazy import qualified Data.Vector +import qualified Data.Void import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Import @@ -160,18 +179,32 @@ import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck import qualified Dhall.Util +import qualified Lens.Family -- $setup -- >>> :set -XOverloadedStrings -- >>> :set -XRecordWildCards +-- >>> import Data.Word (Word8, Word16, Word32, Word64) +-- >>> import Dhall.Pretty.Internal (prettyExpr) +{-| Useful synonym for the `Validation` type used when marshalling Dhall + expressions +-} type Extractor s a = Validation (ExtractErrors s a) -type MonadicExtractor s a = Either (ExtractErrors s a) +{-| Useful synonym for the equivalent `Either` type used when marshalling Dhall + code +-} +type MonadicExtractor s a = Either (ExtractErrors s a) +{-| Generate a type error during extraction by specifying the expected type + and the actual type +-} typeError :: Expr s a -> Expr s a -> Extractor s a b -typeError expected actual = Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual +typeError expected actual = + Failure . ExtractErrors . pure . TypeMismatch $ InvalidType expected actual +-- | Turn a `Text` message into an extraction failure extractError :: Text -> Extractor s a b extractError = Failure . ExtractErrors . pure . ExtractError @@ -185,6 +218,9 @@ fromMonadic :: MonadicExtractor s a b -> Extractor s a b fromMonadic = eitherToValidation +{-| One or more errors returned from extracting a Dhall expression to a + Haskell expression +-} newtype ExtractErrors s a = ExtractErrors { getErrors :: NonEmpty (ExtractError s a) } deriving Semigroup @@ -298,8 +334,8 @@ -- | @since 1.16 data EvaluateSettings = EvaluateSettings - { _startingContext :: Dhall.Context.Context (Expr Src X) - , _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer X) + { _startingContext :: Dhall.Context.Context (Expr Src Void) + , _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer Void) } -- | Default evaluation settings: no extra entries in the initial @@ -317,11 +353,11 @@ -- @since 1.16 startingContext :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (Dhall.Context.Context (Expr Src X)) + => LensLike' f s (Dhall.Context.Context (Expr Src Void)) startingContext = evaluateSettings . l where l :: (Functor f) - => LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src X)) + => LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src Void)) l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s)) -- | Access the custom normalizer. @@ -329,11 +365,11 @@ -- @since 1.16 normalizer :: (Functor f, HasEvaluateSettings s) - => LensLike' f s (Maybe (Dhall.Core.ReifiedNormalizer X)) + => LensLike' f s (Maybe (Dhall.Core.ReifiedNormalizer Void)) normalizer = evaluateSettings . l where l :: (Functor f) - => LensLike' f EvaluateSettings (Maybe (Dhall.Core.ReifiedNormalizer X)) + => LensLike' f EvaluateSettings (Maybe (Dhall.Core.ReifiedNormalizer Void)) l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s)) -- | @since 1.16 @@ -398,8 +434,8 @@ let EvaluateSettings {..} = _evaluateSettings let transform = - set Dhall.Import.normalizer _normalizer - . set Dhall.Import.startingContext _startingContext + Lens.Family.set Dhall.Import.normalizer _normalizer + . Lens.Family.set Dhall.Import.startingContext _startingContext let status = transform (Dhall.Import.emptyStatus _rootDirectory) @@ -467,7 +503,7 @@ inputExpr :: Text -- ^ The Dhall program - -> IO (Expr Src X) + -> IO (Expr Src Void) -- ^ The fully normalized AST inputExpr = inputExprWithSettings defaultInputSettings @@ -482,7 +518,7 @@ :: InputSettings -> Text -- ^ The Dhall program - -> IO (Expr Src X) + -> IO (Expr Src Void) -- ^ The fully normalized AST inputExprWithSettings settings txt = do expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) @@ -492,8 +528,8 @@ let EvaluateSettings {..} = _evaluateSettings let transform = - set Dhall.Import.normalizer _normalizer - . set Dhall.Import.startingContext _startingContext + Lens.Family.set Dhall.Import.normalizer _normalizer + . Lens.Family.set Dhall.Import.startingContext _startingContext let status = transform (Dhall.Import.emptyStatus _rootDirectory) @@ -512,7 +548,7 @@ :: Alternative f => Type a -- ^ The type of value to decode from Dhall to Haskell - -> Expr s X + -> Expr s Void -- ^ a closed form Dhall program, which evaluates to the expected type -> f a -- ^ The decoded value in Haskell @@ -629,11 +665,11 @@ detailed = Control.Exception.handle handler1 . Control.Exception.handle handler0 where - handler0 :: Imported (TypeError Src X) -> IO a + handler0 :: Imported (TypeError Src Void) -> IO a handler0 (Imported ps e) = Control.Exception.throwIO (Imported ps (DetailedTypeError e)) - handler1 :: TypeError Src X -> IO a + 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 @@ -654,9 +690,9 @@ > input :: Type a -> Text -> IO a -} data Type a = Type - { extract :: Expr Src X -> Extractor Src X a + { extract :: Expr Src Void -> Extractor Src Void a -- ^ Extracts Haskell value from the Dhall expression - , expected :: Expr Src X + , expected :: Expr Src Void -- ^ Dhall type of the Haskell value } deriving (Functor) @@ -716,8 +752,8 @@ double :: Type Double double = Type {..} where - extract (DoubleLit n) = pure n - extract expr = typeError Double expr + extract (DoubleLit (DhallDouble n)) = pure n + extract expr = typeError Double expr expected = Double @@ -727,12 +763,7 @@ "Test" -} lazyText :: Type Data.Text.Lazy.Text -lazyText = Type {..} - where - extract (TextLit (Chunks [] t)) = pure (Data.Text.Lazy.fromStrict t) - extract expr = typeError Text expr - - expected = Text +lazyText = fmap Data.Text.Lazy.fromStrict strictText {-| Decode strict `Text` @@ -740,8 +771,12 @@ "Test" -} strictText :: Type Text -strictText = fmap Data.Text.Lazy.toStrict lazyText +strictText = Type {..} + where + extract (TextLit (Chunks [] t)) = pure t + extract expr = typeError Text expr + expected = Text {-| Decode a `Maybe` >>> input (maybe natural) "Some 1" @@ -785,6 +820,176 @@ vector :: Type a -> Type (Vector a) vector = fmap Data.Vector.fromList . list +{-| Decode a `Set` from a `List` + +>>> input (setIgnoringDuplicates natural) "[1, 2, 3]" +fromList [1,2,3] + +Duplicate elements are ignored. + +>>> input (setIgnoringDuplicates natural) "[1, 1, 3]" +fromList [1,3] + +-} +setIgnoringDuplicates :: (Ord a) => Type a -> Type (Data.Set.Set a) +setIgnoringDuplicates = fmap Data.Set.fromList . list + +{-| Decode a `HashSet` from a `List` + +>>> input (hashSetIgnoringDuplicates natural) "[1, 2, 3]" +fromList [1,2,3] + +Duplicate elements are ignored. + +>>> input (hashSetIgnoringDuplicates natural) "[1, 1, 3]" +fromList [1,3] + +-} +hashSetIgnoringDuplicates :: (Hashable a, Ord a) + => Type a + -> Type (Data.HashSet.HashSet a) +hashSetIgnoringDuplicates = fmap Data.HashSet.fromList . list + +{-| Decode a `Set` from a `List` with distinct elements + +>>> input (setFromDistinctList natural) "[1, 2, 3]" +fromList [1,2,3] + +An error is thrown if the list contains duplicates. + +> >>> input (setFromDistinctList natural) "[1, 1, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> One duplicate element in the list: 1 +> + +> >>> input (setFromDistinctList natural) "[1, 1, 3, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> 2 duplicates were found in the list, including 1 +> + +-} +setFromDistinctList :: (Ord a, Show a) => Type a -> Type (Data.Set.Set a) +setFromDistinctList = setHelper Data.Set.size Data.Set.fromList + +{-| Decode a `HashSet` from a `List` with distinct elements + +>>> input (hashSetFromDistinctList natural) "[1, 2, 3]" +fromList [1,2,3] + +An error is thrown if the list contains duplicates. + +> >>> input (hashSetFromDistinctList natural) "[1, 1, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> One duplicate element in the list: 1 +> + +> >>> input (hashSetFromDistinctList natural) "[1, 1, 3, 3]" +> *** Exception: Error: Failed extraction +> +> The expression type-checked successfully but the transformation to the target +> type failed with the following error: +> +> 2 duplicates were found in the list, including 1 +> + +-} +hashSetFromDistinctList :: (Hashable a, Ord a, Show a) + => Type a + -> Type (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 + where + extractOut (ListLit _ es) = case traverse extractIn es of + Success vSeq + | sameSize -> Success vSet + | otherwise -> extractError err + where + vList = Data.Foldable.toList vSeq + vSet = toSet vList + sameSize = size vSet == Data.Sequence.length vSeq + duplicates = vList Data.List.\\ Data.Foldable.toList vSet + err | length duplicates == 1 = + "One duplicate element in the list: " + <> (Data.Text.pack $ show $ head duplicates) + | otherwise = Data.Text.pack $ unwords + [ show $ length duplicates + , "duplicates were found in the list, including" + , show $ head duplicates + ] + Failure f -> Failure f + extractOut expr = typeError expectedOut expr + + expectedOut = App List expectedIn + +{-| Decode a `Map` from a @toMap@ expression or generally a @Prelude.Map.Type@ + +>>> input (Dhall.map strictText bool) "toMap { a = True, b = False }" +fromList [("a",True),("b",False)] +>>> input (Dhall.map strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]" +fromList [("foo",True)] + +If there are duplicate @mapKey@s, later @mapValue@s take precedence: + +>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" +>>> input (Dhall.map natural bool) expr +fromList [(1,False)] + +-} +map :: Ord k => Type k -> Type v -> Type (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@ + +>>> input (Dhall.hashMap strictText bool) "toMap { a = True, b = False }" +fromList [("a",True),("b",False)] +>>> input (Dhall.hashMap strictText bool) "[ { mapKey = \"foo\", mapValue = True } ]" +fromList [("foo",True)] + +If there are duplicate @mapKey@s, later @mapValue@s take precedence: + +>>> let expr = "[ { mapKey = 1, mapValue = True }, { mapKey = 1, mapValue = False } ]" +>>> input (Dhall.hashMap natural bool) expr +fromList [(1,False)] + +-} +hashMap :: (Eq k, Hashable k) => Type k -> Type v -> Type (HashMap k v) +hashMap k v = fmap HashMap.fromList (list (pairFromMapEntry k v)) + +{-| Decode a tuple from a @Prelude.Map.Entry@ record + +>>> input (pairFromMapEntry strictText natural) "{ mapKey = \"foo\", mapValue = 3 }" +("foo",3) +-} +pairFromMapEntry :: Type k -> Type v -> Type (k, v) +pairFromMapEntry k v = Type extractOut expectedOut + where + extractOut (RecordLit kvs) + | Just key <- Dhall.Map.lookup "mapKey" kvs + , Just value <- Dhall.Map.lookup "mapValue" kvs + = liftA2 (,) (extract k key) (extract v value) + extractOut expr = typeError expectedOut expr + + expectedOut = Record (Dhall.Map.fromList [("mapKey", expected k), ("mapValue", expected v)]) + {-| Decode @()@ from an empty record. >>> input unit "{=}" -- GHC doesn't print the result if it is () @@ -799,6 +1004,13 @@ expectedOut = Record mempty +{-| Decode 'Void' from an empty union. + +Since @<>@ is uninhabited, @'input' 'void'@ will always fail. +-} +void :: Type Void +void = union mempty + {-| Decode a `String` >>> input string "\"ABC\"" @@ -829,59 +1041,91 @@ ] ) -{-| Any value that implements `Interpret` can be automatically decoded based on +{-| Any value that implements `FromDhall` can be automatically decoded based on the inferred return type of `input` >>> input auto "[1, 2, 3]" :: IO (Vector Natural) [1,2,3] +>>> input auto "toMap { a = False, b = True }" :: IO (Map Text Bool) +fromList [("a",False),("b",True)] This class auto-generates a default implementation for records that implement `Generic`. This does not auto-generate an instance for recursive types. -} -class Interpret a where +class FromDhall a where autoWith:: InterpretOptions -> Type a default autoWith - :: (Generic a, GenericInterpret (Rep a)) => InterpretOptions -> Type a + :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Type a autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1) -instance Interpret Bool where +{-| A compatibility alias for `FromDhall` + +This will eventually be removed. +-} +type Interpret = FromDhall + +instance FromDhall Void where + autoWith _ = void + +instance FromDhall () where + autoWith _ = unit + +instance FromDhall Bool where autoWith _ = bool -instance Interpret Natural where +instance FromDhall Natural where autoWith _ = natural -instance Interpret Integer where +instance FromDhall Integer where autoWith _ = integer -instance Interpret Scientific where +instance FromDhall Scientific where autoWith _ = scientific -instance Interpret Double where +instance FromDhall Double where autoWith _ = double -instance {-# OVERLAPS #-} Interpret [Char] where +instance {-# OVERLAPS #-} FromDhall [Char] where autoWith _ = string -instance Interpret Data.Text.Lazy.Text where +instance FromDhall Data.Text.Lazy.Text where autoWith _ = lazyText -instance Interpret Text where +instance FromDhall Text where autoWith _ = strictText -instance Interpret a => Interpret (Maybe a) where +instance FromDhall a => FromDhall (Maybe a) where autoWith opts = maybe (autoWith opts) -instance Interpret a => Interpret (Seq a) where +instance FromDhall a => FromDhall (Seq a) where autoWith opts = sequence (autoWith opts) -instance Interpret a => Interpret [a] where - autoWith = fmap (fmap Data.Vector.toList) autoWith +instance FromDhall a => FromDhall [a] where + autoWith opts = list (autoWith opts) -instance Interpret a => Interpret (Vector a) where +instance FromDhall a => FromDhall (Vector a) where autoWith opts = vector (autoWith opts) -instance (Inject a, Interpret b) => Interpret (a -> b) where +{-| Note that this instance will throw errors in the presence of duplicates in + the list. To ignore duplicates, use `setIgnoringDuplicates`. +-} +instance (FromDhall a, Ord a, Show a) => FromDhall (Data.Set.Set a) where + autoWith opts = setFromDistinctList (autoWith opts) + +{-| Note that this instance will throw errors in the presence of duplicates in + the list. To ignore duplicates, use `hashSetIgnoringDuplicates`. +-} +instance (FromDhall a, Hashable a, Ord a, Show a) => FromDhall (Data.HashSet.HashSet a) where + autoWith opts = hashSetFromDistinctList (autoWith opts) + +instance (Ord k, FromDhall k, FromDhall v) => FromDhall (Map k v) where + autoWith opts = Dhall.map (autoWith opts) (autoWith opts) + +instance (Eq k, Hashable k, FromDhall k, FromDhall v) => FromDhall (HashMap k v) where + 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) @@ -889,7 +1133,7 @@ -- ToDo extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of Success o -> o - Failure _e -> error "Interpret: You cannot decode a function if it does not have the correct type" ) + Failure _e -> error "FromDhall: You cannot decode a function if it does not have the correct type" ) expectedOut = Pi "_" declared expectedIn @@ -897,25 +1141,25 @@ Type extractIn expectedIn = autoWith opts -instance (Interpret a, Interpret b) => Interpret (a, b) +instance (FromDhall a, FromDhall b) => FromDhall (a, b) {-| Use the default options for interpreting a configuration file > auto = autoWith defaultInterpretOptions -} -auto :: Interpret a => Type a +auto :: FromDhall a => Type a auto = autoWith defaultInterpretOptions {-| This type is exactly the same as `Data.Fix.Fix` except with a different - `Interpret` instance. This intermediate type simplies the implementation - of the inner loop for the `Interpret` instance for `Fix` + `FromDhall` instance. This intermediate type simplies the implementation + of the inner loop for the `FromDhall` instance for `Fix` -} newtype Result f = Result { _unResult :: f (Result f) } resultToFix :: Functor f => Result f -> Fix f resultToFix (Result x) = Fix (fmap resultToFix x) -instance Interpret (f (Result f)) => Interpret (Result f) where +instance FromDhall (f (Result f)) => FromDhall (Result f) where autoWith options = Type { expected = expected_, extract = extract_ } where expected_ = "result" @@ -939,30 +1183,30 @@ -- > {-# LANGUAGE StandaloneDeriving #-} -- > {-# LANGUAGE TypeFamilies #-} -- > {-# LANGUAGE TemplateHaskell #-} --- > +-- > -- > import Data.Fix (Fix(..)) -- > import Data.Text (Text) --- > import Dhall (Interpret) +-- > import Dhall (FromDhall) -- > import GHC.Generics (Generic) -- > import Numeric.Natural (Natural) --- > +-- > -- > import qualified Data.Fix as Fix -- > import qualified Data.Functor.Foldable as Foldable -- > import qualified Data.Functor.Foldable.TH as TH -- > import qualified Dhall -- > import qualified NeatInterpolation --- > +-- > -- > data Expr -- > = Lit Natural -- > | Add Expr Expr -- > | Mul Expr Expr -- > deriving (Show) --- > +-- > -- > TH.makeBaseFunctor ''Expr --- > +-- > -- > deriving instance Generic (ExprF a) --- > deriving instance Interpret a => Interpret (ExprF a) --- > +-- > deriving instance FromDhall a => FromDhall (ExprF a) +-- > -- > example :: Text -- > example = [NeatInterpolation.text| -- > \(Expr : Type) @@ -974,32 +1218,32 @@ -- > | MulF : -- > { _1 : Expr, _2 : Expr } -- > > --- > +-- > -- > in \(Fix : ExprF -> Expr) -- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x }) --- > +-- > -- > let Add = -- > \(x : Expr) -- > -> \(y : Expr) -- > -> Fix (ExprF.AddF { _1 = x, _2 = y }) --- > +-- > -- > let Mul = -- > \(x : Expr) -- > -> \(y : Expr) -- > -> Fix (ExprF.MulF { _1 = x, _2 = y }) --- > +-- > -- > in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2)) -- > |] --- > +-- > -- > convert :: Fix ExprF -> Expr -- > convert = Fix.cata Foldable.embed --- > +-- > -- > main :: IO () -- > main = do -- > x <- Dhall.input Dhall.auto example :: IO (Fix ExprF) --- > +-- > -- > print (convert x :: Expr) -instance (Functor f, Interpret (f (Result f))) => Interpret (Fix f) where +instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where autoWith options = Type { expected = expected_, extract = extract_ } where expected_ = @@ -1015,15 +1259,15 @@ go0 _ = typeError expected_ expression0 {-| `genericAuto` is the default implementation for `auto` if you derive - `Interpret`. The difference is that you can use `genericAuto` without - having to explicitly provide an `Interpret` instance for a type as long as + `FromDhall`. The difference is that you can use `genericAuto` without + having to explicitly provide a `FromDhall` instance for a type as long as the type derives `Generic` -} -genericAuto :: (Generic a, GenericInterpret (Rep a)) => Type a +genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Type a genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1) {-| Use these options to tweak how Dhall derives a generic implementation of - `Interpret` + `FromDhall` -} data InterpretOptions = InterpretOptions { fieldModifier :: Text -> Text @@ -1036,8 +1280,8 @@ -- ^ Specify how to handle constructors with only one field. The default is -- `Wrapped` for backwards compatibility but will eventually be changed to -- `Smart` - , inputNormalizer :: Dhall.Core.ReifiedNormalizer X - -- ^ This is only used by the `Interpret` instance for functions in order + , inputNormalizer :: Dhall.Core.ReifiedNormalizer Void + -- ^ This is only used by the `FromDhall` instance for functions in order -- to normalize the function input before marshaling the input into a -- Dhall expression } @@ -1082,18 +1326,18 @@ Dhall.Core.ReifiedNormalizer (const (pure Nothing)) } -{-| This is the underlying class that powers the `Interpret` class's support +{-| This is the underlying class that powers the `FromDhall` class's support for automatically deriving a generic implementation -} -class GenericInterpret f where +class GenericFromDhall f where genericAutoWith :: InterpretOptions -> State Int (Type (f a)) -instance GenericInterpret f => GenericInterpret (M1 D d f) where +instance GenericFromDhall f => GenericFromDhall (M1 D d f) where genericAutoWith options = do res <- genericAutoWith options pure (fmap M1 res) -instance GenericInterpret V1 where +instance GenericFromDhall V1 where genericAutoWith _ = pure Type {..} where extract expr = typeError expected expr @@ -1101,14 +1345,15 @@ expected = Union mempty unsafeExpectUnion - :: Text -> Expr Src X -> Dhall.Map.Map Text (Maybe (Expr Src X)) + :: Text -> Expr Src Void -> Dhall.Map.Map Text (Maybe (Expr Src Void)) unsafeExpectUnion _ (Union kts) = kts unsafeExpectUnion name expression = Dhall.Core.internalError (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) -unsafeExpectRecord :: Text -> Expr Src X -> Dhall.Map.Map Text (Expr Src X) +unsafeExpectRecord + :: Text -> Expr Src Void -> Dhall.Map.Map Text (Expr Src Void) unsafeExpectRecord _ (Record kts) = kts unsafeExpectRecord name expression = @@ -1117,8 +1362,8 @@ unsafeExpectUnionLit :: Text - -> Expr Src X - -> (Text, Maybe (Expr Src X)) + -> Expr Src Void + -> (Text, Maybe (Expr Src Void)) unsafeExpectUnionLit _ (Field (Union _) k) = (k, Nothing) unsafeExpectUnionLit _ (App (Field (Union _) k) v) = @@ -1127,7 +1372,8 @@ Dhall.Core.internalError (name <> ": Unexpected constructor: " <> Dhall.Core.pretty expression) -unsafeExpectRecordLit :: Text -> Expr Src X -> Dhall.Map.Map Text (Expr Src X) +unsafeExpectRecordLit + :: Text -> Expr Src Void -> Dhall.Map.Map Text (Expr Src Void) unsafeExpectRecordLit _ (RecordLit kvs) = kvs unsafeExpectRecordLit name expression = @@ -1152,7 +1398,7 @@ extractUnionConstructor _ = empty -instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where +instance (Constructor c1, Constructor c2, GenericFromDhall f1, GenericFromDhall f2) => GenericFromDhall (M1 C c1 f1 :+: M1 C c2 f2) where genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) where nL :: M1 i c1 f1 a @@ -1184,7 +1430,7 @@ Type extractL expectedL = evalState (genericAutoWith options) 1 Type extractR expectedR = evalState (genericAutoWith options) 1 -instance (Constructor c, GenericInterpret (f :+: g), GenericInterpret h) => GenericInterpret ((f :+: g) :+: M1 C c h) where +instance (Constructor c, GenericFromDhall (f :+: g), GenericFromDhall h) => GenericFromDhall ((f :+: g) :+: M1 C c h) where genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) where n :: M1 i c h a @@ -1207,7 +1453,7 @@ ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL -instance (Constructor c, GenericInterpret f, GenericInterpret (g :+: h)) => GenericInterpret (M1 C c f :+: (g :+: h)) where +instance (Constructor c, GenericFromDhall f, GenericFromDhall (g :+: h)) => GenericFromDhall (M1 C c f :+: (g :+: h)) where genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) where n :: M1 i c f a @@ -1230,7 +1476,7 @@ ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR -instance (GenericInterpret (f :+: g), GenericInterpret (h :+: i)) => GenericInterpret ((f :+: g) :+: (h :+: i)) where +instance (GenericFromDhall (f :+: g), GenericFromDhall (h :+: i)) => GenericFromDhall ((f :+: g) :+: (h :+: i)) where genericAutoWith options = pure (Type {..}) where extract e = fmap L1 (extractL e) `ealt` fmap R1 (extractR e) @@ -1243,12 +1489,12 @@ ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR -instance GenericInterpret f => GenericInterpret (M1 C c f) where +instance GenericFromDhall f => GenericFromDhall (M1 C c f) where genericAutoWith options = do res <- genericAutoWith options pure (fmap M1 res) -instance GenericInterpret U1 where +instance GenericFromDhall U1 where genericAutoWith _ = pure (Type {..}) where extract _ = pure U1 @@ -1262,7 +1508,7 @@ pure (Data.Text.pack ("_" ++ show i)) nn -> pure (Data.Text.pack nn) -instance (GenericInterpret (f :*: g), GenericInterpret (h :*: i)) => GenericInterpret ((f :*: g) :*: (h :*: i)) where +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 @@ -1277,7 +1523,7 @@ return (Type {..}) -instance (GenericInterpret (f :*: g), Selector s, Interpret a) => GenericInterpret ((f :*: g) :*: M1 S s (K1 i a)) where +instance (GenericFromDhall (f :*: g), Selector s, FromDhall a) => GenericFromDhall ((f :*: g) :*: M1 S s (K1 i a)) where genericAutoWith options@InterpretOptions{..} = do let nR :: M1 S s (K1 i a) r nR = undefined @@ -1307,7 +1553,7 @@ return (Type {..}) -instance (Selector s, Interpret a, GenericInterpret (f :*: g)) => GenericInterpret (M1 S s (K1 i a) :*: (f :*: g)) where +instance (Selector s, FromDhall a, GenericFromDhall (f :*: g)) => GenericFromDhall (M1 S s (K1 i a) :*: (f :*: g)) where genericAutoWith options@InterpretOptions{..} = do let nL :: M1 S s (K1 i a) r nL = undefined @@ -1337,7 +1583,7 @@ return (Type {..}) -instance (Selector s1, Selector s2, Interpret a1, Interpret a2) => GenericInterpret (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where +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 let nL :: M1 S s1 (K1 i1 a1) r nL = undefined @@ -1374,7 +1620,7 @@ return (Type {..}) -instance (Selector s, Interpret a) => GenericInterpret (M1 S s (K1 i a)) where +instance (Selector s, FromDhall a) => GenericFromDhall (M1 S s (K1 i a)) where genericAutoWith options@InterpretOptions{..} = do let n :: M1 S s (K1 i a) r n = undefined @@ -1420,9 +1666,9 @@ Haskell into Dhall -} data InputType a = InputType - { embed :: a -> Expr Src X + { embed :: a -> Expr Src Void -- ^ Embeds a Haskell value as a Dhall expression - , declared :: Expr Src X + , declared :: Expr Src Void -- ^ Dhall type of the Haskell value } @@ -1431,53 +1677,66 @@ where embed' x = embed (f x) -{-| This class is used by `Interpret` instance for functions: +{-| This class is used by `FromDhall` instance for functions: -> instance (Inject a, Interpret b) => Interpret (a -> b) +> instance (ToDhall a, FromDhall b) => FromDhall (a -> b) You can convert Dhall functions with "simple" inputs (i.e. instances of this class) into Haskell functions. This works by: * Marshaling the input to the Haskell function into a Dhall expression (i.e. - @x :: Expr Src X@) - * Applying the Dhall function (i.e. @f :: Expr Src X@) to the Dhall input + @x :: Expr Src Void@) + * Applying the Dhall function (i.e. @f :: Expr Src Void@) to the Dhall input (i.e. @App f x@) * Normalizing the syntax tree (i.e. @normalize (App f x)@) * Marshaling the resulting Dhall expression back into a Haskell value -} -class Inject a where +class ToDhall a where injectWith :: InterpretOptions -> InputType a default injectWith - :: (Generic a, GenericInject (Rep a)) => InterpretOptions -> InputType a + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputType a injectWith options - = contramap GHC.Generics.from (evalState (genericInjectWith options) 1) + = contramap GHC.Generics.from (evalState (genericToDhallWith options) 1) +{-| A compatibility alias for `ToDhall` + +This will eventually be removed. +-} +type Inject = ToDhall + {-| Use the default options for injecting a value -> inject = inject defaultInterpretOptions +> inject = injectWith defaultInterpretOptions -} -inject :: Inject a => InputType a +inject :: ToDhall a => InputType a inject = injectWith defaultInterpretOptions {-| Use the default options for injecting a value, whose structure is determined generically. -This can be used when you want to use 'Inject' on types that you don't +This can be used when you want to use 'ToDhall' on types that you don't want to define orphan instances for. -} -genericInject - :: (Generic a, GenericInject (Rep a)) => InputType a -genericInject - = contramap GHC.Generics.from (evalState (genericInjectWith defaultInterpretOptions) 1) +genericToDhall + :: (Generic a, GenericToDhall (Rep a)) => InputType a +genericToDhall + = contramap GHC.Generics.from (evalState (genericToDhallWith defaultInterpretOptions) 1) -instance Inject Bool where +instance ToDhall Void where injectWith _ = InputType {..} where + embed = Data.Void.absurd + + declared = Union mempty + +instance ToDhall Bool where + injectWith _ = InputType {..} + where embed = BoolLit declared = Bool -instance Inject Data.Text.Lazy.Text where +instance ToDhall Data.Text.Lazy.Text where injectWith _ = InputType {..} where embed text = @@ -1485,85 +1744,122 @@ declared = Text -instance Inject Text where +instance ToDhall Text where injectWith _ = InputType {..} where embed text = TextLit (Chunks [] text) declared = Text -instance {-# OVERLAPS #-} Inject String where +instance {-# OVERLAPS #-} ToDhall String where injectWith options = contramap Data.Text.pack (injectWith options :: InputType Text) -instance Inject Natural where +instance ToDhall Natural where injectWith _ = InputType {..} where embed = NaturalLit declared = Natural -instance Inject Integer where +instance ToDhall Integer where injectWith _ = InputType {..} where embed = IntegerLit declared = Integer -instance Inject Int where +instance ToDhall Int where injectWith _ = InputType {..} where embed = IntegerLit . toInteger declared = Integer -instance Inject Word8 where +{-| + +>>> embed inject (12 :: Word) +NaturalLit 12 +-} + +instance ToDhall Word where injectWith _ = InputType {..} where - embed = IntegerLit . toInteger + embed = NaturalLit . fromIntegral - declared = Integer + declared = Natural -instance Inject Word16 where +{-| + +>>> embed inject (12 :: Word8) +NaturalLit 12 +-} + +instance ToDhall Word8 where injectWith _ = InputType {..} where - embed = IntegerLit . toInteger + embed = NaturalLit . fromIntegral - declared = Integer + declared = Natural -instance Inject Word32 where +{-| + +>>> embed inject (12 :: Word16) +NaturalLit 12 +-} + +instance ToDhall Word16 where injectWith _ = InputType {..} where - embed = IntegerLit . toInteger + embed = NaturalLit . fromIntegral - declared = Integer + declared = Natural -instance Inject Word64 where +{-| + +>>> embed inject (12 :: Word32) +NaturalLit 12 +-} + +instance ToDhall Word32 where injectWith _ = InputType {..} where - embed = IntegerLit . toInteger + embed = NaturalLit . fromIntegral - declared = Integer + declared = Natural -instance Inject Double where +{-| + +>>> embed inject (12 :: Word64) +NaturalLit 12 +-} + +instance ToDhall Word64 where injectWith _ = InputType {..} where - embed = DoubleLit + embed = NaturalLit . fromIntegral + declared = Natural + +instance ToDhall Double where + injectWith _ = InputType {..} + where + embed = DoubleLit . DhallDouble + declared = Double -instance Inject Scientific where +instance ToDhall Scientific where injectWith options = contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double) -instance Inject () where +instance ToDhall () where injectWith _ = InputType {..} where embed = const (RecordLit mempty) declared = Record mempty -instance Inject a => Inject (Maybe a) where +instance ToDhall a => ToDhall (Maybe a) where injectWith options = InputType embedOut declaredOut where embedOut (Just x ) = Some (embedIn x) @@ -1573,7 +1869,7 @@ declaredOut = App Optional declaredIn -instance Inject a => Inject (Seq a) where +instance ToDhall a => ToDhall (Seq a) where injectWith options = InputType embedOut declaredOut where embedOut xs = ListLit listType (fmap embedIn xs) @@ -1586,35 +1882,108 @@ InputType embedIn declaredIn = injectWith options -instance Inject a => Inject [a] where +instance ToDhall a => ToDhall [a] where injectWith = fmap (contramap Data.Sequence.fromList) injectWith -instance Inject a => Inject (Vector a) where +instance ToDhall a => ToDhall (Vector a) where injectWith = fmap (contramap Data.Vector.toList) injectWith -instance Inject a => Inject (Data.Set.Set a) where - injectWith = fmap (contramap Data.Set.toList) injectWith +{-| Note that the ouput list will be sorted -instance (Inject a, Inject b) => Inject (a, b) +>>> let x = Data.Set.fromList ["mom", "hi" :: Text] +>>> prettyExpr $ embed inject x +[ "hi", "mom" ] -{-| This is the underlying class that powers the `Interpret` class's support +-} +instance ToDhall a => ToDhall (Data.Set.Set a) where + injectWith = fmap (contramap Data.Set.toAscList) injectWith + +{-| Note that the ouput list may not be sorted + +>>> let x = Data.HashSet.fromList ["hi", "mom" :: Text] +>>> prettyExpr $ embed inject x +[ "mom", "hi" ] + +-} +instance ToDhall a => ToDhall (Data.HashSet.HashSet a) where + injectWith = fmap (contramap Data.HashSet.toList) injectWith + +instance (ToDhall a, ToDhall b) => ToDhall (a, b) + +{-| Embed a `Data.Map` as a @Prelude.Map.Type@ + +>>> prettyExpr $ embed inject (Data.Map.fromList [(1 :: Natural, True)]) +[ { mapKey = 1, mapValue = True } ] + +>>> prettyExpr $ embed inject (Data.Map.fromList [] :: Data.Map.Map Natural Bool) +[] : List { mapKey : Natural, mapValue : Bool } + +-} +instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where + injectWith options = InputType embedOut declaredOut + where + embedOut m = ListLit listType (mapEntries m) + where + listType + | Data.Map.null m = Just declaredOut + | otherwise = Nothing + + declaredOut = App List (Record (Dhall.Map.fromList + [("mapKey", declaredK), ("mapValue", declaredV)])) + + mapEntries = Data.Sequence.fromList . fmap recordPair . Data.Map.toList + recordPair (k, v) = RecordLit (Dhall.Map.fromList + [("mapKey", embedK k), ("mapValue", embedV v)]) + + InputType embedK declaredK = injectWith options + InputType embedV declaredV = injectWith options + +{-| Embed a `Data.HashMap` as a @Prelude.Map.Type@ + +>>> prettyExpr $ embed inject (HashMap.fromList [(1 :: Natural, True)]) +[ { mapKey = 1, mapValue = True } ] + +>>> prettyExpr $ embed inject (HashMap.fromList [] :: HashMap Natural Bool) +[] : List { mapKey : Natural, mapValue : Bool } + +-} +instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where + injectWith options = InputType embedOut declaredOut + where + embedOut m = ListLit listType (mapEntries m) + where + listType + | HashMap.null m = Just declaredOut + | otherwise = Nothing + + declaredOut = App List (Record (Dhall.Map.fromList + [("mapKey", declaredK), ("mapValue", declaredV)])) + + mapEntries = Data.Sequence.fromList . fmap recordPair . HashMap.toList + recordPair (k, v) = RecordLit (Dhall.Map.fromList + [("mapKey", embedK k), ("mapValue", embedV v)]) + + InputType embedK declaredK = injectWith options + InputType embedV declaredV = injectWith options + +{-| This is the underlying class that powers the `FromDhall` class's support for automatically deriving a generic implementation -} -class GenericInject f where - genericInjectWith :: InterpretOptions -> State Int (InputType (f a)) +class GenericToDhall f where + genericToDhallWith :: InterpretOptions -> State Int (InputType (f a)) -instance GenericInject f => GenericInject (M1 D d f) where - genericInjectWith options = do - res <- genericInjectWith options +instance GenericToDhall f => GenericToDhall (M1 D d f) where + genericToDhallWith options = do + res <- genericToDhallWith options pure (contramap unM1 res) -instance GenericInject f => GenericInject (M1 C c f) where - genericInjectWith options = do - res <- genericInjectWith options +instance GenericToDhall f => GenericToDhall (M1 C c f) where + genericToDhallWith options = do + res <- genericToDhallWith options pure (contramap unM1 res) -instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where - genericInjectWith options@InterpretOptions{..} = do +instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where + genericToDhallWith options@InterpretOptions{..} = do let InputType { embed = embed', declared = declared' } = injectWith options @@ -1645,8 +2014,8 @@ return (InputType {..}) -instance (Constructor c1, Constructor c2, GenericInject f1, GenericInject f2) => GenericInject (M1 C c1 f1 :+: M1 C c2 f2) where - genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) +instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where + genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -1679,11 +2048,11 @@ keyL = constructorModifier (Data.Text.pack (conName nL)) keyR = constructorModifier (Data.Text.pack (conName nR)) - InputType embedL declaredL = evalState (genericInjectWith options) 1 - InputType embedR declaredR = evalState (genericInjectWith options) 1 + InputType embedL declaredL = evalState (genericToDhallWith options) 1 + InputType embedR declaredR = evalState (genericToDhallWith options) 1 -instance (Constructor c, GenericInject (f :+: g), GenericInject h) => GenericInject ((f :+: g) :+: M1 C c h) where - genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) +instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where + genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 l) = case maybeValL of @@ -1691,7 +2060,7 @@ Just valL -> App (Field declared keyL) valL where (keyL, maybeValL) = - unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l) + unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedL l) embed (R1 (M1 r)) = case notEmptyRecordLit (embedR r) of Nothing -> Field declared keyR @@ -1704,13 +2073,13 @@ declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) - InputType embedL declaredL = evalState (genericInjectWith options) 1 - InputType embedR declaredR = evalState (genericInjectWith options) 1 + InputType embedL declaredL = evalState (genericToDhallWith options) 1 + InputType embedR declaredR = evalState (genericToDhallWith options) 1 - ktsL = unsafeExpectUnion "genericInjectWith (:+:)" declaredL + ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL -instance (Constructor c, GenericInject f, GenericInject (g :+: h)) => GenericInject (M1 C c f :+: (g :+: h)) where - genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) +instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where + genericToDhallWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -1722,7 +2091,7 @@ Just valR -> App (Field declared keyR) valR where (keyR, maybeValR) = - unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r) + unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedR r) nL :: M1 i c f a nL = undefined @@ -1731,13 +2100,13 @@ declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) - InputType embedL declaredL = evalState (genericInjectWith options) 1 - InputType embedR declaredR = evalState (genericInjectWith options) 1 + InputType embedL declaredL = evalState (genericToDhallWith options) 1 + InputType embedR declaredR = evalState (genericToDhallWith options) 1 - ktsR = unsafeExpectUnion "genericInjectWith (:+:)" declaredR + ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR -instance (GenericInject (f :+: g), GenericInject (h :+: i)) => GenericInject ((f :+: g) :+: (h :+: i)) where - genericInjectWith options = pure (InputType {..}) +instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where + genericToDhallWith options = pure (InputType {..}) where embed (L1 l) = case maybeValL of @@ -1745,52 +2114,52 @@ Just valL -> App (Field declared keyL) valL where (keyL, maybeValL) = - unsafeExpectUnionLit "genericInjectWith (:+:)" (embedL l) + unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedL l) embed (R1 r) = case maybeValR of Nothing -> Field declared keyR Just valR -> App (Field declared keyR) valR where (keyR, maybeValR) = - unsafeExpectUnionLit "genericInjectWith (:+:)" (embedR r) + unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedR r) declared = Union (Dhall.Map.union ktsL ktsR) - InputType embedL declaredL = evalState (genericInjectWith options) 1 - InputType embedR declaredR = evalState (genericInjectWith options) 1 + InputType embedL declaredL = evalState (genericToDhallWith options) 1 + InputType embedR declaredR = evalState (genericToDhallWith options) 1 - ktsL = unsafeExpectUnion "genericInjectWith (:+:)" declaredL - ktsR = unsafeExpectUnion "genericInjectWith (:+:)" declaredR + ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL + ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR -instance (GenericInject (f :*: g), GenericInject (h :*: i)) => GenericInject ((f :*: g) :*: (h :*: i)) where - genericInjectWith options = do - InputType embedL declaredL <- genericInjectWith options - InputType embedR declaredR <- genericInjectWith options +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 let embed (l :*: r) = RecordLit (Dhall.Map.union mapL mapR) where mapL = - unsafeExpectRecordLit "genericInjectWith (:*:)" (embedL l) + unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l) mapR = - unsafeExpectRecordLit "genericInjectWith (:*:)" (embedR r) + unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r) let declared = Record (Dhall.Map.union mapL mapR) where - mapL = unsafeExpectRecord "genericInjectWith (:*:)" declaredL - mapR = unsafeExpectRecord "genericInjectWith (:*:)" declaredR + mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL + mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR pure (InputType {..}) -instance (GenericInject (f :*: g), Selector s, Inject a) => GenericInject ((f :*: g) :*: M1 S s (K1 i a)) where - genericInjectWith options@InterpretOptions{..} = do +instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where + genericToDhallWith options@InterpretOptions{..} = do let nR :: M1 S s (K1 i a) r nR = undefined nameR <- fmap fieldModifier (getSelName nR) - InputType embedL declaredL <- genericInjectWith options + InputType embedL declaredL <- genericToDhallWith options let InputType embedR declaredR = injectWith options @@ -1798,16 +2167,16 @@ RecordLit (Dhall.Map.insert nameR (embedR r) mapL) where mapL = - unsafeExpectRecordLit "genericInjectWith (:*:)" (embedL l) + unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l) let declared = Record (Dhall.Map.insert nameR declaredR mapL) where - mapL = unsafeExpectRecord "genericInjectWith (:*:)" declaredL + mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL return (InputType {..}) -instance (Selector s, Inject a, GenericInject (f :*: g)) => GenericInject (M1 S s (K1 i a) :*: (f :*: g)) where - genericInjectWith options@InterpretOptions{..} = do +instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where + genericToDhallWith options@InterpretOptions{..} = do let nL :: M1 S s (K1 i a) r nL = undefined @@ -1815,22 +2184,22 @@ let InputType embedL declaredL = injectWith options - InputType embedR declaredR <- genericInjectWith options + InputType embedR declaredR <- genericToDhallWith options let embed (M1 (K1 l) :*: r) = RecordLit (Dhall.Map.insert nameL (embedL l) mapR) where mapR = - unsafeExpectRecordLit "genericInjectWith (:*:)" (embedR r) + unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r) let declared = Record (Dhall.Map.insert nameL declaredL mapR) where - mapR = unsafeExpectRecord "genericInjectWith (:*:)" declaredR + mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR return (InputType {..}) -instance (Selector s1, Selector s2, Inject a1, Inject a2) => GenericInject (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericInjectWith options@InterpretOptions{..} = do +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 let nL :: M1 S s1 (K1 i1 a1) r nL = undefined @@ -1857,8 +2226,8 @@ return (InputType {..}) -instance GenericInject U1 where - genericInjectWith _ = pure (InputType {..}) +instance GenericToDhall U1 where + genericToDhallWith _ = pure (InputType {..}) where embed _ = RecordLit mempty @@ -1909,12 +2278,12 @@ ( Control.Applicative.Const ( Dhall.Map.Map Text - ( Expr Src X ) + ( Expr Src Void ) ) ) ( Data.Functor.Compose.Compose - ( (->) ( Expr Src X ) ) - (Extractor Src X) + ( (->) ( Expr Src Void ) ) + (Extractor Src Void) ) a ) @@ -2062,7 +2431,7 @@ adapt (Project{..}) = (projectName, (projectDescription, projectStars)) :} - Or, since we are simply using the `Inject` instance to inject each field, we could write + Or, since we are simply using the `ToDhall` instance to inject each field, we could write >>> :{ injectProject :: InputType Project @@ -2084,6 +2453,7 @@ infixr 5 >*< +-- | Intermediate type used for building a `ToDhall` instance for a record newtype RecordInputType a = RecordInputType (Dhall.Map.Map Text (InputType a)) @@ -2098,12 +2468,19 @@ ((contramap $ snd . f) <$> cInputTypeRecord) conquer = RecordInputType mempty +{-| Specify how to encode one field of a record by supplying an explicit + `InputType` for that field +-} inputFieldWith :: Text -> InputType a -> RecordInputType a inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType -inputField :: Inject a => Text -> RecordInputType a +{-| 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 +-- | Convert a `RecordInputType` into the equivalent `InputType` inputRecord :: RecordInputType a -> InputType a inputRecord (RecordInputType inputTypeRecord) = InputType makeRecordLit recordType where @@ -2146,7 +2523,7 @@ adapt (Errored e) = Right (Right e) :} - Or, since we are simply using the `Inject` instance to inject each branch, we could write + Or, since we are simply using the `ToDhall` instance to inject each branch, we could write >>> :{ injectStatus :: InputType Status @@ -2168,10 +2545,10 @@ ( Control.Applicative.Const ( Dhall.Map.Map Text - ( Expr Src X ) + ( Expr Src Void ) ) ) - ( Op (Text, Expr Src X) ) + ( Op (Text, Expr Src Void) ) a ) deriving (Contravariant) @@ -2193,6 +2570,7 @@ 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 @@ -2207,6 +2585,9 @@ where fields' = fmap notEmptyRecord fields +{-| Specify how to encode an alternative by providing an explicit `InputType` + for that alternative +-} inputConstructorWith :: Text -> InputType a @@ -2222,8 +2603,11 @@ ( Op ( (name,) . embed inputType ) ) +{-| Specify how to encode an alternative by using the default `ToDhall` instance + for that type +-} inputConstructor - :: Inject a + :: ToDhall a => Text -> UnionInputType a inputConstructor name = inputConstructorWith name inject diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -31,6 +31,7 @@ , Chunks(..) , Const(..) , Directory(..) + , DhallDouble(..) , Expr(..) , File(..) , FilePrefix(..) @@ -59,7 +60,11 @@ import qualified Dhall.Map import qualified Dhall.Set --- | Supported version strings +{-| 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 @@ -75,6 +80,7 @@ -- ^ 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" @@ -263,6 +269,11 @@ 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₁) @@ -343,18 +354,8 @@ TList [ TInt 15, TInteger (fromIntegral n) ] encode (IntegerLit n) = TList [ TInt 16, TInteger n ] - encode (DoubleLit n64) - -- cborg always encodes NaN as "7e00" - | isNaN n64 = THalf n32 - | useHalf = THalf n32 - | useFloat = TFloat n32 - | otherwise = TDouble n64 - where - n32 = double2Float n64 - useFloat = n64 == float2Double n32 - -- the other three cases for Half-floats are 0.0 and the infinities - useHalf = or $ fmap (n64 ==) [0.0, infinity, -infinity] - infinity = 1/0 :: Double + encode (DoubleLit d) = + encode d encode (TextLit (Chunks xys₀ z₀)) = TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ]) where @@ -472,6 +473,19 @@ 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 @@ -593,6 +607,7 @@ 10 -> return CombineTypes 11 -> return ImportAlt 12 -> return Equivalent + 13 -> return RecordCompletion _ -> empty return (op l₀ r₀) decode (TList [ TInt 4, _T₁ ]) = do @@ -693,11 +708,11 @@ decode (TList [ TInt 16, TInteger n ]) = do return (IntegerLit n) decode (THalf n) = do - return (DoubleLit (float2Double n)) + return (DoubleLit (DhallDouble (float2Double n))) decode (TFloat n) = do - return (DoubleLit (float2Double n)) + return (DoubleLit (DhallDouble (float2Double n))) decode (TDouble n) = do - return (DoubleLit n) + return (DoubleLit (DhallDouble n)) decode (TList (TInt 18 : xs)) = do let process (TString x : y₁ : zs) = do y₀ <- decode y₁ @@ -932,6 +947,9 @@ decode taggedTerm +{-| This indicates that a given CBOR expression did not correspond to a valid + Dhall expression +-} data DecodingFailure = CBORIsNotDhall Term deriving (Eq) diff --git a/src/Dhall/Binary.hs-boot b/src/Dhall/Binary.hs-boot deleted file mode 100644 --- a/src/Dhall/Binary.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module Dhall.Binary where - -import Codec.CBOR.Term (Term) - -import {-# SOURCE #-} Dhall.Core - -class ToTerm a where - encode :: a -> Term - -instance ToTerm a => ToTerm (Expr s a) diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -1,2390 +1,1384 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# OPTIONS_GHC -Wall #-} - -{-| 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(..) - , Var(..) - , Chunks(..) - , Expr(..) - - -- * Normalization - , Eval.alphaNormalize - , Eval.normalize - , normalizeWith - , normalizeWithM - , Normalizer - , NormalizerM - , ReifiedNormalizer (..) - , Eval.judgmentallyEqual - , subst - , shift - , isNormalized - , isNormalizedWith - , denote - , renote - , shallowDenote - , freeIn - - -- * Pretty-printing - , pretty - - -- * Optics - , subExpressions - , chunkExprs - , bindingExprs - - -- * Let-blocks - , multiLet - , wrapInLets - , MultiLet(..) - , Binding(..) - , makeBinding - - -- * Miscellaneous - , internalError - , reservedIdentifiers - , escapeText - , pathCharacter - , throws - , textShow - , censorExpression - , censorText - ) where - -import Control.Applicative (empty) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bifunctor (Bifunctor(..)) -import Data.Data (Data) -import Data.Foldable -import Data.Functor.Identity (Identity(..)) -import Data.HashSet (HashSet) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.String (IsString(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq, ViewL(..), ViewR(..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Data.Traversable -import Data.Void (Void) -import Dhall.Map (Map) -import Dhall.Set (Set) -import Dhall.Src (Src(..)) -import {-# SOURCE #-} Dhall.Pretty.Internal -import GHC.Generics (Generic) -import Instances.TH.Lift () -import Language.Haskell.TH.Syntax (Lift) -import Lens.Family (over) -import Numeric.Natural (Natural) -import Prelude hiding (succ) -import Unsafe.Coerce (unsafeCoerce) - -import qualified Control.Exception -import qualified Control.Monad -import qualified Data.Char -import {-# SOURCE #-} qualified Dhall.Eval as Eval -import qualified Data.HashSet -import qualified Data.List.NonEmpty -import qualified Data.Sequence -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Dhall.Crypto -import qualified Dhall.Map -import qualified Dhall.Set -import qualified Network.URI as URI -import qualified Text.Printf - - -{-| Constants for a pure type system - - The axioms are: - -> ⊦ Type : Kind -> ⊦ Kind : Sort - - ... and the valid rule pairs are: - -> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) -> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) -> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms -> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) -> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) -> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) - - Note that Dhall does not support functions from terms to types and therefore - Dhall is not a dependently typed language --} -data Const = Type | Kind | Sort - deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, NFData) - -instance Lift Const - -instance Pretty Const where - pretty = Pretty.unAnnotate . prettyConst - -{-| Internal representation of a directory that stores the path components in - reverse order - - In other words, the directory @\/foo\/bar\/baz@ is encoded as - @Directory { components = [ "baz", "bar", "foo" ] }@ --} -newtype Directory = Directory { components :: [Text] } - deriving (Eq, Generic, Ord, Show, NFData) - -instance Semigroup Directory where - Directory components₀ <> Directory components₁ = - Directory (components₁ <> components₀) - -instance Pretty Directory where - pretty (Directory {..}) = foldMap prettyPathComponent (reverse components) - -{-| A `File` is a `directory` followed by one additional path component - representing the `file` name --} -data File = File - { directory :: Directory - , file :: Text - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty File where - pretty (File {..}) = - Pretty.pretty directory - <> prettyPathComponent file - -instance Semigroup File where - File directory₀ _ <> File directory₁ file = - File (directory₀ <> directory₁) file - --- | The beginning of a file path which anchors subsequent path components -data FilePrefix - = Absolute - -- ^ Absolute path - | Here - -- ^ Path relative to @.@ - | Parent - -- ^ Path relative to @..@ - | Home - -- ^ Path relative to @~@ - deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty FilePrefix where - pretty Absolute = "" - pretty Here = "." - pretty Parent = ".." - pretty Home = "~" - -data Scheme = HTTP | HTTPS deriving (Eq, Generic, Ord, Show, NFData) - -data URL = URL - { scheme :: Scheme - , authority :: Text - , path :: File - , query :: Maybe Text - , headers :: Maybe (Expr Src Import) - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Pretty URL where - pretty (URL {..}) = - schemeDoc - <> "://" - <> Pretty.pretty authority - <> pathDoc - <> queryDoc - <> foldMap prettyHeaders headers - where - prettyHeaders h = " using " <> Pretty.pretty h - - File {..} = path - - Directory {..} = directory - - pathDoc = - foldMap prettyURIComponent (reverse components) - <> prettyURIComponent file - - schemeDoc = case scheme of - HTTP -> "http" - HTTPS -> "https" - - queryDoc = case query of - Nothing -> "" - Just q -> "?" <> Pretty.pretty q - --- | The type of import (i.e. local vs. remote vs. environment) -data ImportType - = Local FilePrefix File - -- ^ Local path - | Remote URL - -- ^ URL of remote resource and optional headers stored in an import - | Env Text - -- ^ Environment variable - | Missing - deriving (Eq, Generic, Ord, Show, NFData) - -parent :: File -parent = File { directory = Directory { components = [ ".." ] }, file = "" } - -instance Semigroup ImportType where - Local prefix file₀ <> Local Here file₁ = Local prefix (file₀ <> file₁) - - Remote (URL { path = path₀, ..}) <> Local Here path₁ = - Remote (URL { path = path₀ <> path₁, ..}) - - Local prefix file₀ <> Local Parent file₁ = - Local prefix (file₀ <> parent <> file₁) - - Remote (URL { path = path₀, .. }) <> Local Parent path₁ = - Remote (URL { path = path₀ <> parent <> path₁, .. }) - - import₀ <> Remote (URL { headers = headers₀, .. }) = - Remote (URL { headers = headers₁, .. }) - where - importHashed₀ = Import (ImportHashed Nothing import₀) Code - - headers₁ = fmap (fmap (importHashed₀ <>)) headers₀ - - _ <> import₁ = - import₁ - -instance Pretty ImportType where - pretty (Local prefix file) = - Pretty.pretty prefix <> Pretty.pretty file - - pretty (Remote url) = Pretty.pretty url - - pretty (Env env) = "env:" <> Pretty.pretty env - - pretty Missing = "missing" - --- | How to interpret the import's contents (i.e. as Dhall code or raw text) -data ImportMode = Code | RawText | Location - deriving (Eq, Generic, Ord, Show, NFData) - --- | A `ImportType` extended with an optional hash for semantic integrity checks -data ImportHashed = ImportHashed - { hash :: Maybe Dhall.Crypto.SHA256Digest - , importType :: ImportType - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Semigroup ImportHashed where - ImportHashed _ importType₀ <> ImportHashed hash importType₁ = - ImportHashed hash (importType₀ <> importType₁) - -instance Pretty ImportHashed where - pretty (ImportHashed Nothing p) = - Pretty.pretty p - pretty (ImportHashed (Just h) p) = - Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) - --- | Reference to an external resource -data Import = Import - { importHashed :: ImportHashed - , importMode :: ImportMode - } deriving (Eq, Generic, Ord, Show, NFData) - -instance Semigroup Import where - Import importHashed₀ _ <> Import importHashed₁ code = - Import (importHashed₀ <> importHashed₁) code - -instance Pretty Import where - pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix - where - suffix :: Text - suffix = case importMode of - RawText -> " as Text" - Location -> " as Location" - Code -> "" - -{-| Label for a bound variable - - The `Text` field is the variable's name (i.e. \"@x@\"). - - The `Int` field disambiguates variables with the same name if there are - multiple bound variables of the same name in scope. Zero refers to the - nearest bound variable and the index increases by one for each bound - variable of the same name going outward. The following diagram may help: - -> ┌──refers to──┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 -> -> ┌─────────────────refers to─────────────────┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 - - This `Int` behaves like a De Bruijn index in the special case where all - variables have the same name. - - You can optionally omit the index if it is @0@: - -> ┌─refers to─┐ -> │ │ -> v │ -> λ(x : Type) → λ(y : Type) → λ(x : Type) → x - - Zero indices are omitted when pretty-printing `Var`s and non-zero indices - appear as a numeric suffix. --} -data Var = V Text !Int - deriving (Data, Generic, Eq, Ord, Show, NFData) - -instance Lift Var - -instance IsString Var where - fromString str = V (fromString str) 0 - -instance Pretty Var where - pretty = Pretty.unAnnotate . prettyVar - -{-| Syntax tree for expressions - - The @s@ type parameter is used to track the presence or absence of `Src` - spans: - - * If @s = `Src`@ then the code may contains `Src` spans (either in a `Noted` - constructor or inline within another constructor, like `Let`) - * If @s = `Void`@ then the code has no `Src` spans - - The @a@ type parameter is used to track the presence or absence of imports - - * If @a = `Import`@ then the code may contain unresolved `Import`s - * If @a = `Void`@ then the code has no `Import`s --} -data Expr s a - -- | > Const c ~ c - = Const Const - -- | > Var (V x 0) ~ x - -- > Var (V x n) ~ x@n - | Var Var - -- | > Lam x A b ~ λ(x : A) -> b - | Lam Text (Expr s a) (Expr s a) - -- | > Pi "_" A B ~ A -> B - -- > Pi x A B ~ ∀(x : A) -> B - | Pi Text (Expr s a) (Expr s a) - -- | > App f a ~ f a - | App (Expr s a) (Expr s a) - -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e - -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e - -- - -- The difference between - -- - -- > let x = a let y = b in e - -- - -- and - -- - -- > let x = a in let y = b in e - -- - -- is only an additional 'Note' around @'Let' "y" …@ in the second - -- example. - -- - -- See 'MultiLet' for a representation of let-blocks that mirrors the - -- source code more closely. - | Let (Binding s a) (Expr s a) - -- | > Annot x t ~ x : t - | Annot (Expr s a) (Expr s a) - -- | > Bool ~ Bool - | Bool - -- | > BoolLit b ~ b - | BoolLit Bool - -- | > BoolAnd x y ~ x && y - | BoolAnd (Expr s a) (Expr s a) - -- | > BoolOr x y ~ x || y - | BoolOr (Expr s a) (Expr s a) - -- | > BoolEQ x y ~ x == y - | BoolEQ (Expr s a) (Expr s a) - -- | > BoolNE x y ~ x != y - | BoolNE (Expr s a) (Expr s a) - -- | > BoolIf x y z ~ if x then y else z - | BoolIf (Expr s a) (Expr s a) (Expr s a) - -- | > Natural ~ Natural - | Natural - -- | > NaturalLit n ~ n - | NaturalLit Natural - -- | > NaturalFold ~ Natural/fold - | NaturalFold - -- | > NaturalBuild ~ Natural/build - | NaturalBuild - -- | > NaturalIsZero ~ Natural/isZero - | NaturalIsZero - -- | > NaturalEven ~ Natural/even - | NaturalEven - -- | > NaturalOdd ~ Natural/odd - | NaturalOdd - -- | > NaturalToInteger ~ Natural/toInteger - | NaturalToInteger - -- | > NaturalShow ~ Natural/show - | NaturalShow - -- | > NaturalSubtract ~ Natural/subtract - | NaturalSubtract - -- | > NaturalPlus x y ~ x + y - | NaturalPlus (Expr s a) (Expr s a) - -- | > NaturalTimes x y ~ x * y - | NaturalTimes (Expr s a) (Expr s a) - -- | > Integer ~ Integer - | Integer - -- | > IntegerLit n ~ ±n - | IntegerLit Integer - -- | > IntegerShow ~ Integer/show - | IntegerShow - -- | > IntegerToDouble ~ Integer/toDouble - | IntegerToDouble - -- | > Double ~ Double - | Double - -- | > DoubleLit n ~ n - | DoubleLit Double - -- | > DoubleShow ~ Double/show - | DoubleShow - -- | > Text ~ Text - | Text - -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" - | TextLit (Chunks s a) - -- | > TextAppend x y ~ x ++ y - | TextAppend (Expr s a) (Expr s a) - -- | > TextShow ~ Text/show - | TextShow - -- | > List ~ List - | List - -- | > ListLit (Just t ) [x, y, z] ~ [x, y, z] : t - -- > ListLit Nothing [x, y, z] ~ [x, y, z] - | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) - -- | > ListAppend x y ~ x # y - | ListAppend (Expr s a) (Expr s a) - -- | > ListBuild ~ List/build - | ListBuild - -- | > ListFold ~ List/fold - | ListFold - -- | > ListLength ~ List/length - | ListLength - -- | > ListHead ~ List/head - | ListHead - -- | > ListLast ~ List/last - | ListLast - -- | > ListIndexed ~ List/indexed - | ListIndexed - -- | > ListReverse ~ List/reverse - | ListReverse - -- | > Optional ~ Optional - | Optional - -- | > Some e ~ Some e - | Some (Expr s a) - -- | > None ~ None - | None - -- | > OptionalFold ~ Optional/fold - | OptionalFold - -- | > OptionalBuild ~ Optional/build - | OptionalBuild - -- | > Record [(k1, t1), (k2, t2)] ~ { k1 : t1, k2 : t1 } - | Record (Map Text (Expr s a)) - -- | > RecordLit [(k1, v1), (k2, v2)] ~ { k1 = v1, k2 = v2 } - | RecordLit (Map Text (Expr s a)) - -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > - | Union (Map Text (Maybe (Expr s a))) - -- | > Combine x y ~ x ∧ y - | Combine (Expr s a) (Expr s a) - -- | > CombineTypes x y ~ x ⩓ y - | CombineTypes (Expr s a) (Expr s a) - -- | > Prefer x y ~ x ⫽ y - | Prefer (Expr s a) (Expr s a) - -- | > Merge x y (Just t ) ~ merge x y : t - -- > Merge x y Nothing ~ merge x y - | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) - -- | > ToMap x (Just t) ~ toMap x : t - -- > ToMap x Nothing ~ toMap x - | ToMap (Expr s a) (Maybe (Expr s a)) - -- | > Field e x ~ e.x - | Field (Expr s a) Text - -- | > Project e (Left xs) ~ e.{ xs } - -- | > Project e (Right t) ~ e.(t) - | Project (Expr s a) (Either (Set Text) (Expr s a)) - -- | > Assert e ~ assert : e - | Assert (Expr s a) - -- | > Equivalent x y ~ x ≡ y - | Equivalent (Expr s a) (Expr s a) - -- | > Note s x ~ e - | Note s (Expr s a) - -- | > ImportAlt ~ e1 ? e2 - | ImportAlt (Expr s a) (Expr s a) - -- | > Embed import ~ import - | Embed a - deriving (Foldable, Generic, Traversable, Show, Data, NFData) --- NB: If you add a constructor to Expr, please also update the Arbitrary --- instance in Dhall.Test.QuickCheck. - --- | Note that this 'Eq' instance inherits `Double`'s defects, e.g. --- --- >>> nan = 0/0 --- >>> DoubleLit nan == DoubleLit nan --- False -deriving instance (Eq s, Eq a) => Eq (Expr s a) - --- | Note that this 'Eq' instance inherits `Double`'s defects, e.g. --- --- >>> nan = 0/0 --- >>> DoubleLit nan <= DoubleLit nan --- False -deriving instance (Ord s, Ord a) => Ord (Expr s a) - -instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a) - --- This instance is hand-written due to the fact that deriving --- it does not give us an INLINABLE pragma. We annotate this fmap --- implementation with this pragma below to allow GHC to, possibly, --- inline the implementation for performance improvements. -instance Functor (Expr s) where - fmap _ (Const c) = Const c - fmap _ (Var v) = Var v - fmap f (Lam v e1 e2) = Lam v (fmap f e1) (fmap f e2) - fmap f (Pi v e1 e2) = Pi v (fmap f e1) (fmap f e2) - fmap f (App e1 e2) = App (fmap f e1) (fmap f e2) - fmap f (Let b e2) = Let (fmap f b) (fmap f e2) - fmap f (Annot e1 e2) = Annot (fmap f e1) (fmap f e2) - fmap _ Bool = Bool - fmap _ (BoolLit b) = BoolLit b - fmap f (BoolAnd e1 e2) = BoolAnd (fmap f e1) (fmap f e2) - fmap f (BoolOr e1 e2) = BoolOr (fmap f e1) (fmap f e2) - fmap f (BoolEQ e1 e2) = BoolEQ (fmap f e1) (fmap f e2) - fmap f (BoolNE e1 e2) = BoolNE (fmap f e1) (fmap f e2) - fmap f (BoolIf e1 e2 e3) = BoolIf (fmap f e1) (fmap f e2) (fmap f e3) - fmap _ Natural = Natural - fmap _ (NaturalLit n) = NaturalLit n - fmap _ NaturalFold = NaturalFold - fmap _ NaturalBuild = NaturalBuild - fmap _ NaturalIsZero = NaturalIsZero - fmap _ NaturalEven = NaturalEven - fmap _ NaturalOdd = NaturalOdd - fmap _ NaturalToInteger = NaturalToInteger - fmap _ NaturalShow = NaturalShow - fmap _ NaturalSubtract = NaturalSubtract - fmap f (NaturalPlus e1 e2) = NaturalPlus (fmap f e1) (fmap f e2) - fmap f (NaturalTimes e1 e2) = NaturalTimes (fmap f e1) (fmap f e2) - fmap _ Integer = Integer - fmap _ (IntegerLit i) = IntegerLit i - fmap _ IntegerShow = IntegerShow - fmap _ IntegerToDouble = IntegerToDouble - fmap _ Double = Double - fmap _ (DoubleLit d) = DoubleLit d - fmap _ DoubleShow = DoubleShow - fmap _ Text = Text - fmap f (TextLit cs) = TextLit (fmap f cs) - fmap f (TextAppend e1 e2) = TextAppend (fmap f e1) (fmap f e2) - fmap _ TextShow = TextShow - fmap _ List = List - fmap f (ListLit maybeE seqE) = ListLit (fmap (fmap f) maybeE) (fmap (fmap f) seqE) - fmap f (ListAppend e1 e2) = ListAppend (fmap f e1) (fmap f e2) - fmap _ ListBuild = ListBuild - fmap _ ListFold = ListFold - fmap _ ListLength = ListLength - fmap _ ListHead = ListHead - fmap _ ListLast = ListLast - fmap _ ListIndexed = ListIndexed - fmap _ ListReverse = ListReverse - fmap _ Optional = Optional - fmap f (Some e) = Some (fmap f e) - fmap _ None = None - fmap _ OptionalFold = OptionalFold - fmap _ OptionalBuild = OptionalBuild - fmap f (Record r) = Record (fmap (fmap f) r) - fmap f (RecordLit r) = RecordLit (fmap (fmap f) r) - fmap f (Union u) = Union (fmap (fmap (fmap f)) u) - fmap f (Combine e1 e2) = Combine (fmap f e1) (fmap f e2) - fmap f (CombineTypes e1 e2) = CombineTypes (fmap f e1) (fmap f e2) - fmap f (Prefer e1 e2) = Prefer (fmap f e1) (fmap f e2) - fmap f (Merge e1 e2 maybeE) = Merge (fmap f e1) (fmap f e2) (fmap (fmap f) maybeE) - fmap f (ToMap e maybeE) = ToMap (fmap f e) (fmap (fmap f) maybeE) - fmap f (Field e1 v) = Field (fmap f e1) v - fmap f (Project e1 vs) = Project (fmap f e1) (fmap (fmap f) vs) - fmap f (Assert t) = Assert (fmap f t) - fmap f (Equivalent e1 e2) = Equivalent (fmap f e1) (fmap f e2) - fmap f (Note s e1) = Note s (fmap f e1) - fmap f (ImportAlt e1 e2) = ImportAlt (fmap f e1) (fmap f e2) - fmap f (Embed a) = Embed (f a) - {-# INLINABLE fmap #-} - -instance Applicative (Expr s) where - pure = Embed - - (<*>) = Control.Monad.ap - -instance Monad (Expr s) where - return = pure - - Const a >>= _ = Const a - Var a >>= _ = Var a - Lam a b c >>= k = Lam a (b >>= k) (c >>= k) - Pi a b c >>= k = Pi a (b >>= k) (c >>= k) - App a b >>= k = App (a >>= k) (b >>= k) - Let a b >>= k = Let (adapt0 a) (b >>= k) - where - adapt0 (Binding src0 c src1 d src2 e) = - Binding src0 c src1 (fmap adapt1 d) src2 (e >>= k) - - adapt1 (src3, f) = (src3, f >>= k) - Annot a b >>= k = Annot (a >>= k) (b >>= k) - Bool >>= _ = Bool - BoolLit a >>= _ = BoolLit a - BoolAnd a b >>= k = BoolAnd (a >>= k) (b >>= k) - BoolOr a b >>= k = BoolOr (a >>= k) (b >>= k) - BoolEQ a b >>= k = BoolEQ (a >>= k) (b >>= k) - BoolNE a b >>= k = BoolNE (a >>= k) (b >>= k) - BoolIf a b c >>= k = BoolIf (a >>= k) (b >>= k) (c >>= k) - Natural >>= _ = Natural - NaturalLit a >>= _ = NaturalLit a - NaturalFold >>= _ = NaturalFold - NaturalBuild >>= _ = NaturalBuild - NaturalIsZero >>= _ = NaturalIsZero - NaturalEven >>= _ = NaturalEven - NaturalOdd >>= _ = NaturalOdd - NaturalToInteger >>= _ = NaturalToInteger - NaturalShow >>= _ = NaturalShow - NaturalSubtract >>= _ = NaturalSubtract - NaturalPlus a b >>= k = NaturalPlus (a >>= k) (b >>= k) - NaturalTimes a b >>= k = NaturalTimes (a >>= k) (b >>= k) - Integer >>= _ = Integer - IntegerLit a >>= _ = IntegerLit a - IntegerShow >>= _ = IntegerShow - IntegerToDouble >>= _ = IntegerToDouble - Double >>= _ = Double - DoubleLit a >>= _ = DoubleLit a - DoubleShow >>= _ = DoubleShow - Text >>= _ = Text - TextLit (Chunks a b) >>= k = TextLit (Chunks (fmap (fmap (>>= k)) a) b) - TextAppend a b >>= k = TextAppend (a >>= k) (b >>= k) - TextShow >>= _ = TextShow - List >>= _ = List - ListLit a b >>= k = ListLit (fmap (>>= k) a) (fmap (>>= k) b) - ListAppend a b >>= k = ListAppend (a >>= k) (b >>= k) - ListBuild >>= _ = ListBuild - ListFold >>= _ = ListFold - ListLength >>= _ = ListLength - ListHead >>= _ = ListHead - ListLast >>= _ = ListLast - ListIndexed >>= _ = ListIndexed - ListReverse >>= _ = ListReverse - Optional >>= _ = Optional - Some a >>= k = Some (a >>= k) - None >>= _ = None - OptionalFold >>= _ = OptionalFold - OptionalBuild >>= _ = OptionalBuild - Record a >>= k = Record (fmap (>>= k) a) - RecordLit a >>= k = RecordLit (fmap (>>= k) a) - Union a >>= k = Union (fmap (fmap (>>= k)) a) - Combine a b >>= k = Combine (a >>= k) (b >>= k) - CombineTypes a b >>= k = CombineTypes (a >>= k) (b >>= k) - Prefer a b >>= k = Prefer (a >>= k) (b >>= k) - Merge a b c >>= k = Merge (a >>= k) (b >>= k) (fmap (>>= k) c) - ToMap a b >>= k = ToMap (a >>= k) (fmap (>>= k) b) - Field a b >>= k = Field (a >>= k) b - Project a b >>= k = Project (a >>= k) (fmap (>>= k) b) - Assert a >>= k = Assert (a >>= k) - Equivalent a b >>= k = Equivalent (a >>= k) (b >>= k) - Note a b >>= k = Note a (b >>= k) - ImportAlt a b >>= k = ImportAlt (a >>= k) (b >>= k) - Embed a >>= k = k a - -instance Bifunctor Expr where - first _ (Const a ) = Const a - first _ (Var a ) = Var a - first k (Lam a b c ) = Lam a (first k b) (first k c) - first k (Pi a b c ) = Pi a (first k b) (first k c) - first k (App a b ) = App (first k a) (first k b) - first k (Let a b ) = Let (first k a) (first k b) - first k (Annot a b ) = Annot (first k a) (first k b) - first _ Bool = Bool - first _ (BoolLit a ) = BoolLit a - first k (BoolAnd a b ) = BoolAnd (first k a) (first k b) - first k (BoolOr a b ) = BoolOr (first k a) (first k b) - first k (BoolEQ a b ) = BoolEQ (first k a) (first k b) - first k (BoolNE a b ) = BoolNE (first k a) (first k b) - first k (BoolIf a b c ) = BoolIf (first k a) (first k b) (first k c) - first _ Natural = Natural - first _ (NaturalLit a ) = NaturalLit a - first _ NaturalFold = NaturalFold - first _ NaturalBuild = NaturalBuild - first _ NaturalIsZero = NaturalIsZero - first _ NaturalEven = NaturalEven - first _ NaturalOdd = NaturalOdd - first _ NaturalToInteger = NaturalToInteger - first _ NaturalShow = NaturalShow - first _ NaturalSubtract = NaturalSubtract - first k (NaturalPlus a b ) = NaturalPlus (first k a) (first k b) - first k (NaturalTimes a b ) = NaturalTimes (first k a) (first k b) - first _ Integer = Integer - first _ (IntegerLit a ) = IntegerLit a - first _ IntegerShow = IntegerShow - first _ IntegerToDouble = IntegerToDouble - first _ Double = Double - first _ (DoubleLit a ) = DoubleLit a - first _ DoubleShow = DoubleShow - first _ Text = Text - first k (TextLit (Chunks a b)) = TextLit (Chunks (fmap (fmap (first k)) a) b) - first k (TextAppend a b ) = TextAppend (first k a) (first k b) - first _ TextShow = TextShow - first _ List = List - first k (ListLit a b ) = ListLit (fmap (first k) a) (fmap (first k) b) - first k (ListAppend a b ) = ListAppend (first k a) (first k b) - first _ ListBuild = ListBuild - first _ ListFold = ListFold - first _ ListLength = ListLength - first _ ListHead = ListHead - first _ ListLast = ListLast - first _ ListIndexed = ListIndexed - first _ ListReverse = ListReverse - first _ Optional = Optional - first k (Some a ) = Some (first k a) - first _ None = None - first _ OptionalFold = OptionalFold - first _ OptionalBuild = OptionalBuild - first k (Record a ) = Record (fmap (first k) a) - first k (RecordLit a ) = RecordLit (fmap (first k) a) - first k (Union a ) = Union (fmap (fmap (first k)) a) - first k (Combine a b ) = Combine (first k a) (first k b) - first k (CombineTypes a b ) = CombineTypes (first k a) (first k b) - first k (Prefer a b ) = Prefer (first k a) (first k b) - first k (Merge a b c ) = Merge (first k a) (first k b) (fmap (first k) c) - first k (ToMap a b ) = ToMap (first k a) (fmap (first k) b) - first k (Field a b ) = Field (first k a) b - first k (Assert a ) = Assert (first k a) - first k (Equivalent a b ) = Equivalent (first k a) (first k b) - first k (Project a b ) = Project (first k a) (fmap (first k) b) - first k (Note a b ) = Note (k a) (first k b) - first k (ImportAlt a b ) = ImportAlt (first k a) (first k b) - first _ (Embed a ) = Embed a - - second = fmap - -instance IsString (Expr s a) where - fromString str = Var (fromString str) - --- | The body of an interpolated @Text@ literal -data Chunks s a = Chunks [(Text, Expr s a)] Text - deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData) - -instance (Lift s, Lift a, Data s, Data a) => Lift (Chunks s a) - -instance Data.Semigroup.Semigroup (Chunks s a) where - Chunks xysL zL <> Chunks [] zR = - Chunks xysL (zL <> zR) - Chunks xysL zL <> Chunks ((x, y):xysR) zR = - Chunks (xysL ++ (zL <> x, y):xysR) zR - -instance Monoid (Chunks s a) where - mempty = Chunks [] mempty - -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - -instance IsString (Chunks s a) where - fromString str = Chunks [] (fromString str) - -{- There is a one-to-one correspondence between the builders in this section - and the sub-parsers in "Dhall.Parser". Each builder is named after the - corresponding parser and the relationship between builders exactly matches - the relationship between parsers. This leads to the nice emergent property - of automatically getting all the parentheses and precedences right. - - This approach has one major disadvantage: you can get an infinite loop if - you add a new constructor to the syntax tree without adding a matching - case the corresponding builder. --} - --- | Generates a syntactically valid Dhall program -instance Pretty a => Pretty (Expr s a) where - pretty = Pretty.unAnnotate . prettyExpr - -{-| `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 (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 (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 - --- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) -denote :: Expr s a -> Expr t a -denote (Note _ b ) = denote b -denote (Const a ) = Const a -denote (Var a ) = Var a -denote (Lam a b c ) = Lam a (denote b) (denote c) -denote (Pi a b c ) = Pi a (denote b) (denote c) -denote (App a b ) = App (denote a) (denote b) -denote (Let a b ) = Let (adapt0 a) (denote b) - where - adapt0 (Binding _ c _ d _ e) = - Binding Nothing c Nothing (fmap adapt1 d) Nothing (denote e) - - adapt1 (_, f) = (Nothing, denote f) -denote (Annot a b ) = Annot (denote a) (denote b) -denote Bool = Bool -denote (BoolLit a ) = BoolLit a -denote (BoolAnd a b ) = BoolAnd (denote a) (denote b) -denote (BoolOr a b ) = BoolOr (denote a) (denote b) -denote (BoolEQ a b ) = BoolEQ (denote a) (denote b) -denote (BoolNE a b ) = BoolNE (denote a) (denote b) -denote (BoolIf a b c ) = BoolIf (denote a) (denote b) (denote c) -denote Natural = Natural -denote (NaturalLit a ) = NaturalLit a -denote NaturalFold = NaturalFold -denote NaturalBuild = NaturalBuild -denote NaturalIsZero = NaturalIsZero -denote NaturalEven = NaturalEven -denote NaturalOdd = NaturalOdd -denote NaturalToInteger = NaturalToInteger -denote NaturalShow = NaturalShow -denote NaturalSubtract = NaturalSubtract -denote (NaturalPlus a b ) = NaturalPlus (denote a) (denote b) -denote (NaturalTimes a b ) = NaturalTimes (denote a) (denote b) -denote Integer = Integer -denote (IntegerLit a ) = IntegerLit a -denote IntegerShow = IntegerShow -denote IntegerToDouble = IntegerToDouble -denote Double = Double -denote (DoubleLit a ) = DoubleLit a -denote DoubleShow = DoubleShow -denote Text = Text -denote (TextLit (Chunks a b)) = TextLit (Chunks (fmap (fmap denote) a) b) -denote (TextAppend a b ) = TextAppend (denote a) (denote b) -denote TextShow = TextShow -denote List = List -denote (ListLit a b ) = ListLit (fmap denote a) (fmap denote b) -denote (ListAppend a b ) = ListAppend (denote a) (denote b) -denote ListBuild = ListBuild -denote ListFold = ListFold -denote ListLength = ListLength -denote ListHead = ListHead -denote ListLast = ListLast -denote ListIndexed = ListIndexed -denote ListReverse = ListReverse -denote Optional = Optional -denote (Some a ) = Some (denote a) -denote None = None -denote OptionalFold = OptionalFold -denote OptionalBuild = OptionalBuild -denote (Record a ) = Record (fmap denote a) -denote (RecordLit a ) = RecordLit (fmap denote a) -denote (Union a ) = Union (fmap (fmap denote) a) -denote (Combine a b ) = Combine (denote a) (denote b) -denote (CombineTypes a b ) = CombineTypes (denote a) (denote b) -denote (Prefer a b ) = Prefer (denote a) (denote b) -denote (Merge a b c ) = Merge (denote a) (denote b) (fmap denote c) -denote (ToMap a b ) = ToMap (denote a) (fmap denote b) -denote (Field a b ) = Field (denote a) b -denote (Project a b ) = Project (denote a) (fmap denote b) -denote (Assert a ) = Assert (denote a) -denote (Equivalent a b ) = Equivalent (denote a) (denote b) -denote (ImportAlt a b ) = ImportAlt (denote a) (denote b) -denote (Embed a ) = Embed a - --- | The \"opposite\" of `denote`, like @first absurd@ but faster -renote :: Expr Void a -> Expr s a -renote = unsafeCoerce -{-# INLINE renote #-} - -shallowDenote :: Expr s a -> Expr s a -shallowDenote (Note _ e) = shallowDenote e -shallowDenote e = e - -{-| 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 - App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((read . show) n)) - App DoubleShow (DoubleLit 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 = 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' <*> es' - | 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 - 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) - -textShow :: Text -> Text -textShow text = "\"" <> Data.Text.concatMap f text <> "\"" - where - f '"' = "\\\"" - f '$' = "\\u0024" - f '\\' = "\\\\" - f '\b' = "\\b" - f '\n' = "\\n" - f '\r' = "\\r" - f '\t' = "\\t" - f '\f' = "\\f" - f c | c <= '\x1F' = Data.Text.pack (Text.Printf.printf "\\u%04x" (Data.Char.ord c)) - | otherwise = Data.Text.singleton c - --- | 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)) - -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) - 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 - -_ERROR :: String -_ERROR = "\ESC[1;31mError\ESC[0m" - -{-| Utility function used to throw internal errors that should never happen - (in theory) but that are not enforced by the type system --} -internalError :: Data.Text.Text -> forall b . b -internalError text = error (unlines - [ _ERROR <> ": Compiler bug " - , " " - , "Explanation: This error message means that there is a bug in the Dhall compiler." - , "You didn't do anything wrong, but if you would like to see this problem fixed " - , "then you should report the bug at: " - , " " - , "https://github.com/dhall-lang/dhall-haskell/issues " - , " " - , "Please include the following text in your bug report: " - , " " - , "``` " - , Data.Text.unpack text <> " " - , "``` " - ] ) - --- | The set of reserved identifiers for the Dhall language -reservedIdentifiers :: HashSet Text -reservedIdentifiers = - Data.HashSet.fromList - [ "let" - , "in" - , "Type" - , "Kind" - , "Sort" - , "forall" - , "Bool" - , "True" - , "False" - , "merge" - , "toMap" - , "if" - , "then" - , "else" - , "as" - , "using" - , "Natural" - , "Natural/fold" - , "Natural/build" - , "Natural/isZero" - , "Natural/even" - , "Natural/odd" - , "Natural/toInteger" - , "Natural/show" - , "Natural/subtract" - , "Integer" - , "Integer/show" - , "Integer/toDouble" - , "Double" - , "Double/show" - , "Text" - , "Text/show" - , "List" - , "List/build" - , "List/fold" - , "List/length" - , "List/head" - , "List/last" - , "List/indexed" - , "List/reverse" - , "Optional" - , "Some" - , "None" - , "Optional/build" - , "Optional/fold" - , "NaN" - , "Infinity" - ] - - --- | A traversal over the immediate sub-expressions of an expression. -subExpressions :: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a) -subExpressions _ (Const c) = pure (Const c) -subExpressions _ (Var v) = pure (Var v) -subExpressions f (Lam a b c) = Lam a <$> f b <*> f c -subExpressions f (Pi a b c) = Pi a <$> f b <*> f c -subExpressions f (App a b) = App <$> f a <*> f b -subExpressions f (Let a b) = Let <$> bindingExprs f a <*> f b -subExpressions f (Annot a b) = Annot <$> f a <*> f b -subExpressions _ Bool = pure Bool -subExpressions _ (BoolLit b) = pure (BoolLit b) -subExpressions f (BoolAnd a b) = BoolAnd <$> f a <*> f b -subExpressions f (BoolOr a b) = BoolOr <$> f a <*> f b -subExpressions f (BoolEQ a b) = BoolEQ <$> f a <*> f b -subExpressions f (BoolNE a b) = BoolNE <$> f a <*> f b -subExpressions f (BoolIf a b c) = BoolIf <$> f a <*> f b <*> f c -subExpressions _ Natural = pure Natural -subExpressions _ (NaturalLit n) = pure (NaturalLit n) -subExpressions _ NaturalFold = pure NaturalFold -subExpressions _ NaturalBuild = pure NaturalBuild -subExpressions _ NaturalIsZero = pure NaturalIsZero -subExpressions _ NaturalEven = pure NaturalEven -subExpressions _ NaturalOdd = pure NaturalOdd -subExpressions _ NaturalToInteger = pure NaturalToInteger -subExpressions _ NaturalShow = pure NaturalShow -subExpressions _ NaturalSubtract = pure NaturalSubtract -subExpressions f (NaturalPlus a b) = NaturalPlus <$> f a <*> f b -subExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b -subExpressions _ Integer = pure Integer -subExpressions _ (IntegerLit n) = pure (IntegerLit n) -subExpressions _ IntegerShow = pure IntegerShow -subExpressions _ IntegerToDouble = pure IntegerToDouble -subExpressions _ Double = pure Double -subExpressions _ (DoubleLit n) = pure (DoubleLit n) -subExpressions _ DoubleShow = pure DoubleShow -subExpressions _ Text = pure Text -subExpressions f (TextLit chunks) = - TextLit <$> chunkExprs f chunks -subExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b -subExpressions _ TextShow = pure TextShow -subExpressions _ List = pure List -subExpressions f (ListLit a b) = ListLit <$> traverse f a <*> traverse f b -subExpressions f (ListAppend a b) = ListAppend <$> f a <*> f b -subExpressions _ ListBuild = pure ListBuild -subExpressions _ ListFold = pure ListFold -subExpressions _ ListLength = pure ListLength -subExpressions _ ListHead = pure ListHead -subExpressions _ ListLast = pure ListLast -subExpressions _ ListIndexed = pure ListIndexed -subExpressions _ ListReverse = pure ListReverse -subExpressions _ Optional = pure Optional -subExpressions f (Some a) = Some <$> f a -subExpressions _ None = pure None -subExpressions _ OptionalFold = pure OptionalFold -subExpressions _ OptionalBuild = pure OptionalBuild -subExpressions f (Record a) = Record <$> traverse f a -subExpressions f ( RecordLit a ) = RecordLit <$> traverse f a -subExpressions f (Union a) = Union <$> traverse (traverse f) a -subExpressions f (Combine a b) = Combine <$> f a <*> f b -subExpressions f (CombineTypes a b) = CombineTypes <$> f a <*> f b -subExpressions f (Prefer a b) = Prefer <$> f a <*> f b -subExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t -subExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t -subExpressions f (Field a b) = Field <$> f a <*> pure b -subExpressions f (Project a b) = Project <$> f a <*> traverse f b -subExpressions f (Assert a) = Assert <$> f a -subExpressions f (Equivalent a b) = Equivalent <$> f a <*> f b -subExpressions f (Note a b) = Note a <$> f b -subExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r -subExpressions _ (Embed a) = pure (Embed a) - -{-| Utility used to implement the @--censor@ flag, by: - - * Replacing all `Src` text with spaces - * Replacing all `Text` literals inside type errors with spaces --} -censorExpression :: Expr Src a -> Expr Src a -censorExpression (TextLit chunks) = TextLit (censorChunks chunks) -censorExpression (Note src e) = Note (censorSrc src) (censorExpression e) -censorExpression e = over subExpressions censorExpression e - -censorChunks :: Chunks Src a -> Chunks Src a -censorChunks (Chunks xys z) = Chunks xys' z' - where - z' = censorText z - - xys' = [ (censorText x, censorExpression y) | (x, y) <- xys ] - --- | Utility used to censor `Text` by replacing all characters with a space -censorText :: Text -> Text -censorText = Data.Text.map (\_ -> ' ') - -censorSrc :: Src -> Src -censorSrc (Src { srcText = oldText, .. }) = Src { srcText = newText, .. } - where - newText = censorText oldText - --- | A traversal over the immediate sub-expressions in 'Chunks'. -chunkExprs - :: Applicative f - => (Expr s a -> f (Expr t b)) - -> Chunks s a -> f (Chunks t b) -chunkExprs f (Chunks chunks final) = - flip Chunks final <$> traverse (traverse f) chunks - -{-| Returns `True` if the given `Char` is valid within an unquoted path - component - - This is exported for reuse within the @"Dhall.Parser.Token"@ module --} -pathCharacter :: Char -> Bool -pathCharacter c = - '\x21' == c - || ('\x24' <= c && c <= '\x27') - || ('\x2A' <= c && c <= '\x2B') - || ('\x2D' <= c && c <= '\x2E') - || ('\x30' <= c && c <= '\x3B') - || c == '\x3D' - || ('\x40' <= c && c <= '\x5A') - || ('\x5E' <= c && c <= '\x7A') - || c == '\x7C' - || c == '\x7E' - -prettyPathComponent :: Text -> Doc ann -prettyPathComponent text - | Data.Text.all pathCharacter text = - "/" <> Pretty.pretty text - | otherwise = - "/\"" <> Pretty.pretty text <> "\"" - -prettyURIComponent :: Text -> Doc ann -prettyURIComponent text = - Pretty.pretty $ URI.normalizeCase $ URI.normalizeEscape $ "/" <> Data.Text.unpack text - -{-| 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 - -{- -Instead of converting explicitly between 'Expr's and 'MultiLet', it might -be nicer to use a pattern synonym: - -> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a -> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where -> MultiLet' as b = wrapInLets as b -> -> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) -> multiLetFromExpr = \case -> Let x mA a b -> Just (multiLet x mA a b) -> _ -> Nothing - -This works in principle, but GHC as of v8.8.1 doesn't handle it well: -https://gitlab.haskell.org/ghc/ghc/issues/17096 - -This should be fixed by GHC-8.10, so it might be worth revisiting then. --} - -{-| Generate a 'MultiLet' from the contents of a 'Let'. - - In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', - but it might be a @('Note' … ('Let' …))@. - - Given parser output, 'multiLet' consolidates @let@s that formed a - let-block in the original source. --} -multiLet :: Binding s a -> Expr s a -> MultiLet s a -multiLet b0 = \case - Let b1 e1 -> - let MultiLet bs e = multiLet b1 e1 - in MultiLet (Data.List.NonEmpty.cons b0 bs) e - e -> MultiLet (b0 :| []) e - -{-| Wrap let-'Binding's around an 'Expr'. - -'wrapInLets' can be understood as an inverse for 'multiLet': - -> let MultiLet bs e1 = multiLet b e0 -> -> wrapInLets bs e1 == Let b e0 --} -wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a -wrapInLets bs e = foldr Let e bs - -data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) - -{- | Record the binding part of a @let@ expression. - -For example, -> let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x -will be instantiated as follows: - -* @bindingSrc0@ corresponds to the @A@ comment. -* @variable@ is @"x"@ -* @bindingSrc1@ corresponds to the @B@ comment. -* @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. -* @bindingSrc2@ corresponds to the @D@ comment. -* @value@ corresponds to @True@. --} -data Binding s a = Binding - { bindingSrc0 :: Maybe s - , variable :: Text - , bindingSrc1 :: Maybe s - , annotation :: Maybe (Maybe s, Expr s a) - , bindingSrc2 :: Maybe s - , value :: Expr s a - } deriving (Data, Eq, Foldable, Functor, Generic, NFData, Ord, Show, Traversable) - -instance Bifunctor Binding where - first k (Binding src0 a src1 b src2 c) = - Binding (fmap k src0) a (fmap k src1) (fmap adapt0 b) (fmap k src2) (first k c) - where - adapt0 (src3, d) = (fmap k src3, first k d) - - second = fmap - -{-| Traverse over the immediate 'Expr' children in a 'Binding'. --} -bindingExprs - :: (Applicative f) - => (Expr s a -> f (Expr s b)) - -> Binding s a -> f (Binding s b) -bindingExprs f (Binding s0 n s1 t s2 v) = - Binding - <$> pure s0 - <*> pure n - <*> pure s1 - <*> traverse (traverse f) t - <*> pure s2 - <*> f v - -{-| Construct a 'Binding' with no source information and no type annotation. --} -makeBinding :: Text -> Expr s a -> Binding s a -makeBinding name = Binding Nothing name Nothing Nothing Nothing +{-# 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 + +-- | Pretty-print a value +pretty :: Pretty a => a -> Text +pretty = pretty_ +{-# INLINE pretty #-} + +_ERROR :: String +_ERROR = "\ESC[1;31mError\ESC[0m" + +{-| Utility function used to throw internal errors that should never happen + (in theory) but that are not enforced by the type system +-} +internalError :: Data.Text.Text -> forall b . b +internalError text = error (unlines + [ _ERROR <> ": Compiler bug " + , " " + , "Explanation: This error message means that there is a bug in the Dhall compiler." + , "You didn't do anything wrong, but if you would like to see this problem fixed " + , "then you should report the bug at: " + , " " + , "https://github.com/dhall-lang/dhall-haskell/issues " + , " " + , "Please include the following text in your bug report: " + , " " + , "``` " + , Data.Text.unpack text <> " " + , "``` " + ] ) + +{-| Escape a `Text` literal using Dhall's escaping rules + + Note that the result does not include surrounding quotes +-} +escapeText :: Text -> Text +escapeText = escapeText_ +{-# INLINE escapeText #-} + + +{-| Utility used to implement the @--censor@ flag, by: + + * Replacing all `Src` text with spaces + * Replacing all `Text` literals inside type errors with spaces +-} +censorExpression :: Expr Src a -> Expr Src a +censorExpression (TextLit chunks) = TextLit (censorChunks chunks) +censorExpression (Note src e) = Note (censorSrc src) (censorExpression e) +censorExpression e = over subExpressions censorExpression e + +censorChunks :: Chunks Src a -> Chunks Src a +censorChunks (Chunks xys z) = Chunks xys' z' + where + z' = censorText z + + xys' = [ (censorText x, censorExpression y) | (x, y) <- xys ] + +-- | Utility used to censor `Text` by replacing all characters with a space +censorText :: Text -> Text +censorText = Data.Text.map (\_ -> ' ') + +censorSrc :: Src -> Src +censorSrc (Src { srcText = oldText, .. }) = Src { srcText = newText, .. } + where + newText = censorText oldText + +{-| 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 + +{- $setup +>>> import qualified Codec.Serialise +>>> import qualified Dhall.Binary +>>> import Data.SpecialValues +>>> import Test.QuickCheck (Arbitrary(..), oneof, elements) +>>> :{ + instance Arbitrary DhallDouble where + arbitrary = fmap DhallDouble (oneof [ arbitrary, elements specialValues ]) +:} +-} diff --git a/src/Dhall/Core.hs-boot b/src/Dhall/Core.hs-boot deleted file mode 100644 --- a/src/Dhall/Core.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module Dhall.Core where - -data Const - -data Var - -data Expr s a - -data Import - -denote :: Expr s a -> Expr t a diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -25,7 +25,7 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void) -import Dhall.Core (Binding(..), Chunks (..), Const(..), Expr(..), Var(..)) +import Dhall.Core (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..)) import Dhall.Binary (ToTerm) import Dhall.Map (Map) import Dhall.Set (Set) @@ -42,6 +42,9 @@ import qualified Dhall.Set import qualified Dhall.Pretty.Internal as Internal +{-| This type is a `Doc` enriched with a `same` flag to efficiently track if + any difference was detected +-} data Diff = Diff { same :: Bool @@ -185,8 +188,8 @@ diffNatural :: Natural -> Natural -> Diff diffNatural = diffPrimitive (token . Internal.prettyNatural) -diffDouble :: Double -> Double -> Diff -diffDouble = diffPrimitive (token . Internal.prettyDouble) +diffDouble :: DhallDouble -> DhallDouble -> Diff +diffDouble = diffPrimitive (token . Internal.prettyDouble . getDhallDouble) diffConst :: Const -> Const -> Diff diffConst = diffPrimitive (token . Internal.prettyConst) @@ -583,6 +586,10 @@ <> operator "⫽" <> " " <> ignore +skeleton (RecordCompletion {}) = + ignore + <> operator "::" + <> ignore skeleton (Merge {}) = keyword "merge" <> " " @@ -1005,6 +1012,16 @@ diffImportExpression l r@(Embed {}) = mismatch l r diffImportExpression l r = + diffRecordCompletionExpression l r + +diffRecordCompletionExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff +diffRecordCompletionExpression (RecordCompletion aL bL) (RecordCompletion aR bR) = + diffSelectorExpression aL aR <> "::" <> diffSelectorExpression bL bR +diffRecordCompletionExpression l@(RecordCompletion {}) r = + mismatch l r +diffRecordCompletionExpression l r@(RecordCompletion {}) = + mismatch l r +diffRecordCompletionExpression l r = diffSelectorExpression l r diffSelectorExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -O #-} @@ -45,6 +49,7 @@ , Environment(..) , Val(..) , (~>) + , textShow ) where import Data.Foldable (foldr', toList) @@ -53,12 +58,12 @@ import Data.Text (Text) import Data.Void (Void) -import Dhall.Core +import Dhall.Syntax ( Binding(..) , Expr(..) , Chunks(..) , Const(..) - , Import + , DhallDouble(..) , Var(..) ) @@ -67,20 +72,22 @@ import GHC.Natural (Natural) import Prelude hiding (succ) -import qualified Codec.Serialise as Serialise +import qualified Data.Char import qualified Data.Sequence as Sequence import qualified Data.Set import qualified Data.Text as Text -import qualified Dhall.Binary as Binary -import qualified Dhall.Core as Core +import qualified Dhall.Syntax as Syntax import qualified Dhall.Map as Map import qualified Dhall.Set +import qualified Text.Printf data Environment a = Empty | Skip !(Environment a) {-# UNPACK #-} !Text | Extend !(Environment a) {-# UNPACK #-} !Text (Val a) +deriving instance (Show a, Show (Val a -> Val a)) => Show (Environment a) + errorMsg :: String errorMsg = unlines [ _ERROR <> ": Compiler bug " @@ -98,8 +105,13 @@ data Closure a = Closure !Text !(Environment a) !(Expr Void a) + +deriving instance (Show a, Show (Val a -> Val a)) => Show (Closure a) + data VChunks a = VChunks ![(Text, Val a)] !Text +deriving instance (Show a, Show (Val a -> Val a)) => Show (VChunks a) + instance Semigroup (VChunks a) where VChunks xys z <> VChunks [] z' = VChunks xys (z <> z') VChunks xys z <> VChunks ((x', y'):xys') z' = VChunks (xys ++ (z <> x', y'):xys') z' @@ -135,6 +147,8 @@ -- this information in case the @Natural/subtract@ ends up not being fully -- saturated, in which case we need to recover the unsaturated built-in +deriving instance (Show a, Show (Val a -> Val a)) => Show (HLamInfo a) + pattern VPrim :: (Val a -> Val a) -> Val a pattern VPrim f = VHLam Prim f @@ -182,7 +196,7 @@ | VIntegerToDouble !(Val a) | VDouble - | VDoubleLit !Double + | VDoubleLit !DhallDouble | VDoubleShow !(Val a) | VText @@ -221,6 +235,9 @@ | VEquivalent !(Val a) !(Val a) | VEmbed a +-- | For use with "Text.Show.Functions". +deriving instance (Show a, Show (Val a -> Val a)) => Show (Val a) + (~>) :: Val a -> Val a -> Val a (~>) a b = VHPi "_" a (\_ -> b) {-# INLINE (~>) #-} @@ -517,9 +534,10 @@ n -> VIntegerShow n IntegerToDouble -> VPrim $ \case - VIntegerLit n -> VDoubleLit (read (show n)) + VIntegerLit n -> VDoubleLit (DhallDouble (read (show n))) -- `(read . show)` is used instead of `fromInteger` - -- because `read` uses the correct rounding rule + -- because `read` uses the correct rounding rule. + -- See https://gitlab.haskell.org/ghc/ghc/issues/17231. n -> VIntegerToDouble n Double -> VDouble @@ -527,8 +545,8 @@ VDoubleLit n DoubleShow -> VPrim $ \case - VDoubleLit n -> VTextLit (VChunks [] (Text.pack (show n))) - n -> VDoubleShow n + VDoubleLit (DhallDouble n) -> VTextLit (VChunks [] (Text.pack (show n))) + n -> VDoubleShow n Text -> VText TextLit cs -> @@ -539,7 +557,7 @@ eval env (TextLit (Chunks [("", t), ("", u)] "")) TextShow -> VPrim $ \case - VTextLit (VChunks [] x) -> VTextLit (VChunks [] (Core.textShow x)) + VTextLit (VChunks [] x) -> VTextLit (VChunks [] (textShow x)) t -> VTextShow t List -> VPrim VList @@ -624,7 +642,7 @@ VPrim $ \ ~a -> VPrim $ \case VListLit t as | null as -> - VListLit t (Sequence.reverse as) + VListLit t as VListLit _ as -> VListLit Nothing (Sequence.reverse as) t -> @@ -674,6 +692,8 @@ vCombineTypes (eval env t) (eval env u) Prefer t u -> vPrefer env (eval env t) (eval env u) + RecordCompletion t u -> + eval env (Annot (Prefer (Field t "default") u) (Field t "Type")) Merge x y ma -> case (eval env x, eval env y, fmap (eval env) ma) of (VRecordLit m, VInject _ k mt, _) @@ -754,6 +774,21 @@ go _ _ = False {-# INLINE eqMaybeBy #-} +-- | Utility that powers the @Text/show@ built-in +textShow :: Text -> Text +textShow text = "\"" <> Text.concatMap f text <> "\"" + where + f '"' = "\\\"" + f '$' = "\\u0024" + f '\\' = "\\\\" + f '\b' = "\\b" + f '\n' = "\\n" + f '\r' = "\\r" + f '\t' = "\\t" + f '\f' = "\\f" + f c | c <= '\x1F' = Text.pack (Text.Printf.printf "\\u%04x" (Data.Char.ord c)) + | otherwise = Text.singleton c + conv :: forall a. Eq a => Environment a -> Val a -> Val a -> Bool conv !env t0 t0' = case (t0, t0') of @@ -836,8 +871,7 @@ (VDouble, VDouble) -> True (VDoubleLit n, VDoubleLit n') -> - Serialise.serialise (Binary.encode (DoubleLit n :: Expr Void Import)) - == Serialise.serialise (Binary.encode (DoubleLit n' :: Expr Void Import)) + n == n' (VDoubleShow t, VDoubleShow t') -> conv env t t' (VText, VText) -> @@ -928,14 +962,8 @@ convSkip x = conv (Skip env x) {-# INLINE convSkip #-} -{-| 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 (Core.denote -> t) (Core.denote -> u) = +judgmentallyEqual (Syntax.denote -> t) (Syntax.denote -> u) = conv Empty (eval Empty t) (eval Empty u) data Names @@ -961,7 +989,7 @@ VConst k -> Const k VVar !x !i -> - Var (V x (fromIntegral (countNames x env - i - 1))) + Var (V x (countNames x env - i - 1)) VApp t u -> quote env t `qApp` u VLam a (freshClosure -> (x, v, t)) -> @@ -1122,32 +1150,11 @@ -- | Normalize an expression in an environment of values. Any variable pointing out of -- the environment is treated as opaque free variable. nf :: Eq a => Environment a -> Expr s a -> Expr t a -nf !env = Core.renote . quote (envNames env) . eval env . Core.denote - -{-| 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. +nf !env = Syntax.renote . quote (envNames env) . eval env . Syntax.denote - `normalize` can also fail with `error` if you normalize an ill-typed - expression --} normalize :: Eq a => Expr s a -> Expr t a normalize = nf Empty -{-| α-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 = goEnv EmptyNames where @@ -1278,6 +1285,8 @@ CombineTypes (go t) (go u) Prefer t u -> Prefer (go t) (go u) + RecordCompletion t u -> + RecordCompletion (go t) (go u) Merge x y ma -> Merge (go x) (go y) (fmap go ma) ToMap x ma -> diff --git a/src/Dhall/Eval.hs-boot b/src/Dhall/Eval.hs-boot deleted file mode 100644 --- a/src/Dhall/Eval.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ - -module Dhall.Eval where - -import {-# SOURCE #-} Dhall.Core - -judgmentallyEqual :: Eq a => Expr s a -> Expr t a -> Bool -normalize :: Eq a => Expr s a -> Expr t a -alphaNormalize :: Expr s a -> Expr s a diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -54,8 +54,8 @@ case formatMode of Modify {..} -> case inplace of - File file -> do - (header, expr) <- Dhall.Util.getExpressionAndHeader censor (File file) + InputFile file -> do + (header, expr) <- Dhall.Util.getExpressionAndHeader censor (InputFile file) let doc = Pretty.pretty header <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) @@ -83,8 +83,8 @@ (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) Check {..} -> do originalText <- case path of - File file -> Data.Text.IO.readFile file - StandardInput -> Data.Text.IO.getContents + InputFile file -> Data.Text.IO.readFile file + StandardInput -> Data.Text.IO.getContents (header, expr) <- Dhall.Util.getExpressionAndHeader censor path diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -17,10 +17,10 @@ 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.TypeCheck (X) import Dhall.Util (Censor, Input(..)) import System.Console.ANSI (hSupportsANSI) @@ -58,7 +58,7 @@ State.evalStateT (Dhall.Import.loadWith (Embed import_)) status -- Try again without the semantic integrity check if decoding fails - let handler :: SomeException -> IO (Expr Src X) + let handler :: SomeException -> IO (Expr Src Void) handler _ = do State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status @@ -101,7 +101,7 @@ let unAnnotated = Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc) case inplace of - File f -> + InputFile f -> System.IO.withFile f System.IO.WriteMode (\handle -> do Pretty.renderIO handle unAnnotated Data.Text.IO.hPutStrLn handle "" ) @@ -142,8 +142,8 @@ -> IO () freeze inplace scope intent characterSet censor = do let directory = case inplace of - StandardInput -> "." - File file -> System.FilePath.takeDirectory file + StandardInput -> "." + InputFile file -> System.FilePath.takeDirectory file (header, parsedExpression) <- Dhall.Util.getExpressionAndHeader censor inplace diff --git a/src/Dhall/Hash.hs b/src/Dhall/Hash.hs deleted file mode 100644 --- a/src/Dhall/Hash.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | This module contains the implementation of the @dhall hash@ subcommand - -module Dhall.Hash - ( -- * Hash - hash - ) where - -import Dhall.Import (hashExpressionToCode) -import Dhall.Util (Censor, Input(..)) - -import qualified Control.Monad.Trans.State.Strict as State -import qualified Control.Exception -import qualified Dhall.Core -import qualified Dhall.Import -import qualified Dhall.TypeCheck -import qualified Dhall.Util -import qualified Data.Text.IO - --- | Implementation of the @dhall hash@ subcommand -hash :: Censor -> IO () -hash censor = do - parsedExpression <- Dhall.Util.getExpression censor StandardInput - - let status = Dhall.Import.emptyStatus "." - - resolvedExpression <- State.evalStateT (Dhall.Import.loadWith parsedExpression) status - - case Dhall.TypeCheck.typeOf resolvedExpression of - Left exception -> Control.Exception.throwIO exception - Right _ -> return () - - let normalizedExpression = - Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression) - - Data.Text.IO.putStrLn (hashExpressionToCode normalizedExpression) diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -150,7 +150,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) -import Data.Void (absurd) +import Data.Void (Void, absurd) #if MIN_VERSION_base(4,8,0) #else import Data.Traversable (traverse) @@ -178,7 +178,6 @@ import Dhall.Import.Types import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..)) -import Dhall.TypeCheck (X) import Lens.Family.State.Strict (zoom) import qualified Codec.Serialise @@ -462,7 +461,7 @@ chainedChangeMode mode (Chained (Import importHashed _)) = Chained (Import importHashed mode) --- Chain imports, also typecheck and normalize headers if applicable. +-- | Chain imports, also typecheck and normalize headers if applicable. chainImport :: Chained -> Import -> StateT Status IO Chained chainImport (Chained parent) child@(Import importHashed@(ImportHashed _ (Remote url)) _) = do url' <- normalizeHeaders url @@ -545,7 +544,7 @@ -- | Ensure that the given expression is present in the semantic cache. The -- given expression should be alpha-beta-normal. -writeExpressionToSemanticCache :: Expr Src X -> IO () +writeExpressionToSemanticCache :: Expr Src Void -> IO () writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes where bytes = encodeExpression NoVersion expression @@ -572,7 +571,7 @@ absolutePath <- Directory.makeAbsolute path return absolutePath Remote url -> do - let urlText = Dhall.Pretty.Internal.pretty (url { headers = Nothing }) + let urlText = Dhall.Core.pretty (url { headers = Nothing }) return (Text.unpack urlText) Env env -> return $ Text.unpack env Missing -> throwM (MissingImports []) @@ -646,13 +645,13 @@ Missing -> Field locationType "Missing" local@(Local _ _) -> App (Field locationType "Local") - (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty local))) + (TextLit (Chunks [] (Dhall.Core.pretty local))) remote_@(Remote _) -> App (Field locationType "Remote") - (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty remote_))) + (TextLit (Chunks [] (Dhall.Core.pretty remote_))) Env env -> App (Field locationType "Environment") - (TextLit (Chunks [] (Dhall.Pretty.Internal.pretty env))) + (TextLit (Chunks [] (Dhall.Core.pretty env))) return (ImportSemantics {..}) @@ -660,7 +659,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 X -> Dhall.Crypto.SHA256Digest +computeSemisemanticHash :: Expr Src Void -> Dhall.Crypto.SHA256Digest computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr -- Fetch encoded normal form from "semi-semantic cache" @@ -752,6 +751,7 @@ return cacheFile +-- | Warn if no cache directory is available warnAboutMissingCaches :: (MonadCatch m, Alternative m, MonadIO m) => m () warnAboutMissingCaches = warn <|> return () where warn = Data.Foldable.traverse_ (getOrCreateCacheDirectory True) ["dhall", "dhall-haskell"] @@ -926,7 +926,7 @@ loadedExpr <- loadWith headersExpression let go key₀ key₁ = do - let expected :: Expr Src X + let expected :: Expr Src Void expected = App List ( Record @@ -976,7 +976,7 @@ You can configure the desired behavior through the initial `Status` that you supply -} -loadWith :: Expr Src Import -> StateT Status IO (Expr Src X) +loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith expr₀ = case expr₀ of Embed import₀ -> do Status {..} <- State.get @@ -1082,6 +1082,7 @@ Combine a b -> Combine <$> loadWith a <*> loadWith b CombineTypes a b -> CombineTypes <$> loadWith a <*> loadWith b Prefer a b -> Prefer <$> loadWith a <*> loadWith b + RecordCompletion a b -> RecordCompletion <$> loadWith a <*> loadWith b Merge a b c -> Merge <$> loadWith a <*> loadWith b <*> mapM loadWith c ToMap a b -> ToMap <$> loadWith a <*> mapM loadWith b Field a b -> Field <$> loadWith a <*> pure b @@ -1094,12 +1095,12 @@ (Note <$> pure a <*> loadWith b) `catch` handler -- | Resolve all imports within an expression -load :: Expr Src Import -> IO (Expr Src X) +load :: Expr Src Import -> IO (Expr Src Void) load = loadRelativeTo "." UseSemanticCache -- | Resolve all imports within an expression, importing relative to the given -- directory. -loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src X) +loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) loadRelativeTo rootDirectory semanticCacheMode expression = State.evalStateT (loadWith expression) @@ -1109,7 +1110,7 @@ :: forall s . StandardVersion -- ^ `NoVersion` means to encode without the version tag - -> Expr s X + -> Expr s Void -> Data.ByteString.ByteString encodeExpression _standardVersion expression = bytesStrict where @@ -1132,7 +1133,7 @@ bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy -- | Hash a fully resolved expression -hashExpression :: Expr s X -> Dhall.Crypto.SHA256Digest +hashExpression :: Expr s Void -> Dhall.Crypto.SHA256Digest hashExpression expression = Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression) @@ -1142,7 +1143,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 X -> Text +hashExpressionToCode :: Expr s Void -> Text hashExpressionToCode expr = "sha256:" <> Text.pack (show (hashExpression expr)) @@ -1153,6 +1154,6 @@ show _ = "\nImport resolution is disabled" -- | Assert than an expression is import-free -assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src X) +assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src Void) assertNoImports expression = Dhall.Core.throws (traverse (\_ -> Left ImportResolutionDisabled) expression) 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 @@ -11,6 +11,7 @@ import Data.Map (Map) import Data.Semigroup ((<>)) import Data.Text.Prettyprint.Doc (Pretty(..)) +import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core ( Directory (..) @@ -25,7 +26,6 @@ , URL ) import Dhall.Parser (Src) -import Dhall.TypeCheck (X) import Lens.Family (LensLike') import System.FilePath (isRelative, splitDirectories) @@ -38,21 +38,28 @@ -- those are well-typed (either of type `List { header : Text, value Text}` or -- `List { mapKey : Text, mapValue Text})` and in normal form. These -- invariants are preserved by the API exposed by @Dhall.Import@. -newtype Chained = Chained { chainedImport :: Import } +newtype Chained = Chained + { chainedImport :: Import + -- ^ The underlying import + } deriving (Eq, Ord) instance Pretty Chained where pretty (Chained import_) = pretty import_ +-- | An import that has been fully interpeted data ImportSemantics = ImportSemantics - { importSemantics :: Expr Src X + { importSemantics :: Expr Src Void -- ^ The fully resolved import, typechecked and beta-normal. } -- | `parent` imports (i.e. depends on) `child` data Depends = Depends { parent :: Chained, child :: Chained } -data SemanticCacheMode = IgnoreSemanticCache | UseSemanticCache +{-| This enables or disables the semantic cache for imports protected by + integrity checks +-} +data SemanticCacheMode = IgnoreSemanticCache | UseSemanticCache deriving (Eq) -- | State threaded throughout the import process data Status = Status @@ -71,9 +78,9 @@ , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. - , _normalizer :: Maybe (ReifiedNormalizer X) + , _normalizer :: Maybe (ReifiedNormalizer Void) - , _startingContext :: Context (Expr Src X) + , _startingContext :: Context (Expr Src Void) , _semanticCacheMode :: SemanticCacheMode } @@ -112,22 +119,29 @@ , importMode = Code } +-- | Lens from a `Status` to its `_stack` field stack :: Functor f => LensLike' f Status (NonEmpty Chained) stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) +-- | Lens from a `Status` to its `_graph` field graph :: Functor f => LensLike' f Status [Depends] graph k s = fmap (\x -> s { _graph = x }) (k (_graph s)) +-- | Lens from a `Status` to its `_cache` field cache :: Functor f => LensLike' f Status (Map Chained ImportSemantics) cache k s = fmap (\x -> s { _cache = x }) (k (_cache s)) -remote :: Functor f => LensLike' f Status (URL -> StateT Status IO Data.Text.Text) +-- | Lens from a `Status` to its `_remote` field +remote + :: Functor f => LensLike' f Status (URL -> StateT Status IO Data.Text.Text) remote k s = fmap (\x -> s { _remote = x }) (k (_remote s)) -normalizer :: Functor f => LensLike' f Status (Maybe (ReifiedNormalizer X)) +-- | Lens from a `Status` to its `_normalizer` field +normalizer :: Functor f => LensLike' f Status (Maybe (ReifiedNormalizer Void)) normalizer k s = fmap (\x -> s {_normalizer = x}) (k (_normalizer s)) -startingContext :: Functor f => LensLike' f Status (Context (Expr Src X)) +-- | Lens from a `Status` to its `_startingContext` field +startingContext :: Functor f => LensLike' f Status (Context (Expr Src Void)) startingContext k s = fmap (\x -> s { _startingContext = x }) (k (_startingContext s)) diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- | This module contains the implementation of the @dhall lint@ command module Dhall.Lint @@ -6,6 +8,7 @@ , removeUnusedBindings ) where +import Control.Applicative ((<|>)) import Dhall.Core (Binding(..), Expr(..), Import, Var(..), subExpressions) import qualified Dhall.Core @@ -17,12 +20,17 @@ Currently this: * 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' -} lint :: Expr s Import -> Expr t Import -lint = Dhall.Optics.rewriteOf subExpressions removeUnusedBindings . removeLetInLet +lint = + Dhall.Optics.rewriteOf + subExpressions + (\e -> fixAsserts e <|> removeUnusedBindings e) + . removeLetInLet --- Remove unused Let bindings. +-- | Remove unused `Let` bindings. removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a) -- Don't remove assertions! removeUnusedBindings (Let (Binding _ _ _ _ _ e) _) @@ -31,6 +39,13 @@ | not (V a 0 `Dhall.Core.freeIn` d) = 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) = + Just (Let (Binding { value = Assert (Equivalent x y), .. }) body) +fixAsserts _ = + 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 @@ -22,17 +22,19 @@ import Control.Applicative (optional, (<|>)) import Control.Exception (Handler(..), SomeException) +import Control.Monad (when) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) +import Data.Void (Void) import Dhall.Core (Expr(Annot), Import, pretty) import Dhall.Freeze (Intent(..), Scope(..)) -import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..)) +import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode) import Dhall.Parser (Src) import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts) -import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError, X) -import Dhall.Util (Censor(..), Input(..)) +import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError) +import Dhall.Util (Censor(..), Input(..), Output(..)) import Dhall.Version (dhallVersionString) import Options.Applicative (Parser, ParserInfo) import System.Exit (ExitCode, exitFailure) @@ -59,10 +61,10 @@ import qualified Dhall.Diff import qualified Dhall.Format import qualified Dhall.Freeze -import qualified Dhall.Hash import qualified Dhall.Import import qualified Dhall.Import.Types import qualified Dhall.Lint +import qualified Dhall.Tags import qualified Dhall.Pretty import qualified Dhall.Repl import qualified Dhall.TypeCheck @@ -85,25 +87,46 @@ , censor :: Censor } +ignoreSemanticCache :: Mode -> Bool +ignoreSemanticCache Default {..} = semanticCacheMode == IgnoreSemanticCache +ignoreSemanticCache Resolve {..} = semanticCacheMode == IgnoreSemanticCache +ignoreSemanticCache Type {..} = semanticCacheMode == IgnoreSemanticCache +ignoreSemanticCache _ = False + -- | The subcommands for the @dhall@ executable data Mode = Default { file :: Input + , output :: Output , annotate :: Bool , alpha :: Bool , semanticCacheMode :: SemanticCacheMode , version :: Bool } | Version - | Resolve { file :: Input, resolveMode :: Maybe ResolveMode } - | Type { file :: Input, quiet :: Bool } + | Resolve + { file :: Input + , resolveMode :: Maybe ResolveMode + , semanticCacheMode :: SemanticCacheMode + } + | Type + { file :: Input + , quiet :: Bool + , semanticCacheMode :: SemanticCacheMode + } | Normalize { file :: Input , alpha :: Bool } | Repl | Format { formatMode :: Dhall.Format.FormatMode } | Freeze { inplace :: Input, all_ :: Bool, cache :: Bool } - | Hash + | Hash { file :: Input } | Diff { expr1 :: Text, expr2 :: Text } | Lint { inplace :: Input } + | Tags + { input :: Input + , output :: Output + , suffixes :: Maybe [Text] + , followSymlinks :: Bool + } | Encode { file :: Input, json :: Bool } | Decode { file :: Input, json :: Bool } | Text { file :: Input } @@ -157,11 +180,11 @@ <|> subcommand "resolve" "Resolve an expression's imports" - (Resolve <$> parseFile <*> parseResolveMode) + (Resolve <$> parseFile <*> parseResolveMode <*> parseSemanticCacheMode) <|> subcommand "type" "Infer an expression's type" - (Type <$> parseFile <*> parseQuiet) + (Type <$> parseFile <*> parseQuiet <*> parseSemanticCacheMode) <|> subcommand "normalize" "Normalize an expression" @@ -177,12 +200,16 @@ <|> subcommand "hash" "Compute semantic hashes for Dhall expressions" - (pure Hash) + (Hash <$> parseFile) <|> subcommand "lint" "Improve Dhall code by using newer language features and removing dead code" (Lint <$> parseInplace) <|> subcommand + "tags" + "Generate etags file" + (Tags <$> parseInput <*> parseTagsOutput <*> parseSuffixes <*> parseFollowSymlinks) + <|> subcommand "format" "Standard code formatter for the Dhall language" (Format <$> parseFormatMode) @@ -204,6 +231,7 @@ (Text <$> parseFile) <|> ( Default <$> parseFile + <*> parseOutput <*> parseAnnotate <*> parseAlpha <*> parseSemanticCacheMode @@ -218,7 +246,7 @@ parseFile = fmap f (optional p) where f Nothing = StandardInput - f (Just file) = File file + f (Just file) = InputFile file p = Options.Applicative.strOption ( Options.Applicative.long "file" @@ -226,6 +254,17 @@ <> Options.Applicative.metavar "FILE" ) + parseOutput = fmap f (optional p) + where + f Nothing = StandardOutput + f (Just file) = OutputFile file + + p = Options.Applicative.strOption + ( Options.Applicative.long "output" + <> Options.Applicative.help "Write result to a file instead of standard output" + <> Options.Applicative.metavar "FILE" + ) + parseAlpha = Options.Applicative.switch ( Options.Applicative.long "alpha" @@ -282,7 +321,7 @@ parseInplace = fmap f (optional p) where f Nothing = StandardInput - f (Just file) = File file + f (Just file) = InputFile file p = Options.Applicative.strOption ( Options.Applicative.long "inplace" @@ -290,6 +329,46 @@ <> Options.Applicative.metavar "FILE" ) + parseInput = fmap f (optional p) + where + f Nothing = StandardInput + f (Just path) = InputFile path + + p = Options.Applicative.strOption + ( Options.Applicative.long "path" + <> Options.Applicative.help "Index all files in path recursively. Will get list of files from STDIN if omitted." + <> Options.Applicative.metavar "PATH" + ) + + parseTagsOutput = fmap f (optional p) + where + f Nothing = OutputFile "tags" + f (Just file) = OutputFile file + + p = Options.Applicative.strOption + ( Options.Applicative.long "output" + <> Options.Applicative.help "The name of the file that the tags are written to. Defaults to \"tags\"" + <> Options.Applicative.metavar "FILENAME" + ) + + parseSuffixes = fmap f (optional p) + where + f Nothing = Just [".dhall"] + f (Just "") = Nothing + f (Just line) = Just (Data.Text.splitOn " " line) + + p = Options.Applicative.strOption + ( Options.Applicative.long "suffixes" + <> Options.Applicative.help "Index only files with suffixes. \"\" to index all files." + <> Options.Applicative.metavar "SUFFIXES" + ) + + parseFollowSymlinks = + Options.Applicative.switch + ( Options.Applicative.long "follow-symlinks" + <> Options.Applicative.help "Follow symlinks when recursing directories" + ) + parseJSONFlag = Options.Applicative.switch ( Options.Applicative.long "json" @@ -338,7 +417,7 @@ GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 let rootDirectory = \case - File f -> System.FilePath.takeDirectory f + InputFile f -> System.FilePath.takeDirectory f StandardInput -> "." let toStatus = Dhall.Import.emptyStatus . rootDirectory @@ -363,7 +442,7 @@ System.Exit.exitFailure handleTypeError e = Control.Exception.handle handleAll $ do - let _ = e :: TypeError Src X + let _ = e :: TypeError Src Void System.IO.hPutStrLn System.IO.stderr "" if explain then @@ -378,7 +457,7 @@ NoCensor -> Control.Exception.throwIO e handleImported (Imported ps e) = Control.Exception.handle handleAll $ do - let _ = e :: TypeError Src X + let _ = e :: TypeError Src Void System.IO.hPutStrLn System.IO.stderr "" if explain then Control.Exception.throwIO (Imported ps (DetailedTypeError e)) @@ -407,9 +486,9 @@ let doc = Dhall.Pretty.prettyCharacterSet characterSet expression renderDoc h doc - - Dhall.Import.warnAboutMissingCaches + when (not $ ignoreSemanticCache mode) Dhall.Import.warnAboutMissingCaches + handle $ case mode of Version -> do putStrLn dhallVersionString @@ -440,13 +519,16 @@ then Annot alphaNormalizedExpression inferredType else alphaNormalizedExpression - render System.IO.stdout annotatedExpression + case output of + StandardOutput -> render System.IO.stdout annotatedExpression + OutputFile file_ -> + System.IO.withFile file_ System.IO.WriteMode $ \h -> render h annotatedExpression Resolve { resolveMode = Just Dot, ..} -> do expression <- getExpression file (Dhall.Import.Types.Status { _graph, _stack }) <- - State.execStateT (Dhall.Import.loadWith expression) (toStatus file) + State.execStateT (Dhall.Import.loadWith expression) (toStatus file) { _semanticCacheMode = semanticCacheMode } let (rootImport :| _) = _stack imports = rootImport : map parent _graph ++ map child _graph @@ -482,7 +564,7 @@ expression <- getExpression file (Dhall.Import.Types.Status { _cache }) <- - State.execStateT (Dhall.Import.loadWith expression) (toStatus file) + State.execStateT (Dhall.Import.loadWith expression) (toStatus file) { _semanticCacheMode = semanticCacheMode } mapM_ print . fmap ( Pretty.pretty @@ -496,7 +578,7 @@ expression <- getExpression file resolvedExpression <- - Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression + Dhall.Import.loadRelativeTo (rootDirectory file) semanticCacheMode expression render System.IO.stdout resolvedExpression @@ -520,7 +602,7 @@ expression <- getExpression file resolvedExpression <- - Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression + Dhall.Import.loadRelativeTo (rootDirectory file) semanticCacheMode expression inferredType <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) @@ -554,14 +636,24 @@ Dhall.Freeze.freeze inplace scope intent characterSet censor - Hash -> do - Dhall.Hash.hash censor + Hash {..} -> do + expression <- getExpression file + resolvedExpression <- + Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression + + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) + + let normalizedExpression = + Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression) + + Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression) + Lint {..} -> do (header, expression) <- getExpressionAndHeader inplace case inplace of - File file -> do + InputFile file -> do let lintedExpression = Dhall.Lint.lint expression let doc = Pretty.pretty header @@ -601,7 +693,7 @@ Decode {..} -> do bytes <- do case file of - File f -> Data.ByteString.Lazy.readFile f + InputFile f -> Data.ByteString.Lazy.readFile f StandardInput -> Data.ByteString.Lazy.getContents term <- do @@ -639,13 +731,23 @@ Dhall.Core.TextLit (Dhall.Core.Chunks [] text) -> do Data.Text.IO.putStr text _ -> do - let invalidTypeExpected :: Expr X X + let invalidTypeExpected :: Expr Void Void invalidTypeExpected = Dhall.Core.Text - let invalidTypeExpression :: Expr X X + let invalidTypeExpression :: Expr Void Void invalidTypeExpression = normalizedExpression Control.Exception.throwIO (Dhall.InvalidType {..}) + + Tags {..} -> do + tags <- Dhall.Tags.generate input suffixes followSymlinks + + case output of + OutputFile file -> + System.IO.withFile file System.IO.WriteMode (`Data.Text.IO.hPutStr` tags) + + StandardOutput -> Data.Text.IO.putStrLn tags + -- | Entry point for the @dhall@ executable main :: IO () 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 @@ -38,6 +38,7 @@ import qualified Text.Parser.Combinators import qualified Text.Parser.Token.Style +-- | An exception annotated with a `Src` span data SourcedException e = SourcedException Src e instance Exception e => Exception (SourcedException e) 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 @@ -39,6 +39,7 @@ import Dhall.Parser.Combinators import Dhall.Parser.Token +-- | Get the current source position getSourcePos :: Text.Megaparsec.MonadParsec e s m => m Text.Megaparsec.SourcePos getSourcePos = @@ -49,6 +50,7 @@ #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 @@ -57,6 +59,7 @@ #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) -> @@ -67,6 +70,9 @@ #endif {-# INLINE setOffset #-} +{-| Wrap a `Parser` to still match the same text but return only the `Src` + span +-} src :: Parser a -> Parser Src src parser = do before <- getSourcePos @@ -74,6 +80,9 @@ after <- getSourcePos return (Src before after tokens) +{-| Wrap a `Parser` to still match the same text, but to wrap the resulting + `Expr` in a `Note` constructor containing the `Src` span +-} noted :: Parser (Expr Src a) -> Parser (Expr Src a) noted parser = do before <- getSourcePos @@ -84,21 +93,39 @@ Note src₁ _ | laxSrcEq src₀ src₁ -> return e _ -> return (Note src₀ e) +{-| Parse a complete expression (with leading and trailing whitespace) + + This corresponds to the @complete-expression@ rule from the official + grammar +-} completeExpression :: Parser a -> Parser (Expr Src a) completeExpression embedded = completeExpression_ where Parsers {..} = parsers embedded +{-| Parse an \"import expression\" + + This is not the same thing as @`fmap` `Embed`@. This parses any + expression of the same or higher precedence as an import expression (such + as a selector expression). For example, this parses @(1)@ + + This corresponds to the @import-expression@ rule from the official grammar +-} importExpression :: Parser a -> Parser (Expr Src a) importExpression embedded = importExpression_ where Parsers {..} = parsers embedded +{-| For efficiency (and simplicity) we only expose two parsers from the + result of the `parsers` function, since these are the only parsers needed + outside of this module +-} data Parsers a = Parsers { completeExpression_ :: Parser (Expr Src a) , importExpression_ :: Parser (Expr Src a) } +-- | Given a parser for imports, parsers :: Parser a -> Parsers a parsers embedded = Parsers {..} where @@ -293,8 +320,20 @@ a <- embedded return (Embed a) - alternative1 = selectorExpression + alternative1 = completionExpression + completionExpression = noted (do + a <- selectorExpression + + mb <- optional (do + _doubleColon + + selectorExpression ) + + case mb of + Nothing -> return a + Just b -> return (RecordCompletion a b) ) + selectorExpression = noted (do a <- primitiveExpression @@ -338,7 +377,7 @@ b <- if isInfinite a then setOffset n *> fail "double out of bounds" else return a - return (DoubleLit b) + return (DoubleLit (DhallDouble b)) alternative01 = do a <- try naturalLiteral @@ -352,8 +391,13 @@ alternative04 = (do _openBrace + + _ <- optional _comma + a <- recordTypeOrLiteral + _closeBrace + return a ) "record type or literal" alternative05 = unionType @@ -373,7 +417,7 @@ alternative09 = do a <- try doubleInfinity - return (DoubleLit a) + return (DoubleLit (DhallDouble a)) builtin = do let predicate c = @@ -388,7 +432,7 @@ || c == 'F' || c == 'K' - let nan = (0.0/0.0) + let nan = DhallDouble (0.0/0.0) c <- Text.Megaparsec.lookAhead (Text.Megaparsec.satisfy predicate) @@ -673,6 +717,8 @@ unionType = (do _openAngle + _ <- optional _bar + let unionTypeEntry = do a <- anyLabel b <- optional (do _colon; expression) @@ -688,10 +734,18 @@ listLiteral = (do _openBracket + + _ <- optional _comma + a <- Text.Megaparsec.sepBy expression _comma + _closeBracket return (ListLit Nothing (Data.Sequence.fromList a)) ) "list 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:" @@ -707,8 +761,9 @@ _ <- Text.Parser.Char.char '"' return a -localRaw :: Parser ImportType -localRaw = +-- | Parse a local import without trailing whitespace +localOnly :: Parser ImportType +localOnly = choice [ parentPath , herePath @@ -739,12 +794,20 @@ return (Local Absolute file) +{-| Parse a local import + + This corresponds to the @local@ rule from the official grammar +-} local :: Parser ImportType local = do - a <- localRaw + a <- localOnly whitespace return a +{-| Parse an HTTP(S) import + + This corresponds to the @http@ rule from the official grammar +-} http :: Parser ImportType http = do url <- httpRaw @@ -754,11 +817,19 @@ importExpression import_ ) return (Remote (url { headers })) +{-| Parse a `Missing` import + + This corresponds to the @missing@ rule from the official grammar +-} missing :: Parser ImportType missing = do _missing return Missing +{-| Parse an `ImportType` + + This corresponds to the @import-type@ rule from the official grammar +-} importType_ :: Parser ImportType importType_ = do let predicate c = @@ -768,6 +839,10 @@ choice [ local, http, env, missing ] +{-| Parse a `Dhall.Crypto.SHA256Digest` + + This corresponds to the @hash@ rule from the official grammar +-} importHash_ :: Parser Dhall.Crypto.SHA256Digest importHash_ = do _ <- Text.Parser.Char.text "sha256:" @@ -781,12 +856,20 @@ Nothing -> fail "Invalid sha256 hash" Just h -> pure h +{-| Parse an `ImportHashed` + + This corresponds to the @import-hashed@ rule from the official grammar +-} importHashed_ :: Parser ImportHashed importHashed_ = do importType <- importType_ hash <- optional importHash_ return (ImportHashed {..}) +{-| Parse an `Import` + + This corresponds to the @import@ rule from the official grammar +-} import_ :: Parser Import import_ = (do importHashed <- importHashed_ @@ -797,25 +880,14 @@ _as (_Text >> pure RawText) <|> (_Location >> pure Location) --- | Similar to `Dhall.Core.renderChunks` except that this doesn't bother to --- render interpolated expressions to avoid a `Buildable a` constraint. The --- interpolated contents are not necessary for computing how much to dedent a --- multi-line string --- --- This also doesn't include the surrounding quotes since they would interfere --- with the whitespace detection -renderChunks :: Chunks s a -> Text -renderChunks (Chunks a b) = foldMap renderChunk a <> b - where - renderChunk :: (Text, Expr s a) -> Text - renderChunk (c, _) = c <> "${x}" - +-- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result splitOn :: Text -> Text -> NonEmpty Text splitOn needle haystack = case Data.Text.splitOn needle haystack of [] -> "" :| [] t : ts -> t :| ts +-- | Split `Chunks` by lines linesLiteral :: Chunks s a -> NonEmpty (Chunks s a) linesLiteral (Chunks [] suffix) = fmap (Chunks []) (splitOn "\n" suffix) @@ -832,15 +904,18 @@ Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) +-- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a unlinesLiteral chunks = Data.Foldable.fold (Data.List.NonEmpty.intersperse "\n" chunks) +-- | Returns `True` if the `Chunks` represents a blank line emptyLine :: Chunks s a -> Bool emptyLine (Chunks [] "" ) = True emptyLine (Chunks [] "\r") = True -- So that `\r\n` is treated as a blank line emptyLine _ = False +-- | Return the leading whitespace for a `Chunks` literal leadingSpaces :: Chunks s a -> Text leadingSpaces chunks = Data.Text.takeWhile isSpace firstText where @@ -851,12 +926,16 @@ Chunks [] suffix -> suffix Chunks ((prefix, _) : _ ) _ -> prefix +-- | Drop the first @n@ characters for a `Chunks` literal dropLiteral :: Int -> Chunks s a -> Chunks s a dropLiteral n (Chunks [] suffix) = Chunks [] (Data.Text.drop n suffix) dropLiteral n (Chunks ((prefix, interpolation) : rest) suffix) = Chunks ((Data.Text.drop n prefix, interpolation) : rest) suffix +{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted + `Chunks` literal +-} toDoubleQuoted :: Chunks Src a -> Chunks Src a toDoubleQuoted literal = unlinesLiteral (fmap (dropLiteral indent) literals) 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 @@ -103,6 +103,7 @@ _lambda, _forall, _arrow, + _doubleColon, ) where import Dhall.Parser.Combinators @@ -133,15 +134,24 @@ import qualified Text.Parser.Token +-- | Returns `True` if the given `Char` is a valid Unicode codepoint validCodepoint :: Char -> Bool validCodepoint c = not (category == Char.Surrogate || category == Char.NotAssigned) where category = Char.generalCategory c +{-| Parse 0 or more whitespace characters (including comments) + + This corresponds to the @whsp@ rule in the official grammar +-} whitespace :: Parser () whitespace = Text.Parser.Combinators.skipMany whitespaceChunk +{-| Parse 1 or more whitespace characters (including comments) + + This corresponds to the @whsp1@ rule in the official grammar +-} nonemptyWhitespace :: Parser () nonemptyWhitespace = Text.Parser.Combinators.skipSome whitespaceChunk @@ -154,6 +164,10 @@ alphaNum :: Char -> Bool alphaNum c = alpha c || digit c +{-| Parse a hex digit (uppercase or lowercase) + + This corresponds to the @HEXDIG@ rule in the official grammar +-} hexdig :: Char -> Bool hexdig c = ('0' <= c && c <= '9') @@ -166,12 +180,21 @@ let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') positive <|> negative ) "sign" +{-| Parse a `Double` literal + + This corresponds to the @double-literal@ rule from the official grammar +-} doubleLiteral :: Parser Double doubleLiteral = (do sign <- signPrefix <|> pure id a <- Text.Parser.Token.double return (sign a) ) "double literal" +{-| Parse a signed @Infinity@ + + This corresponds to the @minus-infinity-literal@ and @plus-infinity-literal@ + rules from the official grammar +-} doubleInfinity :: Parser Double doubleInfinity = (do let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') @@ -179,6 +202,10 @@ a <- Text.Parser.Char.text "Infinity" >> whitespace >> return (1.0/0.0) return (sign a) ) "double infinity" +{-| Parse an `Integer` literal + + This corresponds to the @integer-literal@ rule from the official grammar +-} integerLiteral :: Parser Integer integerLiteral = (do sign <- signPrefix @@ -186,12 +213,22 @@ whitespace return (sign a) ) "integer literal" +{-| Parse a `Natural` literal + + This corresponds to the @natural-literal@ rule from the official grammar +-} naturalLiteral :: Parser Natural naturalLiteral = (do a <- Text.Megaparsec.Char.Lexer.decimal whitespace return a ) "natural literal" +{-| Parse an identifier (i.e. a variable or built-in) + + Variables can have an optional index to disambiguate shadowed variables + + This corresponds to the @identifier@ rule from the official grammar +-} identifier :: Parser Var identifier = do x <- label @@ -216,6 +253,7 @@ where predicate c = c == ' ' || c == '\t' || c == '\n' +-- | Parse a hexademical number and convert to the corresponding `Int` hexNumber :: Parser Int hexNumber = choice [ hexDigit, hexUpper, hexLower ] where @@ -312,6 +350,12 @@ '\x20' <= c && c <= '\x5F' || '\x61' <= c && c <= '\x7E' +{-| Parse a braced sequence of comma-separated labels + + For example, this is used to parse the record projection syntax + + This corresponds to the @labels@ rule in the official grammar +-} labels :: Parser (Set Text) labels = do _openBrace @@ -326,22 +370,37 @@ xs <- many (do _ <- _comma; anyLabel) 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@) + + This corresponds to the @nonreserved-label@ rule in the official grammar +-} label :: Parser Text label = (do t <- backtickLabel <|> simpleLabel False whitespace return t ) "label" +{-| Same as `label` except that built-in names are allowed + + This corresponds to the @any-label@ rule in the official grammar +-} anyLabel :: Parser Text anyLabel = (do t <- backtickLabel <|> simpleLabel True whitespace return t ) "any label" +{-| Parse a valid Bash environment variable name + + This corresponds to the @bash-environment-variable@ rule in the official + grammar +-} bashEnvironmentVariable :: Parser Text bashEnvironmentVariable = satisfy predicate0 <> star (satisfy predicate1) where @@ -349,6 +408,12 @@ predicate1 c = alphaNum c || c == '_' +{-| Parse a valid POSIX environment variable name, which permits a wider range + of characters than a Bash environment variable name + + This corresponds to the @posix-environment-variable@ rule in the official + grammar +-} posixEnvironmentVariable :: Parser Text posixEnvironmentVariable = plus posixEnvironmentVariableCharacter @@ -385,8 +450,12 @@ || ('\x23' <= c && c <= '\x2E') || ('\x30' <= c && c <= '\x10FFFF') +{-| The `pathComponent` function uses this type to distinguish whether to parse + a URL path component or a file path component +-} data ComponentType = URLComponent | FileComponent +-- | Parse a path component pathComponent :: ComponentType -> Parser Text pathComponent componentType = do _ <- "/" :: Parser Text @@ -411,6 +480,7 @@ quotedPathData <|> pathData +-- | Parse a `File` file_ :: ComponentType -> Parser File file_ componentType = do let emptyPath = @@ -431,6 +501,10 @@ *> ((("s" :: Parser Text) *> pure HTTPS) <|> pure HTTP) <* ("://" :: Parser Text) +{-| Parse an HTTP(S) URL without trailing whitespace + + This corresponds to the @http-raw@ rule in the official grammar +-} httpRaw :: Parser URL httpRaw = do scheme <- scheme_ @@ -590,248 +664,468 @@ keyword :: Data.Text.Text -> Parser () keyword x = try (do _ <- Text.Parser.Char.text x; nonemptyWhitespace) +{-| Parse the @if@ keyword + + This corresponds to the @if@ rule from the official grammar +-} _if :: Parser () _if = keyword "if" +{-| Parse the @then@ keyword + + This corresponds to the @then@ rule from the official grammar +-} _then :: Parser () _then = keyword "then" +{-| Parse the @else@ keyword + + This corresponds to the @else@ rule from the official grammar +-} _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 +-} _let :: Parser () _let = keyword "let" +{-| Parse the @in@ keyword + + This corresponds to the @in@ rule from the official grammar +-} _in :: Parser () _in = keyword "in" +{-| Parse the @as@ keyword + + This corresponds to the @as@ rule from the official grammar +-} _as :: Parser () _as = keyword "as" +{-| Parse the @using@ keyword + + This corresponds to the @using@ rule from the official grammar +-} _using :: Parser () _using = keyword "using" +{-| Parse the @merge@ keyword + + This corresponds to the @merge@ rule from the official grammar +-} _merge :: Parser () _merge = keyword "merge" +{-| Parse the @toMap@ keyword + + This corresponds to the @toMap@ rule from the official grammar +-} _toMap :: Parser () _toMap = keyword "toMap" +{-| Parse the @assert@ keyword + + This corresponds to the @assert@ rule from the official grammar +-} _assert :: Parser () _assert = keyword "assert" +{-| Parse the @Some@ built-in + + This corresponds to the @Some@ rule from the official grammar +-} _Some :: Parser () _Some = keyword "Some" +{-| Parse the @None@ built-in + + This corresponds to the @None@ rule from the official grammar +-} _None :: Parser () _None = reserved "None" +{-| Parse the @Natural/fold@ built-in + + This corresponds to the @Natural-fold@ rule from the official grammar +-} _NaturalFold :: Parser () _NaturalFold = reserved "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" +{-| Parse the @Natural/isZero@ built-in + + This corresponds to the @Natural-isZero@ rule from the official grammar +-} _NaturalIsZero :: Parser () _NaturalIsZero = reserved "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" +{-| Parse the @Natural/odd@ built-in + + This corresponds to the @Natural-odd@ rule from the official grammar +-} _NaturalOdd :: Parser () _NaturalOdd = reserved "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" +{-| Parse the @Natural/show@ built-in + + This corresponds to the @Natural-show@ rule from the official grammar +-} _NaturalShow :: Parser () _NaturalShow = reserved "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" +{-| Parse the @Integer/show@ built-in + + This corresponds to the @Integer-show@ rule from the official grammar +-} _IntegerShow :: Parser () _IntegerShow = reserved "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" +{-| Parse the @Double/show@ built-in + + This corresponds to the @Double-show@ rule from the official grammar +-} _DoubleShow :: Parser () _DoubleShow = reserved "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" +{-| Parse the @List/fold@ built-in + + This corresponds to the @List-fold@ rule from the official grammar +-} _ListFold :: Parser () _ListFold = reserved "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" +{-| Parse the @List/head@ built-in + + This corresponds to the @List-head@ rule from the official grammar +-} _ListHead :: Parser () _ListHead = reserved "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" +{-| Parse the @List/indexed@ built-in + + This corresponds to the @List-indexed@ rule from the official grammar +-} _ListIndexed :: Parser () _ListIndexed = reserved "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" +{-| Parse the @Optional/fold@ built-in + + This corresponds to the @Optional-fold@ rule from the official grammar +-} _OptionalFold :: Parser () _OptionalFold = reserved "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" +{-| Parse the @Bool@ built-in + + This corresponds to the @Bool@ rule from the official grammar +-} _Bool :: Parser () _Bool = reserved "Bool" +{-| Parse the @Optional@ built-in + + This corresponds to the @Optional@ rule from the official grammar +-} _Optional :: Parser () _Optional = reserved "Optional" +{-| Parse the @Natural@ built-in + + This corresponds to the @Natural@ rule from the official grammar +-} _Natural :: Parser () _Natural = reserved "Natural" +{-| Parse the @Integer@ built-in + + This corresponds to the @Integer@ rule from the official grammar +-} _Integer :: Parser () _Integer = reserved "Integer" +{-| Parse the @Double@ built-in + + This corresponds to the @Double@ rule from the official grammar +-} _Double :: Parser () _Double = reserved "Double" +{-| Parse the @Text@ built-in + + This corresponds to the @Text@ rule from the official grammar +-} _Text :: Parser () _Text = reserved "Text" +{-| Parse the @Text/show@ built-in + + This corresponds to the @Text-show@ rule from the official grammar +-} _TextShow :: Parser () _TextShow = reserved "Text/show" +{-| Parse the @List@ built-in + + This corresponds to the @List@ rule from the official grammar +-} _List :: Parser () _List = reserved "List" +{-| Parse the @True@ built-in + + This corresponds to the @True@ rule from the official grammar +-} _True :: Parser () _True = reserved "True" +{-| Parse the @False@ built-in + + This corresponds to the @False@ rule from the official grammar +-} _False :: Parser () _False = reserved "False" +{-| Parse a @NaN@ literal + + This corresponds to the @NaN@ rule from the official grammar +-} _NaN :: Parser () _NaN = reserved "NaN" +{-| Parse the @Type@ built-in + + This corresponds to the @Type@ rule from the official grammar +-} _Type :: Parser () _Type = reserved "Type" +{-| Parse the @Kind@ built-in + + This corresponds to the @Kind@ rule from the official grammar +-} _Kind :: Parser () _Kind = reserved "Kind" +{-| Parse the @Sort@ built-in + + This corresponds to the @Sort@ rule from the official grammar +-} _Sort :: Parser () _Sort = reserved "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 '=' +-- | Parse the @=@ symbol _equal :: Parser () _equal = reservedChar '=' +-- | Parse the @||@ symbol _or :: Parser () _or = reserved "||" +-- | Parse the @+@ symbol _plus :: Parser () _plus = reservedChar '+' +-- | Parse the @++@ symbol _textAppend :: Parser () _textAppend = reserved "++" +-- | Parse the @#@ symbol _listAppend :: Parser () _listAppend = reservedChar '#' +-- | Parse the @&&@ symbol _and :: Parser () _and = reserved "&&" +-- | Parse the @*@ symbol _times :: Parser () _times = reservedChar '*' +-- | Parse the @==@ symbol _doubleEqual :: Parser () _doubleEqual = reserved "==" +-- | Parse the @!=@ symbol _notEqual :: Parser () _notEqual = reserved "!=" +-- | Parse the @.@ symbol _dot :: Parser () _dot = reservedChar '.' +-- | Parse the @{@ symbol _openBrace :: Parser () _openBrace = reservedChar '{' +-- | Parse the @}@ symbol _closeBrace :: Parser () _closeBrace = reservedChar '}' +-- | Parse the @[@] symbol _openBracket :: Parser () _openBracket = reservedChar '[' +-- | Parse the @]@ symbol _closeBracket :: Parser () _closeBracket = reservedChar ']' +-- | Parse the @<@ symbol _openAngle :: Parser () _openAngle = reservedChar '<' +-- | Parse the @>@ symbol _closeAngle :: Parser () _closeAngle = reservedChar '>' +-- | Parse the @|@ symbol _bar :: Parser () _bar = reservedChar '|' +-- | Parse the @,@ symbol _comma :: Parser () _comma = reservedChar ',' +-- | Parse the @(@ symbol _openParens :: Parser () _openParens = reservedChar '(' +-- | Parse the @)@ symbol _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 '@' +-- | Parse the equivalence symbol (@===@ or @≡@) _equivalent :: Parser () _equivalent = do void (Text.Parser.Char.char '≡' "\"≡\"") <|> void (Text.Parser.Char.text "===") whitespace +-- | Parse the @missing@ keyword _missing :: Parser () -_missing = reserved "missing" +_missing = keyword "missing" +-- | Parse the @?@ symbol _importAlt :: Parser () _importAlt = reservedChar '?' +-- | Parse the record combine operator (@/\\@ or @∧@) _combine :: Parser () _combine = do void (Text.Parser.Char.char '∧' "\"∧\"") <|> void (Text.Parser.Char.text "/\\") whitespace +-- | Parse the record type combine operator (@//\\\\@ or @⩓@) _combineTypes :: Parser () _combineTypes = do void (Text.Parser.Char.char '⩓' "\"⩓\"") <|> void (Text.Parser.Char.text "//\\\\") whitespace +-- | Parse the record \"prefer\" operator (@//@ or @⫽@) _prefer :: Parser () _prefer = do void (Text.Parser.Char.char '⫽' "\"⫽\"") <|> void (Text.Parser.Char.text "//") whitespace +-- | Parse a lambda (@\\@ or @λ@) _lambda :: Parser () _lambda = do _ <- Text.Parser.Char.satisfy predicate @@ -841,12 +1135,18 @@ predicate '\\' = True predicate _ = False +-- | Parse a forall (@forall@ or @∀@) _forall :: Parser () _forall = do void (Text.Parser.Char.char '∀' "\"∀\"") <|> void (Text.Parser.Char.text "forall") whitespace +-- | Parse a right arrow (@->@ or @→@) _arrow :: Parser () _arrow = do void (Text.Parser.Char.char '→' "\"→\"") <|> void (Text.Parser.Char.text "->") whitespace + +-- | Parse a double colon (@::@) +_doubleColon :: Parser () +_doubleColon = reserved "::" 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,8 +19,8 @@ , prettyCharacterSet , prettyVar - , pretty - , escapeText + , pretty_ + , escapeText_ , prettyConst , prettyLabel @@ -58,8 +59,6 @@ , rparen ) where -import Dhall.Core - #if MIN_VERSION_base(4,8,0) #else import Control.Applicative (Applicative(..), (<$>)) @@ -71,6 +70,7 @@ import Dhall.Map (Map) import Dhall.Set (Set) import Dhall.Src (Src(..)) +import Dhall.Syntax import Numeric.Natural (Natural) import Prelude hiding (succ) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal @@ -108,6 +108,7 @@ annToAnsiStyle Builtin = Terminal.underlined annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green +-- | This type determines whether to render code as `ASCII` or `Unicode` data CharacterSet = ASCII | Unicode -- | Pretty print an expression @@ -138,29 +139,28 @@ >>> let unusedSourcePos = Text.Megaparsec.SourcePos "" (Text.Megaparsec.mkPos 1) (Text.Megaparsec.mkPos 1) >>> let nonEmptySrc = Src unusedSourcePos unusedSourcePos "-- Documentation for x\n" - >>> "let" <> renderSrc (Just nonEmptySrc) " " <> "x = 1 in x" + >>> "let" <> " " <> renderSrc id (Just nonEmptySrc) <> "x = 1 in x" let -- Documentation for x x = 1 in x >>> let emptySrc = Src unusedSourcePos unusedSourcePos " " - >>> "let" <> renderSrc (Just emptySrc) " " <> "x = 1 in x" + >>> "let" <> " " <> renderSrc id (Just emptySrc) <> "x = 1 in x" let x = 1 in x - >>> "let" <> renderSrc Nothing " " <> "x = 1 in x" + >>> "let" <> " " <> renderSrc id Nothing <> "x = 1 in x" let x = 1 in x -} renderSrc - :: Maybe Src + :: (Text -> Text) + -- ^ Used to preprocess the comment string (e.g. to strip whitespace) + -> Maybe Src -- ^ Source span to render (if present) -> Doc Ann - -- ^ Used as the prefix (when the source span contains a comment) and as a - -- fallback (when the source span is absent or comment-free) - -> Doc Ann -renderSrc (Just (Src {..})) prefix +renderSrc strip (Just (Src {..})) | not (Text.all isWhitespace srcText) = - prefix <> Pretty.align (Pretty.concatWith f newLines <> suffix) + Pretty.align (Pretty.concatWith f newLines <> suffix) where horizontalSpace c = c == ' ' || c == '\t' - strippedText = Text.dropAround horizontalSpace srcText + strippedText = strip srcText suffix = if Text.null strippedText @@ -195,8 +195,8 @@ in Pretty.pretty l0 : map perLine (l1 : ls) f x y = x <> Pretty.hardline <> y -renderSrc _ prefix = - prefix +renderSrc _ _ = + mempty -- Annotation helpers keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann @@ -236,6 +236,9 @@ rarrow Unicode = syntax "→" rarrow ASCII = syntax "->" +doubleColon :: Doc Ann +doubleColon = syntax "::" + -- | Pretty-print a list list :: [Doc Ann] -> Doc Ann list [] = lbracket <> rbracket @@ -275,6 +278,30 @@ rbrace docs +hangingBraces :: [(Doc Ann, Doc Ann)] -> Doc Ann +hangingBraces [] = + lbrace <> rbrace +hangingBraces docs = + Pretty.group + (Pretty.flatAlt + ( lbrace + <> Pretty.hardline + <> mconcat (zipWith combineLong (repeat separator) docsLong) + <> rbrace + ) + (mconcat (zipWith (<>) (beginShort : repeat separator) docsShort) <> space <> rbrace) + ) + where + separator = comma <> space + + docsShort = fmap fst docs + + docsLong = fmap snd docs + + beginShort = lbrace <> space + + combineLong x y = x <> y <> Pretty.hardline + -- | Pretty-print anonymous functions and function types arrows :: CharacterSet -> [(Doc Ann, Doc Ann)] -> Doc Ann arrows ASCII = @@ -430,6 +457,17 @@ prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyInt n)) +{- 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 + exactly matches the relationship between parsers. This leads to the nice emergent + property of automatically getting all the parentheses and precedences right. + + This approach has one major disadvantage: you can get an infinite loop if + you add a new constructor to the syntax tree without adding a matching + case the corresponding builder. +-} + {-| Pretty-print an 'Expr' using the given 'CharacterSet'. 'prettyCharacterSet' largely ignores 'Note's. 'Note's do however matter for @@ -519,37 +557,40 @@ where MultiLet as b = multiLet a0 b0 + stripSpaces = Text.dropAround (\c -> c == ' ' || c == '\t') + + -- Strip a single newline character. Needed to ensure idempotency in + -- cases where we add hard line breaks. + stripNewline t = + case Text.uncons t' of + Just ('\n', t'') -> stripSpaces t'' + _ -> t' + where t' = stripSpaces t + docA (Binding src0 c src1 Nothing src2 e) = Pretty.group (Pretty.flatAlt long short) where long = keyword "let" <> space <> Pretty.align - ( renderSrc src0 mempty - <> prettyLabel c <> renderSrc src1 space - <> equals <> renderSrc src2 Pretty.hardline + ( renderSrc stripSpaces src0 + <> prettyLabel c <> space <> renderSrc stripSpaces src1 + <> equals <> Pretty.hardline <> renderSrc stripNewline src2 <> " " <> prettyExpression e ) - short = keyword "let" <> renderSrc src0 space - <> prettyLabel c <> renderSrc src1 space - <> equals <> renderSrc src2 space + short = keyword "let" <> space <> renderSrc stripSpaces src0 + <> prettyLabel c <> space <> renderSrc stripSpaces src1 + <> equals <> space <> renderSrc stripSpaces src2 <> prettyExpression e docA (Binding src0 c src1 (Just (src3, d)) src2 e) = - Pretty.group (Pretty.flatAlt long short) - where - long = keyword "let" <> space - <> Pretty.align - ( renderSrc src0 mempty - <> prettyLabel c <> renderSrc src1 Pretty.hardline - <> colon <> renderSrc src3 space <> prettyExpression d <> Pretty.hardline <> equals <> renderSrc src2 space - <> prettyExpression e - ) - - short = keyword "let" <> renderSrc src0 space - <> prettyLabel c <> renderSrc src1 space - <> colon <> renderSrc src3 space - <> prettyExpression d <> space <> equals <> renderSrc src2 space + keyword "let" <> space + <> Pretty.align + ( renderSrc stripSpaces src0 + <> prettyLabel c <> Pretty.hardline <> renderSrc stripNewline src1 + <> colon <> space <> renderSrc stripSpaces src3 <> prettyExpression d <> Pretty.hardline + <> equals <> space <> renderSrc stripSpaces src2 <> prettyExpression e + ) docB = ( keyword "in" <> " " <> prettyExpression b @@ -616,22 +657,6 @@ <> prettyImportExpression b <> space <> colon <> space <> prettyApplicationExpression c - prettyAnnotatedExpression (Merge a b Nothing) = - Pretty.group (Pretty.flatAlt long short) - where - long = - Pretty.align - ( keyword "merge" - <> Pretty.hardline - <> Pretty.indent 2 (prettyImportExpression a) - <> Pretty.hardline - <> Pretty.indent 2 (prettyImportExpression b) - ) - - short = keyword "merge" <> space - <> prettyImportExpression a - <> " " - <> prettyImportExpression b prettyAnnotatedExpression (ToMap a (Just b)) = Pretty.group (Pretty.flatAlt long short) where @@ -649,18 +674,6 @@ <> prettyImportExpression a <> space <> colon <> space <> prettyApplicationExpression b - prettyAnnotatedExpression (ToMap a Nothing) = - Pretty.group (Pretty.flatAlt long short) - where - long = - Pretty.align - ( keyword "toMap" - <> Pretty.hardline - <> Pretty.indent 2 (prettyImportExpression a) - ) - - short = keyword "toMap" <> space - <> prettyImportExpression a prettyAnnotatedExpression a0@(Annot _ _) = enclose' "" @@ -854,18 +867,23 @@ prettyApplicationExpression a0 prettyApplicationExpression :: Pretty a => Expr Src a -> Doc Ann - prettyApplicationExpression a0 = case a0 of - App _ _ -> result - Some _ -> result - Note _ b -> prettyApplicationExpression b - _ -> prettyImportExpression a0 + prettyApplicationExpression = go [] where - result = enclose' "" "" " " "" (reverse (docs a0)) + go args = \case + App a b -> go (b : args) a + Some a -> app (builtin "Some") (a : args) + Merge a b Nothing -> app (keyword "merge") (a : b : args) + ToMap a Nothing -> app (keyword "toMap") (a : args) + Note _ b -> go args b + e | null args -> prettyImportExpression e -- just a performance optimization + | otherwise -> app (prettyImportExpression e) args - docs (App a b) = ( prettyImportExpression b, Pretty.indent 2 (prettyImportExpression b) ) : docs a - docs (Some a) = map duplicate [ prettyImportExpression a , builtin "Some" ] - docs (Note _ b) = docs b - docs b = map duplicate [ prettyImportExpression b ] + app f args = + enclose' + "" "" " " "" + ( duplicate f + : map (fmap (Pretty.indent 2) . duplicate . prettyImportExpression) args + ) prettyImportExpression :: Pretty a => Expr Src a -> Doc Ann prettyImportExpression (Embed a) = @@ -873,6 +891,24 @@ prettyImportExpression (Note _ a) = prettyImportExpression a prettyImportExpression a0 = + prettyCompletionExpression a0 + + prettyCompletionExpression :: Pretty a => Expr Src a -> Doc Ann + prettyCompletionExpression (RecordCompletion a b) = + case shallowDenote b of + RecordLit kvs -> + Pretty.align + ( prettySelectorExpression a + <> doubleColon + <> prettyCompletionLit kvs + ) + _ -> prettySelectorExpression a + <> doubleColon + <> prettySelectorExpression b + + prettyCompletionExpression (Note _ a) = + prettyCompletionExpression a + prettyCompletionExpression a0 = prettySelectorExpression a0 prettySelectorExpression :: Pretty a => Expr Src a -> Doc Ann @@ -963,7 +999,7 @@ | otherwise = prettyNumber a prettyPrimitiveExpression (NaturalLit a) = prettyNatural a - prettyPrimitiveExpression (DoubleLit a) = + prettyPrimitiveExpression (DoubleLit (DhallDouble a)) = prettyDouble a prettyPrimitiveExpression (TextLit a) = prettyChunks a @@ -1011,9 +1047,17 @@ prettyRecordLit a | Data.Foldable.null a = lbrace <> equals <> rbrace - | otherwise - = braces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + | otherwise = + braces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + prettyCompletionLit + :: Pretty a => Map Text (Expr Src a) -> Doc Ann + prettyCompletionLit a + | Data.Foldable.null a = + lbrace <> equals <> rbrace + | otherwise = + hangingBraces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + prettyAlternative (key, Just val) = prettyKeyValue colon (key, val) prettyAlternative (key, Nothing ) = duplicate (prettyAnyLabel key) @@ -1060,11 +1104,11 @@ <> prettyExpression d <> syntax rbrace - prettyText t = literal (Pretty.pretty (escapeText t)) + prettyText t = literal (Pretty.pretty (escapeText_ t)) -- | Pretty-print a value -pretty :: Pretty a => a -> Text -pretty = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty +pretty_ :: Pretty a => a -> Text +pretty_ = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty where options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } @@ -1083,8 +1127,8 @@ Note that the result does not include surrounding quotes -} -escapeText :: Text -> Text -escapeText text = Text.concatMap adapt text +escapeText_ :: Text -> Text +escapeText_ text = Text.concatMap adapt text where adapt c | '\x20' <= c && c <= '\x21' = Text.singleton c 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,9 +1,8 @@ module Dhall.Pretty.Internal where -import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty, Doc) -import {-# SOURCE #-} Dhall.Core +import {-# SOURCE #-} Dhall.Syntax data Ann @@ -12,7 +11,3 @@ prettyConst :: Const -> Doc Ann prettyExpr :: Pretty a => Expr s a -> Doc Ann - -pretty :: Pretty a => a -> Text - -escapeText :: Text -> Text diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -22,6 +22,7 @@ import Data.Maybe ( mapMaybe ) import Data.Semigroup ((<>)) import Data.Text ( Text ) +import Data.Void (Void) import Dhall.Context (Context) import Dhall.Import (hashExpressionToCode) import Dhall.Src (Src) @@ -100,8 +101,8 @@ data Binding = Binding - { bindingExpr :: Dhall.Expr Dhall.Src Dhall.X - , bindingType :: Dhall.Expr Dhall.Src Dhall.X + { bindingExpr :: Dhall.Expr Dhall.Src Void + , bindingType :: Dhall.Expr Dhall.Src Void } @@ -116,7 +117,7 @@ parseAndLoad - :: MonadIO m => String -> m ( Dhall.Expr Dhall.Src Dhall.X ) + :: MonadIO m => String -> m ( Dhall.Expr Dhall.Src Void) parseAndLoad src = do parsed <- case Dhall.exprFromText "(stdin)" ( Text.pack src ) of @@ -158,16 +159,13 @@ exprType <- typeCheck loaded - exprType' <- - normalize exprType - - output exprType' + output exprType applyContext :: Context Binding - -> Dhall.Expr Dhall.Src Dhall.X - -> Dhall.Expr Dhall.Src Dhall.X + -> Dhall.Expr Dhall.Src Void + -> Dhall.Expr Dhall.Src Void applyContext context expression = Dhall.Core.wrapInLets bindings expression where @@ -180,7 +178,7 @@ normalize :: MonadState Env m - => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr t Dhall.X ) + => Dhall.Expr Dhall.Src Void -> m ( Dhall.Expr t Void ) normalize e = do env <- get @@ -189,7 +187,7 @@ typeCheck :: ( MonadIO m, MonadState Env m ) - => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr Dhall.Src Dhall.X ) + => Dhall.Expr Dhall.Src Void -> m ( Dhall.Expr Dhall.Src Void ) typeCheck expression = do env <- get @@ -546,7 +544,7 @@ listCompletion = map simpleCompletion . filter (word `isPrefixOf`) algebraicComplete - :: [Text.Text] -> Dhall.Expr Dhall.Src Dhall.X -> [Text.Text] + :: [Text.Text] -> Dhall.Expr Dhall.Src Void -> [Text.Text] algebraicComplete subFields expr = let keys = fmap ("." <>) . Map.keys diff --git a/src/Dhall/Set.hs b/src/Dhall/Set.hs --- a/src/Dhall/Set.hs +++ b/src/Dhall/Set.hs @@ -35,9 +35,13 @@ import qualified Data.Sequence import qualified Data.Foldable --- Invariant: In @Set set seq@, @toAscList set == sort (toList seq)@. +{-| This is a variation on @"Data.Set".`Data.Set.Set`@ that remembers the + original order of elements. This ensures that ordering is not lost when + formatting Dhall code +-} data Set a = Set (Data.Set.Set a) (Seq a) deriving (Generic, Show, Data, NFData) +-- Invariant: In @Set set seq@, @toAscList set == sort (toList seq)@. instance Eq a => Eq (Set a) where (Set _ x) == (Set _ y) = x == y @@ -53,30 +57,37 @@ foldMap f (Set _ x) = foldMap f x {-# INLINABLE foldMap #-} +-- | Convert to an unordered @"Data.Set".`Data.Set.Set`@ toSet :: Set a -> Data.Set.Set a toSet (Set s _) = s +-- | Convert to an ordered `Seq` toSeq :: Set a -> Seq a toSeq (Set _ xs) = xs +-- | Convert a `Set` to a list, preserving the original order of the elements toList :: Set a -> [a] toList = Data.Foldable.toList +-- | Convert a list to a `Set`, remembering the element order +fromList :: Ord a => [a] -> Set a +fromList = foldl' (flip append) empty -- O(n log n) time complexity, O(n) space complexity. -- Implementing it this way is a little silly, but is faster than (nub xs). -- n.b. toList . fromList = id, only if the list elements are unique -fromList :: Ord a => [a] -> Set a -fromList = foldl' (flip append) empty +-- | Convert a @"Data.Set".`Data.Set.Set`@ to a sorted `Set` fromSet :: Data.Set.Set a -> Set a fromSet s = Set s (Data.Sequence.fromList (Data.Set.elems s)) --- O(log n) time complexity. +-- | Append an element to the end of a `Set` append :: Ord a => a -> Set a -> Set a append x os@(Set s xs) | Data.Set.member x s = os | otherwise = Set (Data.Set.insert x s) (xs |> x) +-- O(log n) time complexity. +-- | The empty `Set` empty :: Set a empty = Set Data.Set.empty Data.Sequence.empty diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Syntax.hs @@ -0,0 +1,1182 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UnicodeSyntax #-} + +{-| This module contains the core syntax types and optics for them. + +'reservedIdentifiers', 'denote' and friends are included because they are +involved in a dependency circle with "Dhall.Pretty.Internal". +-} + +module Dhall.Syntax ( + -- * 'Expr' + Const(..) + , Var(..) + , Binding(..) + , makeBinding + , Chunks(..) + , DhallDouble(..) + , Expr(..) + + -- ** 'Let'-blocks + , MultiLet(..) + , multiLet + , wrapInLets + + -- ** Optics + , subExpressions + , chunkExprs + , bindingExprs + + -- ** Handling 'Note's + , denote + , renote + , shallowDenote + + -- * 'Import' + , Directory(..) + , File(..) + , FilePrefix(..) + , Import(..) + , ImportHashed(..) + , ImportMode(..) + , ImportType(..) + , URL(..) + , Scheme(..) + , pathCharacter + + -- * Reserved identifiers + , reservedIdentifiers + ) where + +import Control.DeepSeq (NFData) +import Data.Bifunctor (Bifunctor(..)) +import Data.Bits (xor) +import Data.Data (Data) +import Data.Foldable +import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.String (IsString(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, Pretty) +import Data.Traversable +import Data.Void (Void) +import Dhall.Map (Map) +import Dhall.Set (Set) +import Dhall.Src (Src(..)) +import {-# SOURCE #-} Dhall.Pretty.Internal +import GHC.Generics (Generic) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift) +import Numeric.Natural (Natural) +import Prelude hiding (succ) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Control.Monad +import qualified Data.HashSet +import qualified Data.List.NonEmpty +import qualified Data.Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Dhall.Crypto +import qualified Network.URI as URI + +{-| Constants for a pure type system + + The axioms are: + +> ⊦ Type : Kind +> ⊦ Kind : Sort + + ... and the valid rule pairs are: + +> ⊦ Type ↝ Type : Type -- Functions from terms to terms (ordinary functions) +> ⊦ Kind ↝ Type : Type -- Functions from types to terms (type-polymorphic functions) +> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms +> ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type-level functions) +> ⊦ Sort ↝ Kind : Sort -- Functions from kinds to types (kind-polymorphic functions) +> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind-level functions) + + Note that Dhall does not support functions from terms to types and therefore + Dhall is not a dependently typed language +-} +data Const = Type | Kind | Sort + deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, NFData) + +instance Lift Const + +instance Pretty Const where + pretty = Pretty.unAnnotate . prettyConst + +{-| Label for a bound variable + + The `Text` field is the variable's name (i.e. \"@x@\"). + + The `Int` field disambiguates variables with the same name if there are + multiple bound variables of the same name in scope. Zero refers to the + nearest bound variable and the index increases by one for each bound + variable of the same name going outward. The following diagram may help: + +> ┌──refers to──┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@0 +> +> ┌─────────────────refers to─────────────────┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x@1 + + This `Int` behaves like a De Bruijn index in the special case where all + variables have the same name. + + You can optionally omit the index if it is @0@: + +> ┌─refers to─┐ +> │ │ +> v │ +> λ(x : Type) → λ(y : Type) → λ(x : Type) → x + + Zero indices are omitted when pretty-printing `Var`s and non-zero indices + appear as a numeric suffix. +-} +data Var = V Text !Int + deriving (Data, Generic, Eq, Ord, Show, NFData) + +instance Lift Var + +instance IsString Var where + fromString str = V (fromString str) 0 + +instance Pretty Var where + pretty = Pretty.unAnnotate . prettyVar + +{- | Record the binding part of a @let@ expression. + +For example, +> let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x +will be instantiated as follows: + +* @bindingSrc0@ corresponds to the @A@ comment. +* @variable@ is @"x"@ +* @bindingSrc1@ corresponds to the @B@ comment. +* @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@. +* @bindingSrc2@ corresponds to the @D@ comment. +* @value@ corresponds to @True@. +-} +data Binding s a = Binding + { bindingSrc0 :: Maybe s + , variable :: Text + , bindingSrc1 :: Maybe s + , annotation :: Maybe (Maybe s, Expr s a) + , bindingSrc2 :: Maybe s + , value :: Expr s a + } deriving (Data, Eq, Foldable, Functor, Generic, NFData, Ord, Show, Traversable) + +instance Bifunctor Binding where + first k (Binding src0 a src1 b src2 c) = + Binding (fmap k src0) a (fmap k src1) (fmap adapt0 b) (fmap k src2) (first k c) + where + adapt0 (src3, d) = (fmap k src3, first k d) + + second = fmap + +{-| Construct a 'Binding' with no source information and no type annotation. +-} +makeBinding :: Text -> Expr s a -> Binding s a +makeBinding name = Binding Nothing name Nothing Nothing Nothing + +-- | This wrapper around 'Prelude.Double' exists for its 'Eq' instance which is +-- defined via the binary encoding of Dhall @Double@s. +newtype DhallDouble = DhallDouble { getDhallDouble :: Double } + deriving (Show, Data, NFData, Generic) + +-- | This instance satisfies all the customary 'Eq' laws except substitutivity. +-- +-- In particular: +-- +-- >>> nan = DhallDouble (0/0) +-- >>> nan == nan +-- True +-- +-- This instance is also consistent with with the binary encoding of Dhall @Double@s: +-- +-- >>> toBytes n = Codec.Serialise.serialise (Dhall.Binary.encode (n :: DhallDouble)) +-- +-- prop> \a b -> (a == b) == (toBytes a == toBytes b) +instance Eq DhallDouble where + DhallDouble a == DhallDouble b + | isNaN a && isNaN b = True + | isNegativeZero a `xor` isNegativeZero b = False + | otherwise = a == b + +-- | This instance relies on the 'Eq' instance for 'DhallDouble' but cannot +-- satisfy the customary 'Ord' laws when @NaN@ is involved. +instance Ord DhallDouble where + compare a@(DhallDouble a') b@(DhallDouble b') = + if a == b + then EQ + else compare a' b' + +-- | The body of an interpolated @Text@ literal +data Chunks s a = Chunks [(Text, Expr s a)] Text + deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData) + +instance (Lift s, Lift a, Data s, Data a) => Lift (Chunks s a) + +instance Data.Semigroup.Semigroup (Chunks s a) where + Chunks xysL zL <> Chunks [] zR = + Chunks xysL (zL <> zR) + Chunks xysL zL <> Chunks ((x, y):xysR) zR = + Chunks (xysL ++ (zL <> x, y):xysR) zR + +instance Monoid (Chunks s a) where + mempty = Chunks [] mempty + +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +instance IsString (Chunks s a) where + fromString str = Chunks [] (fromString str) + +{-| Syntax tree for expressions + + The @s@ type parameter is used to track the presence or absence of `Src` + spans: + + * If @s = `Src`@ then the code may contains `Src` spans (either in a `Noted` + constructor or inline within another constructor, like `Let`) + * If @s = `Void`@ then the code has no `Src` spans + + The @a@ type parameter is used to track the presence or absence of imports + + * If @a = `Import`@ then the code may contain unresolved `Import`s + * If @a = `Void`@ then the code has no `Import`s +-} +data Expr s a + -- | > Const c ~ c + = Const Const + -- | > Var (V x 0) ~ x + -- > Var (V x n) ~ x@n + | Var Var + -- | > Lam x A b ~ λ(x : A) -> b + | Lam Text (Expr s a) (Expr s a) + -- | > Pi "_" A B ~ A -> B + -- > Pi x A B ~ ∀(x : A) -> B + | Pi Text (Expr s a) (Expr s a) + -- | > App f a ~ f a + | App (Expr s a) (Expr s a) + -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e + -- > Let (Binding _ x _ (Just t ) _ r) e ~ let x : t = r in e + -- + -- The difference between + -- + -- > let x = a let y = b in e + -- + -- and + -- + -- > let x = a in let y = b in e + -- + -- is only an additional 'Note' around @'Let' "y" …@ in the second + -- example. + -- + -- See 'MultiLet' for a representation of let-blocks that mirrors the + -- source code more closely. + | Let (Binding s a) (Expr s a) + -- | > Annot x t ~ x : t + | Annot (Expr s a) (Expr s a) + -- | > Bool ~ Bool + | Bool + -- | > BoolLit b ~ b + | BoolLit Bool + -- | > BoolAnd x y ~ x && y + | BoolAnd (Expr s a) (Expr s a) + -- | > BoolOr x y ~ x || y + | BoolOr (Expr s a) (Expr s a) + -- | > BoolEQ x y ~ x == y + | BoolEQ (Expr s a) (Expr s a) + -- | > BoolNE x y ~ x != y + | BoolNE (Expr s a) (Expr s a) + -- | > BoolIf x y z ~ if x then y else z + | BoolIf (Expr s a) (Expr s a) (Expr s a) + -- | > Natural ~ Natural + | Natural + -- | > NaturalLit n ~ n + | NaturalLit Natural + -- | > NaturalFold ~ Natural/fold + | NaturalFold + -- | > NaturalBuild ~ Natural/build + | NaturalBuild + -- | > NaturalIsZero ~ Natural/isZero + | NaturalIsZero + -- | > NaturalEven ~ Natural/even + | NaturalEven + -- | > NaturalOdd ~ Natural/odd + | NaturalOdd + -- | > NaturalToInteger ~ Natural/toInteger + | NaturalToInteger + -- | > NaturalShow ~ Natural/show + | NaturalShow + -- | > NaturalSubtract ~ Natural/subtract + | NaturalSubtract + -- | > NaturalPlus x y ~ x + y + | NaturalPlus (Expr s a) (Expr s a) + -- | > NaturalTimes x y ~ x * y + | NaturalTimes (Expr s a) (Expr s a) + -- | > Integer ~ Integer + | Integer + -- | > IntegerLit n ~ ±n + | IntegerLit Integer + -- | > IntegerShow ~ Integer/show + | IntegerShow + -- | > IntegerToDouble ~ Integer/toDouble + | IntegerToDouble + -- | > Double ~ Double + | Double + -- | > DoubleLit n ~ n + | DoubleLit DhallDouble + -- | > DoubleShow ~ Double/show + | DoubleShow + -- | > Text ~ Text + | Text + -- | > TextLit (Chunks [(t1, e1), (t2, e2)] t3) ~ "t1${e1}t2${e2}t3" + | TextLit (Chunks s a) + -- | > TextAppend x y ~ x ++ y + | TextAppend (Expr s a) (Expr s a) + -- | > TextShow ~ Text/show + | TextShow + -- | > List ~ List + | List + -- | > ListLit (Just t ) [] ~ [] : t + -- > ListLit Nothing [x, y, z] ~ [x, y, z] + -- + -- Invariant: A non-empty list literal is always represented as + -- @ListLit Nothing xs@. + -- + -- When an annotated, non-empty list literal is parsed, it is represented + -- as + -- + -- > Annot (ListLit Nothing [x, y, z]) t ~ [x, y, z] : t + + -- Eventually we should have separate constructors for empty and non-empty + -- list literals. For now it's easier to check the invariant in @infer@. + -- See https://github.com/dhall-lang/dhall-haskell/issues/1359#issuecomment-537087234. + | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) + -- | > ListAppend x y ~ x # y + | ListAppend (Expr s a) (Expr s a) + -- | > ListBuild ~ List/build + | ListBuild + -- | > ListFold ~ List/fold + | ListFold + -- | > ListLength ~ List/length + | ListLength + -- | > ListHead ~ List/head + | ListHead + -- | > ListLast ~ List/last + | ListLast + -- | > ListIndexed ~ List/indexed + | ListIndexed + -- | > ListReverse ~ List/reverse + | ListReverse + -- | > Optional ~ Optional + | Optional + -- | > Some e ~ Some e + | Some (Expr s a) + -- | > None ~ None + | None + -- | > OptionalFold ~ Optional/fold + | OptionalFold + -- | > OptionalBuild ~ Optional/build + | OptionalBuild + -- | > Record [(k1, t1), (k2, t2)] ~ { k1 : t1, k2 : t1 } + | Record (Map Text (Expr s a)) + -- | > RecordLit [(k1, v1), (k2, v2)] ~ { k1 = v1, k2 = v2 } + | RecordLit (Map Text (Expr s a)) + -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > + | Union (Map Text (Maybe (Expr s a))) + -- | > Combine x y ~ x ∧ y + | Combine (Expr s a) (Expr s a) + -- | > CombineTypes x y ~ x ⩓ y + | CombineTypes (Expr s a) (Expr s a) + -- | > Prefer x y ~ x ⫽ y + | Prefer (Expr s a) (Expr s a) + -- | > RecordCompletion x y ~ x::y + | RecordCompletion (Expr s a) (Expr s a) + -- | > Merge x y (Just t ) ~ merge x y : t + -- > Merge x y Nothing ~ merge x y + | Merge (Expr s a) (Expr s a) (Maybe (Expr s a)) + -- | > ToMap x (Just t) ~ toMap x : t + -- > ToMap x Nothing ~ toMap x + | ToMap (Expr s a) (Maybe (Expr s a)) + -- | > Field e x ~ e.x + | Field (Expr s a) Text + -- | > Project e (Left xs) ~ e.{ xs } + -- | > Project e (Right t) ~ e.(t) + | Project (Expr s a) (Either (Set Text) (Expr s a)) + -- | > Assert e ~ assert : e + | Assert (Expr s a) + -- | > Equivalent x y ~ x ≡ y + | Equivalent (Expr s a) (Expr s a) + -- | > Note s x ~ e + | Note s (Expr s a) + -- | > ImportAlt ~ e1 ? e2 + | ImportAlt (Expr s a) (Expr s a) + -- | > Embed import ~ import + | Embed a + deriving (Foldable, Generic, Traversable, Show, Data, NFData) +-- NB: If you add a constructor to Expr, please also update the Arbitrary +-- instance in Dhall.Test.QuickCheck. + +-- | This instance encodes what the Dhall standard calls an \"exact match\" +-- between two expressions. +-- +-- Note that +-- +-- >>> nan = DhallDouble (0/0) +-- >>> DoubleLit nan == DoubleLit nan +-- True +deriving instance (Eq s, Eq a) => Eq (Expr s a) + +-- | Note that this 'Ord' instance inherits `DhallDouble`'s defects. +deriving instance (Ord s, Ord a) => Ord (Expr s a) + +instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a) + +-- This instance is hand-written due to the fact that deriving +-- it does not give us an INLINABLE pragma. We annotate this fmap +-- implementation with this pragma below to allow GHC to, possibly, +-- inline the implementation for performance improvements. +instance Functor (Expr s) where + fmap _ (Const c) = Const c + fmap _ (Var v) = Var v + fmap f (Lam v e1 e2) = Lam v (fmap f e1) (fmap f e2) + fmap f (Pi v e1 e2) = Pi v (fmap f e1) (fmap f e2) + fmap f (App e1 e2) = App (fmap f e1) (fmap f e2) + fmap f (Let b e2) = Let (fmap f b) (fmap f e2) + fmap f (Annot e1 e2) = Annot (fmap f e1) (fmap f e2) + fmap _ Bool = Bool + fmap _ (BoolLit b) = BoolLit b + fmap f (BoolAnd e1 e2) = BoolAnd (fmap f e1) (fmap f e2) + fmap f (BoolOr e1 e2) = BoolOr (fmap f e1) (fmap f e2) + fmap f (BoolEQ e1 e2) = BoolEQ (fmap f e1) (fmap f e2) + fmap f (BoolNE e1 e2) = BoolNE (fmap f e1) (fmap f e2) + fmap f (BoolIf e1 e2 e3) = BoolIf (fmap f e1) (fmap f e2) (fmap f e3) + fmap _ Natural = Natural + fmap _ (NaturalLit n) = NaturalLit n + fmap _ NaturalFold = NaturalFold + fmap _ NaturalBuild = NaturalBuild + fmap _ NaturalIsZero = NaturalIsZero + fmap _ NaturalEven = NaturalEven + fmap _ NaturalOdd = NaturalOdd + fmap _ NaturalToInteger = NaturalToInteger + fmap _ NaturalShow = NaturalShow + fmap _ NaturalSubtract = NaturalSubtract + fmap f (NaturalPlus e1 e2) = NaturalPlus (fmap f e1) (fmap f e2) + fmap f (NaturalTimes e1 e2) = NaturalTimes (fmap f e1) (fmap f e2) + fmap _ Integer = Integer + fmap _ (IntegerLit i) = IntegerLit i + fmap _ IntegerShow = IntegerShow + fmap _ IntegerToDouble = IntegerToDouble + fmap _ Double = Double + fmap _ (DoubleLit d) = DoubleLit d + fmap _ DoubleShow = DoubleShow + fmap _ Text = Text + fmap f (TextLit cs) = TextLit (fmap f cs) + fmap f (TextAppend e1 e2) = TextAppend (fmap f e1) (fmap f e2) + fmap _ TextShow = TextShow + fmap _ List = List + fmap f (ListLit maybeE seqE) = ListLit (fmap (fmap f) maybeE) (fmap (fmap f) seqE) + fmap f (ListAppend e1 e2) = ListAppend (fmap f e1) (fmap f e2) + fmap _ ListBuild = ListBuild + fmap _ ListFold = ListFold + fmap _ ListLength = ListLength + fmap _ ListHead = ListHead + fmap _ ListLast = ListLast + fmap _ ListIndexed = ListIndexed + fmap _ ListReverse = ListReverse + fmap _ Optional = Optional + fmap f (Some e) = Some (fmap f e) + fmap _ None = None + fmap _ OptionalFold = OptionalFold + fmap _ OptionalBuild = OptionalBuild + fmap f (Record r) = Record (fmap (fmap f) r) + fmap f (RecordLit r) = RecordLit (fmap (fmap f) r) + fmap f (Union u) = Union (fmap (fmap (fmap f)) u) + fmap f (Combine e1 e2) = Combine (fmap f e1) (fmap f e2) + fmap f (CombineTypes e1 e2) = CombineTypes (fmap f e1) (fmap f e2) + fmap f (Prefer e1 e2) = Prefer (fmap f e1) (fmap f e2) + fmap f (RecordCompletion e1 e2) = RecordCompletion (fmap f e1) (fmap f e2) + fmap f (Merge e1 e2 maybeE) = Merge (fmap f e1) (fmap f e2) (fmap (fmap f) maybeE) + fmap f (ToMap e maybeE) = ToMap (fmap f e) (fmap (fmap f) maybeE) + fmap f (Field e1 v) = Field (fmap f e1) v + fmap f (Project e1 vs) = Project (fmap f e1) (fmap (fmap f) vs) + fmap f (Assert t) = Assert (fmap f t) + fmap f (Equivalent e1 e2) = Equivalent (fmap f e1) (fmap f e2) + fmap f (Note s e1) = Note s (fmap f e1) + fmap f (ImportAlt e1 e2) = ImportAlt (fmap f e1) (fmap f e2) + fmap f (Embed a) = Embed (f a) + {-# INLINABLE fmap #-} + +instance Applicative (Expr s) where + pure = Embed + + (<*>) = Control.Monad.ap + +instance Monad (Expr s) where + return = pure + + Const a >>= _ = Const a + Var a >>= _ = Var a + Lam a b c >>= k = Lam a (b >>= k) (c >>= k) + Pi a b c >>= k = Pi a (b >>= k) (c >>= k) + App a b >>= k = App (a >>= k) (b >>= k) + Let a b >>= k = Let (adapt0 a) (b >>= k) + where + adapt0 (Binding src0 c src1 d src2 e) = + Binding src0 c src1 (fmap adapt1 d) src2 (e >>= k) + + adapt1 (src3, f) = (src3, f >>= k) + Annot a b >>= k = Annot (a >>= k) (b >>= k) + Bool >>= _ = Bool + BoolLit a >>= _ = BoolLit a + BoolAnd a b >>= k = BoolAnd (a >>= k) (b >>= k) + BoolOr a b >>= k = BoolOr (a >>= k) (b >>= k) + BoolEQ a b >>= k = BoolEQ (a >>= k) (b >>= k) + BoolNE a b >>= k = BoolNE (a >>= k) (b >>= k) + BoolIf a b c >>= k = BoolIf (a >>= k) (b >>= k) (c >>= k) + Natural >>= _ = Natural + NaturalLit a >>= _ = NaturalLit a + NaturalFold >>= _ = NaturalFold + NaturalBuild >>= _ = NaturalBuild + NaturalIsZero >>= _ = NaturalIsZero + NaturalEven >>= _ = NaturalEven + NaturalOdd >>= _ = NaturalOdd + NaturalToInteger >>= _ = NaturalToInteger + NaturalShow >>= _ = NaturalShow + NaturalSubtract >>= _ = NaturalSubtract + NaturalPlus a b >>= k = NaturalPlus (a >>= k) (b >>= k) + NaturalTimes a b >>= k = NaturalTimes (a >>= k) (b >>= k) + Integer >>= _ = Integer + IntegerLit a >>= _ = IntegerLit a + IntegerShow >>= _ = IntegerShow + IntegerToDouble >>= _ = IntegerToDouble + Double >>= _ = Double + DoubleLit a >>= _ = DoubleLit a + DoubleShow >>= _ = DoubleShow + Text >>= _ = Text + TextLit (Chunks a b) >>= k = TextLit (Chunks (fmap (fmap (>>= k)) a) b) + TextAppend a b >>= k = TextAppend (a >>= k) (b >>= k) + TextShow >>= _ = TextShow + List >>= _ = List + ListLit a b >>= k = ListLit (fmap (>>= k) a) (fmap (>>= k) b) + ListAppend a b >>= k = ListAppend (a >>= k) (b >>= k) + ListBuild >>= _ = ListBuild + ListFold >>= _ = ListFold + ListLength >>= _ = ListLength + ListHead >>= _ = ListHead + ListLast >>= _ = ListLast + ListIndexed >>= _ = ListIndexed + ListReverse >>= _ = ListReverse + Optional >>= _ = Optional + Some a >>= k = Some (a >>= k) + None >>= _ = None + OptionalFold >>= _ = OptionalFold + OptionalBuild >>= _ = OptionalBuild + Record a >>= k = Record (fmap (>>= k) a) + RecordLit a >>= k = RecordLit (fmap (>>= k) a) + Union a >>= k = Union (fmap (fmap (>>= k)) a) + Combine a b >>= k = Combine (a >>= k) (b >>= k) + CombineTypes a b >>= k = CombineTypes (a >>= k) (b >>= k) + Prefer a b >>= k = Prefer (a >>= k) (b >>= k) + RecordCompletion a b >>= k = RecordCompletion (a >>= k) (b >>= k) + Merge a b c >>= k = Merge (a >>= k) (b >>= k) (fmap (>>= k) c) + ToMap a b >>= k = ToMap (a >>= k) (fmap (>>= k) b) + Field a b >>= k = Field (a >>= k) b + Project a b >>= k = Project (a >>= k) (fmap (>>= k) b) + Assert a >>= k = Assert (a >>= k) + Equivalent a b >>= k = Equivalent (a >>= k) (b >>= k) + Note a b >>= k = Note a (b >>= k) + ImportAlt a b >>= k = ImportAlt (a >>= k) (b >>= k) + Embed a >>= k = k a + +instance Bifunctor Expr where + first _ (Const a ) = Const a + first _ (Var a ) = Var a + first k (Lam a b c ) = Lam a (first k b) (first k c) + first k (Pi a b c ) = Pi a (first k b) (first k c) + first k (App a b ) = App (first k a) (first k b) + first k (Let a b ) = Let (first k a) (first k b) + first k (Annot a b ) = Annot (first k a) (first k b) + first _ Bool = Bool + first _ (BoolLit a ) = BoolLit a + first k (BoolAnd a b ) = BoolAnd (first k a) (first k b) + first k (BoolOr a b ) = BoolOr (first k a) (first k b) + first k (BoolEQ a b ) = BoolEQ (first k a) (first k b) + first k (BoolNE a b ) = BoolNE (first k a) (first k b) + first k (BoolIf a b c ) = BoolIf (first k a) (first k b) (first k c) + first _ Natural = Natural + first _ (NaturalLit a ) = NaturalLit a + first _ NaturalFold = NaturalFold + first _ NaturalBuild = NaturalBuild + first _ NaturalIsZero = NaturalIsZero + first _ NaturalEven = NaturalEven + first _ NaturalOdd = NaturalOdd + first _ NaturalToInteger = NaturalToInteger + first _ NaturalShow = NaturalShow + first _ NaturalSubtract = NaturalSubtract + first k (NaturalPlus a b ) = NaturalPlus (first k a) (first k b) + first k (NaturalTimes a b ) = NaturalTimes (first k a) (first k b) + first _ Integer = Integer + first _ (IntegerLit a ) = IntegerLit a + first _ IntegerShow = IntegerShow + first _ IntegerToDouble = IntegerToDouble + first _ Double = Double + first _ (DoubleLit a ) = DoubleLit a + first _ DoubleShow = DoubleShow + first _ Text = Text + first k (TextLit (Chunks a b)) = TextLit (Chunks (fmap (fmap (first k)) a) b) + first k (TextAppend a b ) = TextAppend (first k a) (first k b) + first _ TextShow = TextShow + first _ List = List + first k (ListLit a b ) = ListLit (fmap (first k) a) (fmap (first k) b) + first k (ListAppend a b ) = ListAppend (first k a) (first k b) + first _ ListBuild = ListBuild + first _ ListFold = ListFold + first _ ListLength = ListLength + first _ ListHead = ListHead + first _ ListLast = ListLast + first _ ListIndexed = ListIndexed + first _ ListReverse = ListReverse + first _ Optional = Optional + first k (Some a ) = Some (first k a) + first _ None = None + first _ OptionalFold = OptionalFold + first _ OptionalBuild = OptionalBuild + first k (Record a ) = Record (fmap (first k) a) + first k (RecordLit a ) = RecordLit (fmap (first k) a) + first k (Union a ) = Union (fmap (fmap (first k)) a) + first k (Combine a b ) = Combine (first k a) (first k b) + first k (CombineTypes a b ) = CombineTypes (first k a) (first k b) + first k (Prefer a b ) = Prefer (first k a) (first k b) + first k (RecordCompletion a b) = RecordCompletion (first k a) (first k b) + first k (Merge a b c ) = Merge (first k a) (first k b) (fmap (first k) c) + first k (ToMap a b ) = ToMap (first k a) (fmap (first k) b) + first k (Field a b ) = Field (first k a) b + first k (Assert a ) = Assert (first k a) + first k (Equivalent a b ) = Equivalent (first k a) (first k b) + first k (Project a b ) = Project (first k a) (fmap (first k) b) + first k (Note a b ) = Note (k a) (first k b) + first k (ImportAlt a b ) = ImportAlt (first k a) (first k b) + first _ (Embed a ) = Embed a + + second = fmap + +instance IsString (Expr s a) where + fromString str = Var (fromString str) + +-- | Generates a syntactically valid Dhall program +instance Pretty a => Pretty (Expr s a) where + pretty = Pretty.unAnnotate . prettyExpr + +{- +Instead of converting explicitly between 'Expr's and 'MultiLet', it might +be nicer to use a pattern synonym: + +> pattern MultiLet' :: NonEmpty (Binding s a) -> Expr s a -> Expr s a +> pattern MultiLet' as b <- (multiLetFromExpr -> Just (MultiLet as b)) where +> MultiLet' as b = wrapInLets as b +> +> multiLetFromExpr :: Expr s a -> Maybe (MultiLet s a) +> multiLetFromExpr = \case +> Let x mA a b -> Just (multiLet x mA a b) +> _ -> Nothing + +This works in principle, but GHC as of v8.8.1 doesn't handle it well: +https://gitlab.haskell.org/ghc/ghc/issues/17096 + +This should be fixed by GHC-8.10, so it might be worth revisiting then. +-} + +{-| Generate a 'MultiLet' from the contents of a 'Let'. + + In the resulting @'MultiLet' bs e@, @e@ is guaranteed not to be a 'Let', + but it might be a @('Note' … ('Let' …))@. + + Given parser output, 'multiLet' consolidates @let@s that formed a + let-block in the original source. +-} +multiLet :: Binding s a -> Expr s a -> MultiLet s a +multiLet b0 = \case + Let b1 e1 -> + let MultiLet bs e = multiLet b1 e1 + in MultiLet (Data.List.NonEmpty.cons b0 bs) e + e -> MultiLet (b0 :| []) e + +{-| Wrap let-'Binding's around an 'Expr'. + +'wrapInLets' can be understood as an inverse for 'multiLet': + +> let MultiLet bs e1 = multiLet b e0 +> +> wrapInLets bs e1 == Let b e0 +-} +wrapInLets :: Foldable f => f (Binding s a) -> Expr s a -> Expr s a +wrapInLets bs e = foldr Let e bs + +{-| This type represents 1 or more nested `Let` bindings that have been + coalesced together for ease of manipulation +-} +data MultiLet s a = MultiLet (NonEmpty (Binding s a)) (Expr s a) + +-- | A traversal over the immediate sub-expressions of an expression. +subExpressions :: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a) +subExpressions _ (Const c) = pure (Const c) +subExpressions _ (Var v) = pure (Var v) +subExpressions f (Lam a b c) = Lam a <$> f b <*> f c +subExpressions f (Pi a b c) = Pi a <$> f b <*> f c +subExpressions f (App a b) = App <$> f a <*> f b +subExpressions f (Let a b) = Let <$> bindingExprs f a <*> f b +subExpressions f (Annot a b) = Annot <$> f a <*> f b +subExpressions _ Bool = pure Bool +subExpressions _ (BoolLit b) = pure (BoolLit b) +subExpressions f (BoolAnd a b) = BoolAnd <$> f a <*> f b +subExpressions f (BoolOr a b) = BoolOr <$> f a <*> f b +subExpressions f (BoolEQ a b) = BoolEQ <$> f a <*> f b +subExpressions f (BoolNE a b) = BoolNE <$> f a <*> f b +subExpressions f (BoolIf a b c) = BoolIf <$> f a <*> f b <*> f c +subExpressions _ Natural = pure Natural +subExpressions _ (NaturalLit n) = pure (NaturalLit n) +subExpressions _ NaturalFold = pure NaturalFold +subExpressions _ NaturalBuild = pure NaturalBuild +subExpressions _ NaturalIsZero = pure NaturalIsZero +subExpressions _ NaturalEven = pure NaturalEven +subExpressions _ NaturalOdd = pure NaturalOdd +subExpressions _ NaturalToInteger = pure NaturalToInteger +subExpressions _ NaturalShow = pure NaturalShow +subExpressions _ NaturalSubtract = pure NaturalSubtract +subExpressions f (NaturalPlus a b) = NaturalPlus <$> f a <*> f b +subExpressions f (NaturalTimes a b) = NaturalTimes <$> f a <*> f b +subExpressions _ Integer = pure Integer +subExpressions _ (IntegerLit n) = pure (IntegerLit n) +subExpressions _ IntegerShow = pure IntegerShow +subExpressions _ IntegerToDouble = pure IntegerToDouble +subExpressions _ Double = pure Double +subExpressions _ (DoubleLit n) = pure (DoubleLit n) +subExpressions _ DoubleShow = pure DoubleShow +subExpressions _ Text = pure Text +subExpressions f (TextLit chunks) = + TextLit <$> chunkExprs f chunks +subExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b +subExpressions _ TextShow = pure TextShow +subExpressions _ List = pure List +subExpressions f (ListLit a b) = ListLit <$> traverse f a <*> traverse f b +subExpressions f (ListAppend a b) = ListAppend <$> f a <*> f b +subExpressions _ ListBuild = pure ListBuild +subExpressions _ ListFold = pure ListFold +subExpressions _ ListLength = pure ListLength +subExpressions _ ListHead = pure ListHead +subExpressions _ ListLast = pure ListLast +subExpressions _ ListIndexed = pure ListIndexed +subExpressions _ ListReverse = pure ListReverse +subExpressions _ Optional = pure Optional +subExpressions f (Some a) = Some <$> f a +subExpressions _ None = pure None +subExpressions _ OptionalFold = pure OptionalFold +subExpressions _ OptionalBuild = pure OptionalBuild +subExpressions f (Record a) = Record <$> traverse f a +subExpressions f ( RecordLit a ) = RecordLit <$> traverse f a +subExpressions f (Union a) = Union <$> traverse (traverse f) a +subExpressions f (Combine a b) = Combine <$> f a <*> f b +subExpressions f (CombineTypes a b) = CombineTypes <$> f a <*> f b +subExpressions f (Prefer a b) = Prefer <$> f a <*> f b +subExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b +subExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t +subExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t +subExpressions f (Field a b) = Field <$> f a <*> pure b +subExpressions f (Project a b) = Project <$> f a <*> traverse f b +subExpressions f (Assert a) = Assert <$> f a +subExpressions f (Equivalent a b) = Equivalent <$> f a <*> f b +subExpressions f (Note a b) = Note a <$> f b +subExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r +subExpressions _ (Embed a) = pure (Embed a) + +{-| Traverse over the immediate 'Expr' children in a 'Binding'. +-} +bindingExprs + :: (Applicative f) + => (Expr s a -> f (Expr s b)) + -> Binding s a -> f (Binding s b) +bindingExprs f (Binding s0 n s1 t s2 v) = + Binding + <$> pure s0 + <*> pure n + <*> pure s1 + <*> traverse (traverse f) t + <*> pure s2 + <*> f v + +-- | A traversal over the immediate sub-expressions in 'Chunks'. +chunkExprs + :: Applicative f + => (Expr s a -> f (Expr t b)) + -> Chunks s a -> f (Chunks t b) +chunkExprs f (Chunks chunks final) = + flip Chunks final <$> traverse (traverse f) chunks + +{-| Internal representation of a directory that stores the path components in + reverse order + + In other words, the directory @\/foo\/bar\/baz@ is encoded as + @Directory { components = [ "baz", "bar", "foo" ] }@ +-} +newtype Directory = Directory { components :: [Text] } + deriving (Eq, Generic, Ord, Show, NFData) + +instance Semigroup Directory where + Directory components₀ <> Directory components₁ = + Directory (components₁ <> components₀) + +instance Pretty Directory where + pretty (Directory {..}) = foldMap prettyPathComponent (reverse components) + +prettyPathComponent :: Text -> Doc ann +prettyPathComponent text + | Data.Text.all pathCharacter text = + "/" <> Pretty.pretty text + | otherwise = + "/\"" <> Pretty.pretty text <> "\"" + +{-| A `File` is a `directory` followed by one additional path component + representing the `file` name +-} +data File = File + { directory :: Directory + , file :: Text + } deriving (Eq, Generic, Ord, Show, NFData) + +instance Pretty File where + pretty (File {..}) = + Pretty.pretty directory + <> prettyPathComponent file + +instance Semigroup File where + File directory₀ _ <> File directory₁ file = + File (directory₀ <> directory₁) file + +-- | The beginning of a file path which anchors subsequent path components +data FilePrefix + = Absolute + -- ^ Absolute path + | Here + -- ^ Path relative to @.@ + | Parent + -- ^ Path relative to @..@ + | Home + -- ^ Path relative to @~@ + deriving (Eq, Generic, Ord, Show, NFData) + +instance Pretty FilePrefix where + pretty Absolute = "" + pretty Here = "." + pretty Parent = ".." + pretty Home = "~" + +-- | The URI scheme +data Scheme = HTTP | HTTPS deriving (Eq, Generic, Ord, Show, NFData) + +-- | This type stores all of the components of a remote import +data URL = URL + { scheme :: Scheme + , authority :: Text + , path :: File + , query :: Maybe Text + , headers :: Maybe (Expr Src Import) + } deriving (Eq, Generic, Ord, Show, NFData) + +instance Pretty URL where + pretty (URL {..}) = + schemeDoc + <> "://" + <> Pretty.pretty authority + <> pathDoc + <> queryDoc + <> foldMap prettyHeaders headers + where + prettyHeaders h = " using " <> Pretty.pretty h + + File {..} = path + + Directory {..} = directory + + pathDoc = + foldMap prettyURIComponent (reverse components) + <> prettyURIComponent file + + schemeDoc = case scheme of + HTTP -> "http" + HTTPS -> "https" + + queryDoc = case query of + Nothing -> "" + Just q -> "?" <> Pretty.pretty q + +prettyURIComponent :: Text -> Doc ann +prettyURIComponent text = + Pretty.pretty $ URI.normalizeCase $ URI.normalizeEscape $ "/" <> Data.Text.unpack text + +-- | The type of import (i.e. local vs. remote vs. environment) +data ImportType + = Local FilePrefix File + -- ^ Local path + | Remote URL + -- ^ URL of remote resource and optional headers stored in an import + | Env Text + -- ^ Environment variable + | Missing + deriving (Eq, Generic, Ord, Show, NFData) + +parent :: File +parent = File { directory = Directory { components = [ ".." ] }, file = "" } + +instance Semigroup ImportType where + Local prefix file₀ <> Local Here file₁ = Local prefix (file₀ <> file₁) + + Remote (URL { path = path₀, ..}) <> Local Here path₁ = + Remote (URL { path = path₀ <> path₁, ..}) + + Local prefix file₀ <> Local Parent file₁ = + Local prefix (file₀ <> parent <> file₁) + + Remote (URL { path = path₀, .. }) <> Local Parent path₁ = + Remote (URL { path = path₀ <> parent <> path₁, .. }) + + import₀ <> Remote (URL { headers = headers₀, .. }) = + Remote (URL { headers = headers₁, .. }) + where + importHashed₀ = Import (ImportHashed Nothing import₀) Code + + headers₁ = fmap (fmap (importHashed₀ <>)) headers₀ + + _ <> import₁ = + import₁ + +instance Pretty ImportType where + pretty (Local prefix file) = + Pretty.pretty prefix <> Pretty.pretty file + + pretty (Remote url) = Pretty.pretty url + + pretty (Env env) = "env:" <> Pretty.pretty env + + pretty Missing = "missing" + +-- | How to interpret the import's contents (i.e. as Dhall code or raw text) +data ImportMode = Code | RawText | Location + deriving (Eq, Generic, Ord, Show, NFData) + +-- | A `ImportType` extended with an optional hash for semantic integrity checks +data ImportHashed = ImportHashed + { hash :: Maybe Dhall.Crypto.SHA256Digest + , importType :: ImportType + } deriving (Eq, Generic, Ord, Show, NFData) + +instance Semigroup ImportHashed where + ImportHashed _ importType₀ <> ImportHashed hash importType₁ = + ImportHashed hash (importType₀ <> importType₁) + +instance Pretty ImportHashed where + pretty (ImportHashed Nothing p) = + Pretty.pretty p + pretty (ImportHashed (Just h) p) = + Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) + +-- | Reference to an external resource +data Import = Import + { importHashed :: ImportHashed + , importMode :: ImportMode + } deriving (Eq, Generic, Ord, Show, NFData) + +instance Semigroup Import where + Import importHashed₀ _ <> Import importHashed₁ code = + Import (importHashed₀ <> importHashed₁) code + +instance Pretty Import where + pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix + where + suffix :: Text + suffix = case importMode of + RawText -> " as Text" + Location -> " as Location" + Code -> "" + +{-| Returns `True` if the given `Char` is valid within an unquoted path + component + + This is exported for reuse within the @"Dhall.Parser.Token"@ module +-} +pathCharacter :: Char -> Bool +pathCharacter c = + '\x21' == c + || ('\x24' <= c && c <= '\x27') + || ('\x2A' <= c && c <= '\x2B') + || ('\x2D' <= c && c <= '\x2E') + || ('\x30' <= c && c <= '\x3B') + || c == '\x3D' + || ('\x40' <= c && c <= '\x5A') + || ('\x5E' <= c && c <= '\x7A') + || c == '\x7C' + || c == '\x7E' + +-- | Remove all `Note` constructors from an `Expr` (i.e. de-`Note`) +denote :: Expr s a -> Expr t a +denote (Note _ b ) = denote b +denote (Const a ) = Const a +denote (Var a ) = Var a +denote (Lam a b c ) = Lam a (denote b) (denote c) +denote (Pi a b c ) = Pi a (denote b) (denote c) +denote (App a b ) = App (denote a) (denote b) +denote (Let a b ) = Let (adapt0 a) (denote b) + where + adapt0 (Binding _ c _ d _ e) = + Binding Nothing c Nothing (fmap adapt1 d) Nothing (denote e) + + adapt1 (_, f) = (Nothing, denote f) +denote (Annot a b ) = Annot (denote a) (denote b) +denote Bool = Bool +denote (BoolLit a ) = BoolLit a +denote (BoolAnd a b ) = BoolAnd (denote a) (denote b) +denote (BoolOr a b ) = BoolOr (denote a) (denote b) +denote (BoolEQ a b ) = BoolEQ (denote a) (denote b) +denote (BoolNE a b ) = BoolNE (denote a) (denote b) +denote (BoolIf a b c ) = BoolIf (denote a) (denote b) (denote c) +denote Natural = Natural +denote (NaturalLit a ) = NaturalLit a +denote NaturalFold = NaturalFold +denote NaturalBuild = NaturalBuild +denote NaturalIsZero = NaturalIsZero +denote NaturalEven = NaturalEven +denote NaturalOdd = NaturalOdd +denote NaturalToInteger = NaturalToInteger +denote NaturalShow = NaturalShow +denote NaturalSubtract = NaturalSubtract +denote (NaturalPlus a b ) = NaturalPlus (denote a) (denote b) +denote (NaturalTimes a b ) = NaturalTimes (denote a) (denote b) +denote Integer = Integer +denote (IntegerLit a ) = IntegerLit a +denote IntegerShow = IntegerShow +denote IntegerToDouble = IntegerToDouble +denote Double = Double +denote (DoubleLit a ) = DoubleLit a +denote DoubleShow = DoubleShow +denote Text = Text +denote (TextLit (Chunks a b)) = TextLit (Chunks (fmap (fmap denote) a) b) +denote (TextAppend a b ) = TextAppend (denote a) (denote b) +denote TextShow = TextShow +denote List = List +denote (ListLit a b ) = ListLit (fmap denote a) (fmap denote b) +denote (ListAppend a b ) = ListAppend (denote a) (denote b) +denote ListBuild = ListBuild +denote ListFold = ListFold +denote ListLength = ListLength +denote ListHead = ListHead +denote ListLast = ListLast +denote ListIndexed = ListIndexed +denote ListReverse = ListReverse +denote Optional = Optional +denote (Some a ) = Some (denote a) +denote None = None +denote OptionalFold = OptionalFold +denote OptionalBuild = OptionalBuild +denote (Record a ) = Record (fmap denote a) +denote (RecordLit a ) = RecordLit (fmap denote a) +denote (Union a ) = Union (fmap (fmap denote) a) +denote (Combine a b ) = Combine (denote a) (denote b) +denote (CombineTypes a b ) = CombineTypes (denote a) (denote b) +denote (Prefer a b ) = Prefer (denote a) (denote b) +denote (RecordCompletion a b) = RecordCompletion (denote a) (denote b) +denote (Merge a b c ) = Merge (denote a) (denote b) (fmap denote c) +denote (ToMap a b ) = ToMap (denote a) (fmap denote b) +denote (Field a b ) = Field (denote a) b +denote (Project a b ) = Project (denote a) (fmap denote b) +denote (Assert a ) = Assert (denote a) +denote (Equivalent a b ) = Equivalent (denote a) (denote b) +denote (ImportAlt a b ) = ImportAlt (denote a) (denote b) +denote (Embed a ) = Embed a + +-- | The \"opposite\" of `denote`, like @first absurd@ but faster +renote :: Expr Void a -> Expr s a +renote = unsafeCoerce +{-# INLINE renote #-} + +{-| Remove any outermost `Note` constructors + + This is typically used when you want to get the outermost non-`Note` + constructor without removing internal `Note` constructors +-} +shallowDenote :: Expr s a -> Expr s a +shallowDenote (Note _ e) = shallowDenote e +shallowDenote e = e + +-- | The set of reserved identifiers for the Dhall language +reservedIdentifiers :: HashSet Text +reservedIdentifiers = + Data.HashSet.fromList + [ "let" + , "in" + , "Type" + , "Kind" + , "Sort" + , "forall" + , "Bool" + , "True" + , "False" + , "merge" + , "toMap" + , "if" + , "then" + , "else" + , "as" + , "using" + , "Natural" + , "Natural/fold" + , "Natural/build" + , "Natural/isZero" + , "Natural/even" + , "Natural/odd" + , "Natural/toInteger" + , "Natural/show" + , "Natural/subtract" + , "Integer" + , "Integer/show" + , "Integer/toDouble" + , "Double" + , "Double/show" + , "Text" + , "Text/show" + , "List" + , "List/build" + , "List/fold" + , "List/length" + , "List/head" + , "List/last" + , "List/indexed" + , "List/reverse" + , "Optional" + , "Some" + , "None" + , "Optional/build" + , "Optional/fold" + , "NaN" + , "Infinity" + ] diff --git a/src/Dhall/Syntax.hs-boot b/src/Dhall/Syntax.hs-boot new file mode 100644 --- /dev/null +++ b/src/Dhall/Syntax.hs-boot @@ -0,0 +1,7 @@ +module Dhall.Syntax where + +data Var + +data Const + +data Expr s a diff --git a/src/Dhall/Tags.hs b/src/Dhall/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Tags.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module contains the implementation of the @dhall tags@ command + +module Dhall.Tags + ( generate + ) where + +import Control.Exception (handle, SomeException(..)) +import Data.List (isSuffixOf) +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.Src (Src(srcStart)) +import Dhall.Parser (exprFromText) +import System.FilePath ((), takeFileName) +import Text.Megaparsec (sourceLine, sourceColumn, unPos) + +import qualified Data.ByteString as BS (length) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified System.Directory as SD + +{- + Documentation for the etags format is not very informative and not very correct. + You can find some documentation here: + https://en.wikipedia.org/wiki/Ctags#Etags_2 + and you can also check the source code here: + http://cvs.savannah.gnu.org/viewvc/vtags/vtags/vtags.el?view=markup +-} + +data LineColumn = LC + { lcLine :: Int + -- ^ line number, starting from 1, where to find the tag + , lcColumn :: Int + -- ^ column of line where tag is + } deriving (Eq, Ord, Show) + +data LineOffset = LO + { loLine :: Int + -- ^ line number, starting from 1, where to find the tag + , loOffset :: Int + -- ^ byte offset from start of file. Not sure if any editor uses it + } deriving (Eq, Ord, Show) + +newtype Tags = Tags (M.Map FilePath [(LineOffset, Tag)]) + +instance Semigroup Tags where + (Tags ts1) <> (Tags ts2) = Tags (M.unionWith (<>) ts1 ts2) + +instance Monoid Tags where + mempty = Tags M.empty + mappend = (<>) + +{-| For example, for the line: @let foo = \"foo\"@ the tag is: + > Tag "let " "foo" +-} +data Tag = Tag + { tagPattern :: Text + -- ^ In vtags source code this field is named \"pattern\" and EMacs used it as + -- a regex pattern to locate line with tag. It's looking for ^. + -- Looks like vi is not using it. + , tagName :: Text + -- ^ text, that editor compare with selected text. So it's really name of entity + } deriving (Show) + +type LineNumber = Int + +type ByteOffset = Int + +{-| Generate etags for Dhall expressions +-} +generate + :: Input + -- ^ Where to look for files. This can be a directory name (@.@ for example), + -- a file name or `StandardInput`. If `StandardInput`, then this will wait for + -- file names from @STDIN@. + -- This way someone can combine tools in @bash@ to send, for example, output from + -- @find@ to the input of @dhall tags@. + -> Maybe [Text] + -- ^ List of suffixes for dhall files or Nothing to check all files + -> Bool + -- ^ Flag if `generate` should follow symlinks + -> IO Text + -- ^ Content for tags file +generate inp sxs followSyms = do + files <- inputToFiles followSyms (map T.unpack <$> sxs) inp + tags <- traverse (\f -> handle (\(SomeException _) -> return mempty) + (fileTags f <$> TIO.readFile f)) files + return (showTags . mconcat $ tags) + +{-| Find tags in Text (second argument) and generates a list of them + To make tags for filenames that works in both emacs and vi, add two initial tags. + First for @filename@ for vi and second with @/filename@ for emacs. + Other tags are working for both. +-} +fileTags :: FilePath -> Text -> Tags +fileTags f t = Tags (M.singleton f + (initialMap <> getTagsFromText t)) + where initialViTag = (LO 1 1, Tag "" (T.pack . takeFileName $ f)) + initialEmacsTag = (LO 1 1, Tag "" ("/" <> (T.pack . takeFileName) f)) + initialMap = [initialViTag, initialEmacsTag] + +getTagsFromText :: Text -> [(LineOffset, Tag)] +getTagsFromText t = case exprFromText "" t of + Right expr -> fixPosAndDefinition t (getTagsFromExpr expr) + _ -> mempty + +{-| Used to update tag position and to build tag from term. + After getTagsFromExpr line and column in line are in `LineColumn` for each tag. + And tagPattern is not added. + Emacs use tag pattern to check if tag is on line. It compares line from start + with tag pattern and in case they are the same, relocate user. + fixPosAndDefinition change position to line and byte offset (`LineOffset`) and + add tag pattern. For example, for Dhall string: + + >>> let dhallSource = "let foo = \"bar\"\nlet baz = \"qux\"" + + Input for this function is: + + >>> foundTerms = [(LC 1 4, "foo"), (LC 2 4, "baz")] + + And: + + >>> fixPosAndDefinition dhallSource foundTerms + [(LO {loLine = 1, loOffset = 5},Tag {tagPattern = "let foo ", tagName = "foo"}),(LO {loLine = 2, loOffset = 21},Tag {tagPattern = "let baz ", tagName = "baz"})] + + where 21 is byte offset from file start. +-} +fixPosAndDefinition :: Text -> [(LineColumn, Text)] -> [(LineOffset, Tag)] +fixPosAndDefinition t = foldMap (\(LC ln c, term) -> + let (ln', offset, tPattern) = fromMaybe (fallbackInfoForText ln c) + (infoForText term ln) + in [(LO ln' offset, Tag tPattern term)]) + where mls :: M.Map Int (Text, Int) + -- ^ mls is map that for each line has length of file before this map and line content. + -- 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 + + {-| 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 + -} + processLine + :: ([(LineNumber, (Text, ByteOffset))], ByteOffset) + -- ^ previous result and byte offset for the start of current line + -> (LineNumber, Text) + -> ([(LineNumber, (Text, ByteOffset))], ByteOffset) + -- ^ next result, where new line was added and byte offset for next line + processLine (numberedLinesWithSizes, bytesBeforeLine) (n, line) = + ((n, (line, bytesBeforeLine)): numberedLinesWithSizes, bytesBeforeNextLine) + where bytesBeforeNextLine = bytesBeforeLine + lengthInBytes line + 1 + + lineFromMap ln = fromMaybe ("", 0) (ln `M.lookup` mls) + + lengthInBytes = BS.length . encodeUtf8 + + {-| get information about term from map of lines + In most cases, `LineColumn` after `getTagsFromExpr` points to byte before term. + It's better to have term in term pattern, so this function finds and updates + line number and byte offset and generate pattern. + -} + infoForText + :: Text + -- ^ term to find + -> Int + -- ^ line where to start + -> Maybe (Int, Int, Text) + -- ^ (Line number, byte offset, pattern to find term in file) + infoForText term ln + | ln <= 0 = Nothing + | T.null part2 = infoForText term (ln - 1) + | otherwise = Just (ln, lsl + 1 + lengthInBytes part1, part1 <> termAndNext) + where (l, lsl) = lineFromMap ln + (part1, part2) = T.breakOn term l + termAndNext = T.take (T.length term + 1) part2 + + fallbackInfoForText ln c = (ln, lsl + 1 + lengthInBytes pat, pat) + where (l, lsl) = lineFromMap ln + pat = T.take c l + +getTagsFromExpr :: Expr Src a -> [(LineColumn, Text)] +getTagsFromExpr = go (LC 0 0) [] + where go lpos mts = \case + (Let b e) -> go lpos (mts <> parseBinding lpos b) e + (Annot e1 e2) -> go lpos (go lpos mts e1) e2 + (Record mr) -> mts <> tagsFromDhallMap lpos mr + (RecordLit mr) -> mts <> tagsFromDhallMap lpos mr + (Union mmr) -> mts <> tagsFromDhallMapMaybe lpos mmr + (Note s e) -> go (srcToLineColumn s) mts e + _ -> mts + + tagsFromDhallMap lpos = foldMapWithKey (tagsFromDhallMapElement lpos) + + tagsFromDhallMapMaybe lpos = foldMapWithKey (\k -> \case + Just e -> tagsFromDhallMapElement lpos k e + _ -> [(lpos, k)]) + + tagsFromDhallMapElement lpos k e = go pos [(pos, k)] e + where pos = firstPosFromExpr lpos e + + parseBinding :: LineColumn -> Binding Src a -> [(LineColumn, Text)] + parseBinding lpos b = go p2 [(p0, variable b)] (value b) + where p0 = posFromBinding (bindingSrc0 b) lpos + p1 = posFromBinding (bindingSrc1 b) p0 + p2 = posFromBinding (bindingSrc2 b) p1 + posFromBinding src startPos = maybe startPos srcToLineColumn src + +srcToLineColumn :: Src -> LineColumn +srcToLineColumn s = LC line column + where ssp = srcStart s + line = unPos . sourceLine $ ssp + column = unPos . sourceColumn $ ssp + +firstPosFromExpr :: LineColumn -> Expr Src a -> LineColumn +firstPosFromExpr lpos = \case + (Note s _) -> srcToLineColumn s + _ -> lpos + +showTags :: Tags -> Text +showTags (Tags ts) = T.concat . map (uncurry showFileTags) . M.toList $ ts + +showFileTags :: FilePath -> [(LineOffset, Tag)] -> T.Text +showFileTags f ts = "\x0c\n" <> T.pack f <> "," <> (showInt . T.length) cs <> "\n" <> cs + where cs = T.concat . map (uncurry showPosTag) $ ts + +showPosTag :: LineOffset -> Tag -> Text +showPosTag lo tag = def <>"\x7f" <> name <> "\x01" <> showInt line <> + "," <> showInt offset <> "\n" + where line = loLine lo + offset = loOffset lo + def = tagPattern tag + name = tagName tag + +showInt :: Int -> Text +showInt = T.pack . show + +{-| Generate list of files for a given `Input` +-} +inputToFiles + :: Bool + -- ^ If `True`, this function will follow symbolic links + -> Maybe [String] + -- ^ List of suffixes. If `Nothing`, all files will be returned. + -- This parameter only works when the `Input` is an `InputFile` and point to a directory. + -> Input + -> IO [ FilePath ] + -- List of files. +inputToFiles _ _ StandardInput = lines <$> getContents +inputToFiles followSyms suffixes (InputFile path) = go path + where go p = do + isD <- SD.doesDirectoryExist p + isSL <- isSymLink + if isD + then if isSL && not followSyms + then return [] + else do + -- filter . .. and hidden files .* + contents <- fmap (filter ((/=) '.' . head)) + (SD.getDirectoryContents p) + concat <$> mapM (go . () p) contents + else return [p | matchingSuffix || p == path] + where matchingSuffix = maybe True (any (`isSuffixOf` p)) suffixes + isSymLink = +#if MIN_VERSION_directory(1,3,0) + SD.pathIsSymbolicLink p +#elif MIN_VERSION_directory(1,2,6) + SD.isSymbolicLink pa +#else + return False +#endif diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -1,2986 +1,2175 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-| Dhall is a programming language specialized for configuration files. This - module contains a tutorial explaining how to author configuration files using - this language --} -module Dhall.Tutorial ( - -- * Introduction - -- $introduction - - -- * Types - -- $types - - -- * Imports - -- $imports - - -- * Lists - -- $lists - - -- * Optional values - -- $optional0 - - -- * Records - -- $records - - -- * Functions - -- $functions - - -- * Compiler - -- $compiler - - -- * Strings - -- $strings - - -- * Combine - -- $combine - - -- * Let expressions - -- $let - - -- * Unions - -- $unions - - -- * Polymorphic functions - -- $polymorphic - - -- * Total - -- $total - - -- * Assertions - -- $assertions - - -- * Headers - -- $headers - - -- * Import integrity - -- $integrity - - -- * Raw text - -- $rawText - - -- * Formatting code - -- $format - - -- * Built-in functions - -- $builtins - - -- ** Caveats - -- $caveats - - -- ** Extending the language - -- $extending - - -- ** Overview - -- $builtinOverview - - -- ** @Bool@ - -- $bool - - -- *** @(||)@ - -- $or - - -- *** @(&&)@ - -- $and - - -- *** @(==)@ - -- $equal - - -- *** @(!=)@ - -- $unequal - - -- *** @if@\/@then@\/@else@ - -- $ifthenelse - - -- ** @Natural@ - -- $natural - - -- *** @(+)@ - -- $plus - - -- *** @(*)@ - -- $times - - -- *** @Natural/even@ - -- $even - - -- *** @Natural/odd@ - -- $odd - - -- *** @Natural/isZero@ - -- $isZero - - -- *** @Natural/fold@ - -- $naturalFold - - -- *** @Natural/build@ - -- $naturalBuild - - -- ** @Integer@ - -- $integer - - -- ** @Double@ - -- $double - - -- ** @Text@ - -- $text - - -- *** @(++)@ - -- $textAppend - - -- ** @List@ - -- $list - - -- *** @(#)@ - -- $listAppend - - -- *** @List/fold@ - -- $listFold - - -- *** @List/build@ - -- $listBuild - - -- *** @List/length@ - -- $listLength - - -- *** @List/head@ - -- $listHead - - -- *** @List/last@ - -- $listLast - - -- *** @List/indexed@ - -- $listIndexed - - -- *** @List/reverse@ - -- $listReverse - - -- ** @Optional@ - -- $optional1 - - -- *** @Optional/fold@ - -- $optionalFold - - -- * Prelude - -- $prelude - - -- * Conclusion - -- $conclusion - - -- * Frequently Asked Questions (FAQ) - -- $faq - ) where - -import Data.Vector (Vector) -import Dhall - --- $setup --- --- >>> :set -XOverloadedStrings - --- $introduction --- --- The simplest way to use Dhall is to ignore the programming language features --- and use it as a strongly typed configuration format. For example, suppose --- that you create the following configuration file: --- --- > $ cat ./config --- > { foo = 1 --- > , bar = [3.0, 4.0, 5.0] --- > } --- --- You can read the above configuration file into Haskell using the following --- code: --- --- > -- example.hs --- > --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Dhall --- > --- > data Example = Example { foo :: Natural, bar :: Vector Double } --- > deriving (Generic, Show) --- > --- > instance Interpret Example --- > --- > main :: IO () --- > main = do --- > x <- input auto "./config" --- > print (x :: Example) --- --- If you compile and run the above example, the program prints the corresponding --- Haskell record: --- --- > $ ./example --- > Example {foo = 1, bar = [3.0,4.0,5.0]} --- --- You can also load some types directly into Haskell without having to define a --- record, like this: --- --- >>> :set -XOverloadedStrings --- >>> input auto "True" :: IO Bool --- True --- --- The `input` function can decode any value if we specify the value's expected --- `Type`: --- --- > input --- > :: Type a -- Expected type --- > -> Text -- Dhall program --- > -> IO a -- Decoded expression --- --- ... and we can either specify an explicit type like `bool`: --- --- > bool :: Type Bool --- > --- > input bool :: Text -> IO Bool --- > --- > input bool "True" :: IO Bool --- --- >>> input bool "True" --- True --- --- ... or we can use `auto` to let the compiler infer what type to decode from --- the expected return type: --- --- > auto :: Interpret a => Type a --- > --- > input auto :: Interpret a => Text -> IO a --- --- >>> input auto "True" :: IO Bool --- True --- --- You can see what types `auto` supports \"out-of-the-box\" by browsing the --- instances for the `Interpret` class. For example, the following instance --- says that we can directly decode any Dhall expression that evaluates to a --- @Bool@ into a Haskell `Bool`: --- --- > instance Interpret Bool --- --- ... which is why we could directly decode the string @\"True\"@ into the --- value `True`. --- --- There is also another instance that says that if we can decode a value of --- type @a@, then we can also decode a @List@ of values as a `Vector` of @a@s: --- --- > instance Interpret a => Interpret (Vector a) --- --- Therefore, since we can decode a @Bool@, we must also be able to decode a --- @List@ of @Bool@s, like this: --- --- >>> input auto "[True, False]" :: IO (Vector Bool) --- [True,False] --- --- We could also specify what type to decode by providing an explicit `Type` --- instead of using `auto` with a type annotation: --- --- >>> input (vector bool) "[True, False]" --- [True,False] --- --- __Exercise:__ Create a @./config@ file that the following program can decode: --- --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Dhall --- > --- > data Person = Person { age :: Natural, name :: Text } --- > deriving (Generic, Show) --- > --- > instance Interpret Person --- > --- > main :: IO () --- > main = do --- > x <- input auto "./config" --- > print (x :: Person) --- --- __Exercise:__ Create a @./config@ file that the following program can decode: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Data.Functor.Identity --- > import Dhall --- > --- > instance Interpret a => Interpret (Identity a) --- > --- > main :: IO () --- > main = do --- > x <- input auto "./config" --- > print (x :: Identity Double) - --- $types --- --- Suppose that we try to decode a value of the wrong type, like this: --- --- >>> input auto "1" :: IO Bool --- *** Exception: --- ...Error...: Expression doesn't match annotation --- ... --- - Bool --- + Natural --- ... --- 1│ 1 : Bool --- ... --- (input):1:1 --- ... --- --- The interpreter complains because the string @\"1\"@ cannot be decoded into a --- Haskell value of type `Bool`. This part of the type error: --- --- > - Bool --- > + Natural --- --- ... means that the expected type was @Bool@ but the inferred type of the --- expression @1@ was @Natural@. --- --- The code excerpt from the above error message has two components: --- --- * the expression being type checked (i.e. @1@) --- * the expression's expected type (i.e. @Bool@) --- --- > Expression --- > ⇩ --- > 1 : Bool --- > ⇧ --- > Expected type --- --- The @(:)@ symbol is how Dhall annotates values with their expected types. --- This notation is equivalent to type annotations in Haskell using the @(::)@ --- symbol. Whenever you see: --- --- > x : t --- --- ... you should read that as \"we expect the expression @x@ to have type --- @t@\". However, we might be wrong and if our expected type does not match the --- expression's actual type then the type checker will complain. --- --- In this case, the expression @1@ does not have type @Bool@ so type checking --- fails with an exception. --- --- __Exercise:__ Load the Dhall library into @ghci@ and run these commands to get --- get a more detailed error message: --- --- > >>> import Dhall --- > >>> :set -XOverloadedStrings --- > >>> detailed (input auto "1") :: IO Bool --- > ... --- --- ... then read the entire error message --- --- __Exercise:__ Fix the type error, either by changing the value to decode or --- changing the expected type - --- $imports --- --- You might wonder why in some cases we can decode a configuration file: --- --- >>> writeFile "bool" "True" --- >>> input auto "./bool" :: IO Bool --- True --- --- ... and in other cases we can decode a value directly: --- --- >>> input auto "True" :: IO Bool --- True --- --- This is because importing a configuration from a file is a special case of a --- more general language feature: Dhall expressions can reference other --- expressions by their file path. --- --- To illustrate this, let's create three files: --- --- > $ echo "True" > bool1 --- > $ echo "False" > bool2 --- > $ echo "./bool1 && ./bool2" > both --- --- ... and read in all three files in a single expression: --- --- >>> input auto "[ ./bool1 , ./bool2 , ./both ]" :: IO (Vector Bool) --- [True,False,False] --- --- Each file path is replaced with the Dhall expression contained within that --- file. If that file contains references to other files then those references --- are transitively resolved. --- --- In other words: configuration files can reference other configuration files, --- either by their relative or absolute paths. This means that we can split a --- configuration file into multiple files, like this: --- --- > $ cat > ./config < { foo = 1 --- > , bar = ./bar --- > } --- > EOF --- --- > $ echo "[3.0, 4.0, 5.0]" > ./bar --- --- > $ ./example --- > Example {foo = 1, bar = [3.0,4.0,5.0]} --- --- However, the Dhall language will forbid cycles in these file references. For --- example, if we create the following cycle: --- --- > $ echo './file1' > file2 --- > $ echo './file2' > file1 --- --- ... then the interpreter will reject the import: --- --- >>> input auto "./file1" :: IO Natural --- *** Exception: --- ↳ ./file1 --- ↳ ./file2 --- ... --- Cyclic import: ./file1 --- ... --- --- You can also import expressions by URL. For example, you can find a Dhall --- expression hosted at this GitHub URL: --- --- --- --- > $ curl https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True --- > True --- --- ... and you can reference that expression either directly: --- --- >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool --- True --- --- ... or inside of a larger expression: --- --- >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool --- False --- --- You're not limited to hosting Dhall expressions on GitHub. You can host a --- Dhall expression anywhere that you can host UTF8-encoded text on the web, --- as a pastebin, or your own web server. --- --- You can also import Dhall expressions from environment variables, too: --- --- >>> System.Environment.setEnv "FOO" "1" --- >>> input auto "env:FOO" :: IO Natural --- 1 --- --- You can import types, too. For example, we can change our @./bar@ file to: --- --- > $ echo "[3.0, 4.0, 5.0] : List ./type" > ./bar --- --- ... then specify the @./type@ in a separate file: --- --- > $ echo "Double" > ./type --- --- ... and everything still type checks: --- --- > $ ./example --- > Example {foo = 1, bar = [3.0,4.0,5.0]} --- --- Note that all imports must be terminated by whitespace or you will get either --- an import error or a parse error, like this: --- --- >>> writeFile "baz" "2.0" --- >>> input auto "./baz: Double" :: IO Double --- *** Exception: --- ↳ ./baz: --- ... --- ...Error...: Missing file ...baz: --- ... --- --- This is because the parser thinks that @./baz:@ is a single token due to --- the missing whitespace before the colon and tries to import a file named --- @./baz:@, which does not exist. To fix the problem we have to add a space --- after @./baz@: --- --- >>> input auto "./baz : Double" :: IO Double --- 2.0 --- --- __Exercise:__ There is a @not@ function hosted online here: --- --- --- --- Visit that link and read the documentation. Then try to guess what this --- code returns: --- --- > >>> input auto "https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool --- > ??? --- --- Run the code to test your guess - --- $lists --- --- You can store 0 or more values of the same type in a list, like this: --- --- > [1, 2, 3] --- --- Every list can be followed by the type of the list. The type annotation is --- required for empty lists but optional for non-empty lists. You will get a --- type error if you provide an empty list without a type annotation: --- --- >>> input auto "[]" :: IO (Vector Natural) --- *** Exception: --- ...Error...: An empty list requires a type annotation --- ... --- 1│ [] --- ... --- (input):1:1 --- --- Also, list elements must all have the same type. You will get an error if --- you try to store elements of different types in a list: --- --- >>> input auto "[1, True, 3]" :: IO (Vector Natural) --- *** Exception: --- ...Error...: List elements should all have the same type --- ... --- - Natural --- + Bool --- ... --- 1│ True --- ... --- (input):1:5 --- ... --- --- __Exercise:__ What is the shortest @./config@ file that you can decode using --- this command: --- --- > >>> input auto "./config" :: IO (Vector (Vector Natural)) - --- $optional0 --- --- @Optional@ values are either of the form @Some aValue@ or @None aType@. --- --- For example, these are valid @Optional@ values: --- --- > Some 1 --- > --- > None Natural --- --- ... which both have type @Optional Natural@ --- --- An @Optional@ corresponds to Haskell's `Maybe` type for decoding purposes: --- --- >>> input auto "Some 1" :: IO (Maybe Natural) --- Just 1 --- >>> input auto "None Natural" :: IO (Maybe Natural) --- Nothing --- --- __Exercise:__ Author a @./config@ file that you can decode like this: --- --- > >>> input auto "./config" :: IO (Maybe (Maybe (Maybe Natural))) --- > ??? - --- $records --- --- Record literals are delimited by curly braces and their fields are separated --- by commas. For example, this is a valid record literal: --- --- > { foo = True --- > , bar = 2 --- > , baz = 4.2 --- > } --- --- A record type is like a record literal except instead of specifying each --- field's value we specify each field's type. For example, the preceding --- record literal has the following record type: --- --- > { foo : Bool --- > , bar : Natural --- > , baz : Double --- > } --- --- If you want to specify an empty record literal, you must use @{=}@, which is --- special syntax reserved for empty records. If you want to specify the empty --- record type, then you use @{}@. If you forget which is which you can always --- ask the @dhall@ compiler to remind you of the type for each one: --- --- > $ dhall --- > {=} --- > --- > {} --- > --- > {=} --- --- > $ dhall --- > {} --- > --- > Type --- > --- > {} --- --- You can access a field of a record using the following syntax: --- --- > record.fieldName --- --- ... which means to access the value of the field named @fieldName@ from the --- @record@. For example: --- --- >>> input auto "{ foo = True, bar = 2, baz = 4.2 }.baz" :: IO Double --- 4.2 --- --- ... and you can project out multiple fields into a new record using this --- syntax: --- --- > someRecord.{ field₀, field₁, … } --- --- For example: --- --- > $ dhall --- > { x = 1, y = True, z = "ABC" }.{ x, y } --- > --- > { x : Natural, y : Bool } --- > --- > { x = 1, y = True } --- --- __Exercise__: What is the type of this record: --- --- > { foo = 1 --- > , bar = --- > { baz = 2.0 --- > , qux = True --- > } --- > } --- --- __Exercise__: Save the above code to a file named @./record@ and then try to --- access the value of the @baz@ field - --- $functions --- --- The Dhall programming language also supports user-defined anonymous --- functions. For example, we can save the following anonymous function to a --- file: --- --- > $ cat > makeBools --- > \(n : Bool) -> --- > [ n && True, n && False, n || True, n || False ] --- > --- --- ... or we can use Dhall's support for Unicode characters to use @λ@ (U+03BB) --- instead of @\\@ and @→@ (U+2192) instead of @->@ (for people who are into that --- sort of thing): --- --- > $ cat > makeBools --- > λ(n : Bool) → --- > [ n && True, n && False, n || True, n || False ] --- > --- --- You can read this as a function of one argument named @n@ that has type --- @Bool@. This function returns a @List@ of @Bool@s. Each element of the --- @List@ depends on the input argument named @n@. --- --- The (ASCII) syntax for anonymous functions resembles the syntax for anonymous --- functions in Haskell. The only difference is that Dhall requires you to --- annotate the type of the function's input. --- --- You can import this function into Haskell, too: --- --- >>> makeBools <- input auto "./makeBools" :: IO (Bool -> Vector Bool) --- >>> makeBools True --- [True,False,True,True] --- --- The reason this works is that there is an `Interpret` instance for simple --- functions: --- --- > instance (Inject a, Interpret b) => Interpret (a -> b) --- --- Thanks to currying, this instance works for functions of multiple simple --- arguments: --- --- >>> dhallAnd <- input auto "λ(x : Bool) → λ(y : Bool) → x && y" :: IO (Bool -> Bool -> Bool) --- >>> dhallAnd True False --- False --- --- However, you can't convert anything more complex than that (like a polymorphic --- or higher-order function). You will need to apply those functions to their --- arguments within Dhall before converting their result to a Haskell value. --- --- Just like `Interpret`, you can derive `Inject` for user-defined data types: --- --- > {-# LANGUAGE DeriveAnyClass #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > module Main where --- > --- > import Dhall --- > --- > data Example0 = Example0 { foo :: Bool, bar :: Bool } --- > deriving (Generic, Inject) --- > --- > main = do --- > f <- input auto "λ(r : { foo : Bool, bar : Bool }) → r.foo && r.bar" --- > print (f (Example0 { foo = True, bar = False }) :: Bool) --- > print (f (Example0 { foo = True, bar = True }) :: Bool) --- --- The above program prints: --- --- > False --- > True - --- $compiler --- --- We can also test our @makeBools@ function directly from the command line. --- This library comes with a command-line executable program named @dhall@ that --- you can use to both type-check files and convert them to a normal form. Our --- compiler takes a program on standard input and then prints the program's type --- to standard error followed by the program's normal form to standard output: --- --- > $ dhall --- > ./makeBools --- > --- > ∀(n : Bool) → List Bool --- > --- > λ(n : Bool) → [ n, False, True, n ] --- --- The first line says that @makeBools@ is a function of one argument named @n@ --- that has type @Bool@ and the function returns a @List@ of @Bool@s. The @∀@ --- (U+2200) symbol is shorthand for the ASCII @forall@ keyword: --- --- > ∀(x : a) → b -- This type ... --- > --- > forall (x : a) → b -- ... is the same as this type --- --- ... and Dhall's @forall@ keyword behaves the same way as Haskell's @forall@ --- keyword for input values that are @Type@s: --- --- > forall (x : Type) → b -- This Dhall type ... --- --- > forall x . b -- ... is the same as this Haskell type --- --- The part where Dhall differs from Haskell is that you can also use --- @∀@/@forall@ to give names to non-@Type@ arguments (such as the first --- argument to @makeBools@). --- --- The second line of Dhall's output is our program's normal form: --- --- > λ(n : Bool) → [ n, False, True, n ] --- --- ... and the interpreter was able to simplify our expression by noting that: --- --- * @n && True = n@ --- * @n && False = False@ --- * @n || True = True@ --- * @n || False = n@ --- --- To apply a function to an argument you separate the function and argument by --- whitespace (just like Haskell): --- --- @f x@ --- --- You can read the above as \"apply the function @f@ to the argument @x@\". This --- means that we can \"apply\" our @./makeBools@ function to a @Bool@ argument --- like this: --- --- > $ dhall --- > ./makeBools True --- > --- > List Bool --- > --- > [True, False, True, True] --- --- Remember that file paths are synonymous with their contents, so the above --- code is exactly equivalent to: --- --- > $ dhall --- > (λ(n : Bool) → [n && True, n && False, n || True, n || False]) True --- > --- > List Bool --- > --- > [True, False, True, True] --- --- When you apply an anonymous function to an argument, you substitute the --- \"bound variable" with the function's argument: --- --- > Bound variable --- > ⇩ --- > (λ(n : Bool) → ...) True --- > ⇧ --- > Function argument --- --- So in our above example, we would replace all occurrences of @n@ with @True@, --- like this: --- --- > -- If we replace all of these `n`s with `True` ... --- > [n && True, n && False, n || True, n || False] --- > --- > -- ... then we get this: --- > [True && True, True && False, True || True, True || False] --- > --- > -- ... which reduces to the following normal form: --- > [True, False, True, True] --- --- Now that we've verified that our function type checks and works, we can use --- the same function within Haskell: --- --- >>> input auto "./makeBools True" :: IO (Vector Bool) --- [True,False,True,True] --- --- __Exercise__: Create a file named @getFoo@ that is a function of the following --- type: --- --- > ∀(r : { foo : Bool, bar : Text }) → Bool --- --- This function should take a single input argument named @r@ that is a record --- with two fields. The function should return the value of the @foo@ field. --- --- __Exercise__: Use the @dhall@ compiler to infer the type of the function you --- just created and verify that your function has the correct type --- --- __Exercise__: Use the @dhall@ compiler to apply your function to a sample --- record - --- $strings --- Dhall supports ordinary string literals with Haskell-style escaping rules: --- --- > dhall --- > "Hello, \"world\"!" --- > --- > Text --- > --- > "Hello, \"world\"!" --- --- ... and Dhall also supports Nix-style multi-line string literals: --- --- > dhall --- > '' --- > #!/bin/bash --- > --- > echo "Hi!" --- > '' --- > --- > Text --- > --- > "\n#!/bin/bash\n\necho \"Hi!\"\n" --- --- These \"double single quote strings\" ignore all special characters, with one --- exception: if you want to include a @''@ in the string, you will need to --- escape it with a preceding @'@ (i.e. use @'''@ to insert @''@ into the final --- string). --- --- These strings also strip leading whitespace using the same rules as Nix. --- Specifically: \"it strips from each line a number of spaces equal to the --- minimal indentation of the string as a whole (disregarding the indentation --- of empty lines).\" --- --- You can also interpolate expressions into strings using @${...}@ syntax. For --- example: --- --- > $ dhall --- > let name = "John Doe" --- > in let age = 21 --- > in "My name is ${name} and my age is ${Natural/show age}" --- > --- > Text --- > --- > "My name is John Doe and my age is 21" --- --- Note that you can only interpolate expressions of type @Text@ --- --- If you need to insert a @"${"@ into a string without interpolation then use --- @"''${"@ (same as Nix) --- --- > '' --- > for file in *; do --- > echo "Found ''${file}" --- > done --- > '' - --- $combine --- --- You can combine two records, using either the @(//)@ operator or the --- @(/\\)@ operator. --- --- The @(//)@ operator (or @(⫽)@ U+2AFD) combines the fields of both records, --- preferring fields from the right record if they share fields in common: --- --- > $ dhall --- > { foo = 1, bar = "ABC" } // { baz = True } --- > --- > { bar : Text, baz : Bool, foo : Natural } --- > --- > { bar = "ABC", baz = True, foo = 1 } --- > $ dhall --- > { foo = 1, bar = "ABC" } ⫽ { bar = True } -- Fancy unicode --- > --- > { bar : Bool, foo : Natural } --- > --- > { bar = True, foo = 1 } --- --- Note that the order of record fields does not matter. The compiler --- automatically sorts the fields. --- --- The @(/\\)@ operator (or @(∧)@ U+2227) also lets you combine records, but --- behaves differently if the records share fields in common. The operator --- combines shared fields recursively if they are both records: --- --- > $ dhall --- > { foo = { bar = True }, baz = "ABC" } /\ { foo = { qux = 1.0 } } --- > --- > { baz : Text, foo : { bar : Bool, qux : Double } } --- > --- > { baz = "ABC", foo = { bar = True, qux = 1.0 } } --- --- ... but fails with a type error if either shared field is not a record: --- --- > $ dhall --- > { foo = 1, bar = "ABC" } ∧ { foo = True } --- > --- > Use "dhall --explain" for detailed errors --- > --- > Error: Field collision --- > --- > { foo = 1, bar = "ABC" } ∧ { foo = True } --- > --- > (stdin):1:1 --- --- __Exercise__: Combine any record with the empty record. What do you expect --- to happen? --- --- You can analogously combine record types using the @//\\\\@ operator (or @(⩓)@ U+2A53): --- --- > $ dhall --- > { foo : Natural } ⩓ { bar : Text } --- > --- > { foo : Natural, bar : Text } --- --- ... which behaves the exact same, except at the type level, meaning that the --- operator descends recursively into record types: --- --- > $ dhall --- > { foo : { bar : Text } } ⩓ { foo : { baz : Bool }, qux : Natural } --- > --- > { foo : { bar : Text, baz : Bool }, qux : Natural } - --- $let --- --- Dhall also supports @let@ expressions, which you can use to define --- intermediate values in the course of a computation, like this: --- --- > $ dhall --- > let x = "ha" in x ++ x --- > --- > Text --- > --- > "haha" --- --- You can also annotate the types of values defined within a @let@ expression, --- like this: --- --- > $ dhall --- > let x : Text = "ha" in x ++ x --- > --- > Text --- > --- > "haha" --- --- You need to nest @let@ expressions if you want to define more than one value --- in this way: --- --- > $ dhall --- > let x = "Hello, " --- > in let y = "world!" --- > in x ++ y --- > --- > Text --- > --- > "Hello, world!" --- --- Dhall is whitespace-insensitive, so feel free to format things over multiple --- lines or indent in any way that you please. --- --- If you want to define a named function, just give a name to an anonymous --- function: --- --- > $ dhall --- > let twice = λ(x : Text) → x ++ x in twice "ha" --- > --- > Text --- > --- > "haha" --- --- Unlike Haskell, Dhall does not support function arguments on the left-hand --- side of the equals sign, so this will not work: --- --- > $ dhall --- > let twice (x : Text) = x ++ x in twice "ha" --- > --- > Error: Invalid input --- > --- > (stdin):1:11: --- > | --- > 1 | let twice (x : Text) = x ++ x in twice "ha" --- > | ^ --- > unexpected '(' --- > expecting ':', '=', or the rest of label --- --- The error message says that Dhall expected either a @(:)@ (i.e. the beginning --- of a type annotation) or a @(=)@ (the beginning of the assignment) and not a --- function argument. --- --- You can also use @let@ expressions to rename imports, like this: --- --- > $ dhall --- > let not = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not --- > in not True --- > --- > Bool --- > --- > False --- --- ... or to define synonyms for types: --- --- > $ dhall <<< 'let Name : Type = Text in [ "John", "Mary" ] : List Name' --- > List Text --- > --- > [ "John", "Mary" ] --- --- __Exercise:__ What do you think the following code will normalize to? --- --- > let x = 1 --- > in let x = 2 --- > in x --- --- Test your guess using the @dhall@ compiler --- --- __Exercise:__ Now try to guess what this code will normalize to: --- --- > let x = "ha" --- > in let x = x ++ "ha" --- > in x --- --- __Exercise:__ What about this code? --- --- > let x = x ++ "ha" --- > in x - --- $unions --- --- A union is a value that can be one of many alternative types of values. For --- example, the following union type: --- --- > < Left : Natural | Right : Bool > --- --- ... represents a value that can be either a @Natural@ or a @Bool@ value. If --- you are familiar with Haskell these are exactly analogous to Haskell's --- \"sum types\". --- --- Each alternative is associated with a tag that distinguishes that alternative --- from other alternatives. In the above example, the @Left@ tag is used for --- the @Natural@ alternative and the @Right@ tag is used for the @Bool@ --- alternative. --- --- You can specify the value of a union constructor like this: --- --- > let Union = < Left : Natural | Right : Bool> --- > --- > [ Union.Left 0, Union.Right True ] : List Union --- --- In other words, you can access a union constructor as a field of a union --- type and use that constructor to wrap a value of a type appropriate for --- that alternative. In the above example, the @Left@ constructor can wrap --- a @Natural@ value and the @Right@ constructor can wrap a @Bool@ value. We --- can also confirm that by inspecting their type: --- --- > $ echo '< Left : Natural | Right : Bool>' > ./Union --- --- > $ dhall --annotate <<< '(./Union).Left' --- > < Left : Natural | Right : Bool >.Left --- > : ∀(Left : Natural) → < Left : Natural | Right : Bool > --- --- > $ dhall --annotate <<< '(./Union).Right' --- > < Left : Natural | Right : Bool >.Right --- > : ∀(Right : Bool) → < Left : Natural | Right : Bool > --- --- In other words, the @Left@ constructor is a function from a @Natural@ to a --- value of our @Union@ type and the @Right@ constructor is a separate function --- from a @Bool@ to that same @Union@ type. --- --- You can consume a union using the built-in @merge@ function. For example, --- suppose we want to convert our union to a @Bool@ but we want to behave --- differently depending on whether or not the union is a @Natural@ wrapped in --- the @Left@ constructor or a @Bool@ wrapped in the @Right@ constructor . We --- would write: --- --- > $ cat > process < λ(union : < Left : Natural | Right : Bool >) --- > → let handlers = --- > { Left = Natural/even -- Natural/even is a built-in function --- > , Right = λ(b : Bool) → b --- > } --- > in merge handlers union : Bool --- > EOF --- --- Now our @./process@ function can handle both alternatives: --- --- > $ dhall <<< './process ((./Union).Left 3)' --- > False --- --- > $ dhall <<< './process ((./Union).Right True)' --- > True --- --- Every @merge@ has the following form: --- --- > merge handlers union : type --- --- ... where: --- --- * @union@ is the union you want to consume --- * @handlers@ is a record with one function per alternative of the union --- * @type@ is the declared result type of the @merge@ --- --- The @merge@ function selects which function to apply from the record based on --- which alternative the union selects: --- --- > merge { Foo = f, ... } (< … >.Foo x) = f x --- --- So, for example: --- --- > merge { Left = Natural/even, Right = λ(b : Bool) → b } (< Left : Natural | Right : Bool >.Left 3) --- > = Natural/even 3 --- > = False --- --- ... and similarly: --- --- > merge { Left = Natural/even, Right = λ(b : Bool) → b } (< Left : Natural | Right : Bool >.Right True) --- > = (λ(b : Bool) → b) True --- > = True --- --- Notice that each handler has to return the same type of result (@Bool@ in --- this case). --- --- You can also store more than one value within alternatives using Dhall's --- support for anonymous records. You can nest an anonymous record within a --- union such as in this type: --- --- > < Empty : {} | Person : { name : Text, age : Natural } > --- --- You can even go a step further and omit the type of an alternative if it --- stores no data, like this: --- --- > < Empty | Person : { name : Text, age : Natural } > --- --- --- This union of records resembles following equivalent Haskell data type: --- --- > data Example = Empty | Person { name :: Text, age :: Text } --- --- Empty alternatives like @Empty@ require no argument: --- --- > let MyType = < Empty | Person : { name : Text, age : Natural } > --- > --- > in [ MyType.Empty -- Note the absence of any argument to `Empty` --- > , MyType.Person { name = "John", age = 23 } --- > , MyType.Person { name = "Amy" , age = 25 } --- > ] --- --- ... and when you @merge@ an empty alternative the correspond handler takes no --- argument: --- --- > λ(x : < Empty | Person : { name : Text, age : Natural } >) --- > → merge --- > { Empty = "Unknown" -- Note the absence of a `λ` --- > --- > , Person = --- > λ(person : { name : Text, age : Natural }) --- > → "Name: ${person.name}, Age: ${Natural/show person.age}" --- > } --- > x --- --- __Exercise__: Create a list of the following type with at least one element --- per alternative: --- --- > List < Left : Natural | Right : Double > - --- $polymorphic --- --- The Dhall language supports defining polymorphic functions (a.k.a. --- \"generic\" functions) that work on more than one type of value. However, --- Dhall differs from Haskell by not inferring the types of these polymorphic --- functions. Instead, you must be explicit about what type of value the --- function is specialized to. --- --- Take, for example, Haskell's identity function named @id@: --- --- > id :: a -> a --- > id = \x -> x --- --- The identity function is polymorphic, meaning that `id` works on values of --- different types: --- --- >>> id 4 --- 4 --- >>> id True --- True --- --- The equivalent function in Dhall is: --- --- > λ(a : Type) → λ(x : a) → x --- --- Notice how this function takes two arguments instead of one. The first --- argument is the type of the second argument. --- --- Let's illustrate how this works by actually using the above function: --- --- > $ echo "λ(a : Type) → λ(x : a) → x" > id --- --- If we supply the function alone to the compiler we get the inferred type as --- the first line: --- --- > $ dhall --- > ./id --- > --- > ∀(a : Type) → ∀(x : a) → a --- > --- > λ(a : Type) → λ(x : a) → x --- --- You can read the type @(∀(a : Type) → ∀(x : a) → a)@ as saying: \"This is the --- type of a function whose first argument is named @a@ and is a @Type@. The --- second argument is named @x@ and has type @a@ (i.e. the value of the first --- argument). The result also has type @a@.\" --- --- This means that the type of the second argument changes depending on what --- type we provide for the first argument. When we apply @./id@ to @Natural@, --- we create a function that expects an @Natural@ argument: --- --- > $ dhall --- > ./id Natural --- > --- > ∀(x : Natural) → Natural --- > --- > λ(x : Natural) → x --- --- Similarly, when we apply @./id@ to @Bool@, we create a function that expects a --- @Bool@ argument: --- --- > $ dhall --- > ./id Bool --- > --- > ∀(x : Bool) → Bool --- > --- > λ(x : Bool) → x --- --- We can then supply the final argument to each of those functions to show --- that they both work on their respective types: --- --- > $ dhall --- > ./id Natural 4 --- > --- > Natural --- > --- > 4 --- --- > $ dhall --- > ./id Bool True --- > --- > Bool --- > --- > True --- --- Built-in functions can also be polymorphic, too. For example, we can ask --- the compiler for the type of @List/reverse@, the function that reverses a --- list: --- --- > $ dhall --- > List/reverse --- > --- > ∀(a : Type) → List a → List a --- > --- > List/reverse --- --- The first argument to @List/reverse@ is the type of the list to reverse: --- --- > $ dhall --- > List/reverse Bool --- > --- > List Bool → List Bool --- > --- > List/reverse Bool --- --- ... and the second argument is the list to reverse: --- --- > $ dhall --- > List/reverse Bool [True, False] --- > --- > List Bool --- > --- > [False, True] : List Bool --- --- Note that the second argument has no name. This type: --- --- > ∀(a : Type) → List a → List a --- --- ... is equivalent to this type: --- --- > ∀(a : Type) → ∀(_ : List a) → List a --- --- In other words, if you don't see the @∀@ symbol surrounding a function --- argument type then that means that the name of the argument is @"_"@. This --- is true even for user-defined functions: --- --- > $ dhall --- > λ(_ : Text) → 1 --- > --- > Text → Natural --- > --- > λ(_ : Text) → 1 --- --- The type @(Text → Natural)@ is the same as @(∀(_ : Text) → Natural)@ --- --- __Exercise__ : Translate Haskell's `flip` function to Dhall - --- $total --- --- Dhall is a total programming language, which means that Dhall is not --- Turing-complete and evaluation of every Dhall program is guaranteed to --- eventually halt. There is no upper bound on how long the program might take --- to evaluate, but the program is guaranteed to terminate in a finite amount of --- time and not hang forever. --- --- This guarantees that all Dhall programs can be safely reduced to a normal --- form where as many functions have been evaluated as possible. In fact, Dhall --- expressions can be evaluated even if all function arguments haven't been fully --- applied. For example, the following program is an anonymous function: --- --- > $ dhall --- > \(n : Bool) -> 10 * 10 --- > --- > ∀(n : Bool) → Natural --- > --- > λ(n : Bool) → 100 --- --- ... and even though the function is still missing the first argument named --- @n@ the compiler is smart enough to evaluate the body of the anonymous --- function ahead of time before the function has even been invoked. --- --- We can use the @map@ function from the Prelude to illustrate an even more --- complex example: --- --- > $ dhall --- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map --- > in λ(f : Natural → Natural) → Prelude/List/map Natural Natural f [1, 2, 3] --- > --- > ∀(f : Natural → Natural) → List Natural --- > --- > λ(f : Natural → Natural) → [f 1, f 2, f 3] : List Natural --- --- Dhall can apply our function to each element of the list even before we specify --- which function to apply. --- --- The language will also never crash or throw any exceptions. Every --- computation will succeed and produce something, even if the result might be --- an @Optional@ value: --- --- > $ dhall --- > List/head Natural ([] : List Natural) --- > --- > Optional Natural --- > --- > None Natural --- --- __Exercise__: The Dhall Prelude provides a @replicate@ function which you can --- find here: --- --- --- --- Test what the following Dhall expression normalizes to: --- --- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate --- > in replicate 10 --- --- __Exercise__: If you have a lot of spare time, try to \"break the compiler\" by --- finding an input expression that crashes or loops forever (and file a bug --- report if you succeed) - --- $assertions --- --- You can add compile-time assertions which you can use to add tests to your --- code. For example, we can add some tests to our @not@ function like this: --- --- > let not : Bool -> Bool = \(b : Bool) -> b == False --- > --- > let example0 = assert : not False === True --- > --- > let example1 = assert : not True === False --- > --- > in not --- --- The expression @assert : not False == True@ is a type-checking assertion --- that two expressions have the same normal form. If the two expressions differ --- then type-checking rejects the code. --- --- For example, suppose that we change the example to add an incorrect assertion: --- --- > -- ./test.dhall --- > --- > let not : Bool -> Bool = \(b : Bool) -> b == False --- > --- > let example0 = assert : not False === True --- > --- > let example1 = assert : not True === True -- Oops! --- > --- > in not --- --- The type-checker then rejects the assertion with the following error message: --- --- > $ dhall <<< './test.dhall' --- > --- > ↳ ./test.dhall --- > --- > Error: Assertion failed --- > --- > - False --- > + True --- > --- > 7│ assert : not True === True -- Oops! --- > 8│ --- > --- > ./test.dhall:7:16 --- > --- > 1│ ./test.dhall --- > --- > (stdin):1:1 --- --- You can compare expressions that contain variables, too, which is equivalent --- to symbolic reasoning: --- --- > $ dhall <<< '\(n : Natural) -> assert : n === (n + 0)' --- > λ(n : Natural) → assert : n ≡ n --- --- Dhall accepts this because the language has built-in support for normalizing --- @n + 0@ to @n@, so both sides of the comparison normalize to the same value: --- @n@. --- --- Note that this sort of symbolic reasoning is limited and can only detect --- equality of normal forms. Some equivalent expressions will be rejected --- if they don't share the same normal form, such as these: --- --- > $ dhall <<< '\(n : Natural) -> assert : Natural/even (n + n) === True' --- > --- > Use "dhall --explain" for detailed errors --- > --- > n : Natural --- > --- > Error: Assertion failed --- > --- > - … … --- > + True --- > --- > 1│ assert : Natural/even (n + n) === True --- > --- > (stdin):1:19 --- --- Here the normalizer is not smart enough to simplify @Natural/even (n + n)@ to --- @True@ so the assertion fails. --- --- If you prefer to use Unicode, then the Unicode equivalent of @===@ is @≡@ --- (U+2261). - --- $headers --- --- Sometimes you would like to provide additional request headers when importing --- Dhall expressions from URLs. For example, you might want to provide an --- authorization header or specify the expected content type. --- --- Dhall URL imports let you add or modify request headers with the @using@ --- keyword: --- --- > https://example.com/example.dhall using ./headers --- --- ... where you can replace @./headers@ with any import that points to a Dhall --- expression of the following type: --- --- > List { header : Text, value : Text } --- --- For example, if you needed to specify the content type correctly in order to --- download the file, then your @./headers@ file might look like this: --- --- > $ cat headers --- > [ { header = "Accept", value = "application/dhall" } ] --- --- ... or if you needed to provide an authorization token to access a private --- GitHub repository, then your headers could look like this: --- --- > [ { header = "Authorization", value = "token ${env:GITHUB_TOKEN as Text}" } ] --- --- This would read your GitHub API token from the @GITHUB_TOKEN@ environment --- variable and supply that token in the authorization header. --- --- You cannot inline the headers within the same file as the URL. You must --- provide them as a separate import. That means that this is /not/ legal code: --- --- > http://example.com/example.dhall using [ { header = "Accept", value = "application/dhall" } ] -- NOT legal --- --- Dhall will forward imports if you import an expression from a URL that --- contains a relative import. For example, if you import an expression like --- this: --- --- > http://example.com/example.dhall using ./headers --- --- ... and @http:\/\/example.com/example.dhall@ contains a relative import of @./foo@ --- then Dhall will import @http:\/\/example.com/foo@ using the same @./headers@ file. - --- $integrity --- --- Sometimes you want to use share code while still ensuring that the imported --- value never changes and can't be corrupted by a malicious attacker. Dhall --- provides built-in support for hashing imported values to verify that their --- value never changes --- --- For example, suppose you save the following two files: --- --- > $ cat ./foo --- > ./bar sha256:d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 --- --- > $ cat ./bar --- > ./baz --- --- > $ cat ./baz --- > 1 --- --- The first file named @./foo@ contains an example of an integrity check. You --- can add @sha256:XXX@ after any import (such as after @./bar@), where @XXX@ is --- an expected 64-character @sha256@ hash of the Dhall value. To be precise, --- the hash represents a @sha256@ hash of the UTF-8 encoding of a canonical text --- representation of the fully resolved and normalized abstract syntax tree of --- the imported expression. --- --- Dhall will verify that the expected hash matches the actual hash of the --- imported Dhall value and reject the import if there is a hash mismatch: --- --- > $ dhall <<< './foo' --- > Natural --- > --- > 1 --- --- Any import protected by a semantic integrity check is automatically cached --- locally underneath either @~\/.cache\/dhall\/1220${HASH}@ or --- @${XDG_CACHE_HOME}\/dhall/1220${HASH}@ if you define the @XDG_CACHE_HOME@ --- environment variable. --- --- For example, after you import @./foo@ the contents of `./bar` are locally --- cached in a fully-evaluated and binary-encoded form which you can inspect by --- running: --- --- > $ dhall decode < ~/.cache/dhall/1220d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 --- > 1 --- --- Subsequent attempts to resolve the same import will automatically retrieve --- the import from the cache. This matters less for local imports, but comes in --- handy for remote imports to avoid redownloading them. --- --- The local cache takes precedence when resolving imports, so changing the --- original import afterwards will have no affect until you update the hash. --- From Dhall's point of view, the hash is the true address and the file path --- is just a suggestion for how to obtain the import if it's not already cached. --- --- You can disable the cache by setting `XDG_CACHE_HOME` to `/var/empty` (an --- empty and unwritable directory), like this: --- --- > $ XDG_CACHE_HOME=/var/empty dhall <<< './foo' --- > Natural --- > --- > 1 --- --- 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: --- --- > $ cat ./bar --- > -- This comment does not change the hash --- > ./baz --- --- ... then @./foo@ will still successfully import @./bar@ because the hash --- only depends on the normalized value and does not depend on meaningless --- changes to whitespace or comments: --- --- > $ XDG_CACHE_HOME=/var/empty dhall <<< './foo' # This still succeeds --- > Natural --- > --- > 1 --- --- You can compute the Hash for any import by using the hash subcommand --- of this package. For example: --- --- > $ dhall hash <<< './bar' --- > sha256:d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 --- --- Now suppose that you actually change the value of the @./baz@ file: --- --- > $ cat ./baz --- > 2 --- --- ... then the @./foo@ file will fail to import @./bar@, even though the --- text of the @./bar@ file technically never changed: --- --- > XDG_CACHE_HOME=/var/empty dhall <<< './foo' --- > --- > Error: Import integrity check failed --- > --- > Expected hash: --- > --- > ↳ d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 --- > --- > Actual hash: --- > --- > ↳ 4caf97e8c445d4d4b5c5b992973e098ed4ae88a355915f5a59db640a589bc9cb --- --- This is because the @./bar@ file now represents a new value (@2@ instead of --- @1@), even though the text of the @./bar@ file is still the same. Since the --- value changed the hash must change as well. However, we could change @./baz@ --- to: --- --- > $ cat baz --- > if True then 1 else 2 --- --- ... and the import would now succeed again because the final result is @1@. --- --- The integrity hash ensures that your import's final meaning can never change, --- so an attacker can never compromise an imported value protected by a hash --- unless they can break SHA-256 encryption. The hash not only protects the --- file that you immediately import, but also protects every transitive import --- as well. --- --- You can also safely refactor your imported dependencies knowing that the --- refactor will not change your hash so long as your refactor is --- behavior-preserving. This provides an easy way to detect refactoring errors --- that you might accidentally introduce. The hash not only protects you --- from attackers, but also protects against human error, too! --- --- If you have a file which either doesn't already use hashed imports, --- or you changed some of the imports and want to update the hashes you can use the --- freeze command to either add or update hashes: --- --- > $ cat foo.dhall --- > let replicate = --- > https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate --- > in replicate 5 --- > $ --- > $ dhall freeze --inplace ./foo.dhall --- > $ cat ./foo.dhall --- > let replicate = --- > https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate sha256:b0e3ec1797b32c80c0bcb7e8254b08c7e9e35e75e6b410c7ac21477ab90167ad --- > in replicate 5 - --- $rawText --- --- Sometimes you want to import the contents of a raw text file as a Dhall --- value of type `Text`. For example, one of the fields of a record might be --- the contents of a software license: --- --- > { package = "dhall" --- > , author = "Gabriel Gonzalez" --- > , license = ./LICENSE --- > } --- --- Normally if you wanted to import a text file you would need to wrap the --- contents of the file in double single-quotes, like this: --- --- > $ cat LICENSE --- > '' --- > Copyright (c) 2017 Gabriel Gonzalez --- > All rights reserved. --- > --- > ... --- > (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- > SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- > '' --- --- ... which does not work well if you need to reuse the same text file for --- other programs --- --- However, Dhall supports importing a raw text file by adding @as Text@ to the --- end of the import, like this: --- --- > { package = "dhall" --- > , author = "Gabriel Gonzalez" --- > , license = ./LICENSE as Text --- > } --- --- ... and then you can use the original text file unmodified: --- --- > $ cat LICENSE --- > Copyright (c) 2017 Gabriel Gonzalez --- > All rights reserved. --- > --- > ... --- > (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- > SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - --- $format --- --- A format subcommand is also available that you can use to --- automatically format Dhall expressions. For example, we can take the --- following unformatted Dhall expression: --- --- > $ cat ./unformatted --- > λ(a : Type) → λ(kvss : List (List { index : Natural, value : a })) → --- > List/build { index : Natural, value : a } (λ(list : Type) → λ(cons : { --- > index : Natural, value : a } → list → list) → λ(nil : list) → --- > (List/fold (List { index : Natural, value : a }) kvss { count : Natural, diff : --- > Natural → list } (λ(kvs : List { index : Natural, value : a }) → λ(y : { --- > count : Natural, diff : Natural → list }) → { count = y.count + List/length --- > { index : Natural, value : a } kvs, diff = λ(n : Natural) → List/fold { --- > index : Natural, value : a } kvs list (λ(kvOld : { index : Natural, value : a --- > }) → λ(z : list) → cons { index = kvOld.index + n, value = kvOld.value } --- > z) (y.diff (n + List/length { index : Natural, value : a } kvs)) }) { count = --- > 0, diff = λ(_ : Natural) → nil }).diff 0) --- --- ... and run the expression through the formatter: --- --- > $ dhall format < ./unformatted --- > λ(a : Type) --- > → λ(kvss : List (List { index : Natural, value : a })) --- > → List/build --- > { index : Natural, value : a } --- > ( λ(list : Type) --- > → λ(cons : { index : Natural, value : a } → list → list) --- > → λ(nil : list) --- > → ( List/fold --- > (List { index : Natural, value : a }) --- > kvss --- > { count : Natural, diff : Natural → list } --- > ( λ(kvs : List { index : Natural, value : a }) --- > → λ(y : { count : Natural, diff : Natural → list }) --- > → { count = y.count + List/length { index : Natural, value : a } kvs --- > , diff = --- > λ(n : Natural) --- > → List/fold --- > { index : Natural, value : a } --- > kvs --- > list --- > ( λ(kvOld : { index : Natural, value : a }) --- > → λ(z : list) --- > → cons { index = kvOld.index + n, value = kvOld.value } z --- > ) --- > (y.diff (n + List/length { index : Natural, value : a } kvs)) --- > } --- > ) --- > { count = 0, diff = λ(_ : Natural) → nil } --- > ).diff --- > 0 --- > ) --- --- The executable formats expressions without resolving, type-checking, or --- normalizing them: --- --- > $ dhall format --- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate --- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) --- > --- > let replicate = --- > https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate --- > --- > in replicate --- > 5 --- > (List (List Natural)) --- > (replicate 5 (List Natural) (replicate 5 Natural 1)) --- --- You can also use the formatter to modify files in place using the --- @--inplace@ flag (i.e. for formatting source code): --- --- > $ dhall format --inplace ./unformatted --- > $ cat ./unformatted --- > λ(a : Type) --- > → λ(kvss : List (List { index : Natural, value : a })) --- > → List/build --- > { index : Natural, value : a } --- > ( λ(list : Type) --- > → λ(cons : { index : Natural, value : a } → list → list) --- > → λ(nil : list) --- > → ( List/fold --- > (List { index : Natural, value : a }) --- > kvss --- > { count : Natural, diff : Natural → list } --- > ( λ(kvs : List { index : Natural, value : a }) --- > → λ(y : { count : Natural, diff : Natural → list }) --- > → { count = y.count + List/length { index : Natural, value : a } kvs --- > , diff = --- > λ(n : Natural) --- > → List/fold --- > { index : Natural, value : a } --- > kvs --- > list --- > ( λ(kvOld : { index : Natural, value : a }) --- > → λ(z : list) --- > → cons { index = kvOld.index + n, value = kvOld.value } z --- > ) --- > (y.diff (n + List/length { index : Natural, value : a } kvs)) --- > } --- > ) --- > { count = 0, diff = λ(_ : Natural) → nil } --- > ).diff --- > 0 --- > ) --- --- Carefully note that the code formatter does not preserve all comments. --- Currently, the formatter only preserves leading comments and whitespace --- up until the last newline preceding the code. In other words: --- --- > $ dhall format --- > {- This comment will be preserved by the formatter -} --- > -- ... and this comment will be preserved, too --- > {- This comment will *NOT* be preserved -} 1 --- > -- ... and this comment will also *NOT* be preserved --- > --- > {- This comment will be preserved by the formatter -} --- > -- ... and this comment will be preserved, too --- > 1 --- --- Note that you do not need to format the output of the --- @dhall@ interpreter. The interpreter already automatically formats --- multi-line expressions, too: --- --- > $ dhall --- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate --- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) --- > --- > List (List (List Natural)) --- > --- > [ [ [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > ] --- > : List (List Natural) --- > , [ [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > ] --- > : List (List Natural) --- > , [ [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > ] --- > : List (List Natural) --- > , [ [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > ] --- > : List (List Natural) --- > , [ [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > , [ 1, 1, 1, 1, 1 ] : List Natural --- > ] --- > : List (List Natural) --- > ] --- > : List (List (List Natural)) - --- $builtins --- --- Dhall is a restricted programming language that only supports simple built-in --- functions and operators. If you want to do anything fancier you will need to --- load your data into Haskell for further processing --- --- This section covers types, functions, and operators that are built into the --- language, meaning that you do not need to import any code to use them. --- Additionally, Dhall also comes with a Prelude (covered in the next section) --- hosted online that contains functions derived from these base utilities. The --- Prelude also re-exports all built-in functions for people who prefer --- consistency. --- --- The following documentation on built-ins is provided primarily as a reference. --- You don't need to read about every single built-in and you may want to skip to --- the following Prelude section. - --- The language provides built-in support for the following primitive types: --- --- * @Bool@ values --- * @Natural@ values --- * @Integer@ values --- * @Double@ values --- * @Text@ values --- --- ... as well as support for the following derived types: --- --- * @List@s of values --- * @Optional@ values --- * Anonymous records --- * Anonymous unions - --- $caveats --- --- Dhall differs in a few important ways from other programming languages, so --- you should keep the following caveats in mind: --- --- First, Dhall only supports addition and multiplication on @Natural@ numbers --- (i.e. non-negative integers), which are not the same type of number as --- @Integer@s (which can be negative). An @Integer@ number is a number prefixed --- with either a @+@ or @-@ symbol whereas a @Natural@ number has no leading --- sign. If you try to add or multiply two @Integer@s you will get a type --- error: --- --- > $ dhall --- > +2 + +2 --- > --- > Use "dhall --explain" for detailed errors --- > --- > Error: ❰+❱ only works on ❰Natural❱s --- > --- > +2 + +2 --- > --- > (stdin):1:1 --- --- In fact, there are no built-in functions for @Integer@s (or @Double@s). As --- far as the language is concerned they are opaque values that can only be --- shuffled around but not used in any meaningful way until they have been --- loaded into Haskell. --- --- Second, the equality @(==)@ and inequality @(!=)@ operators only work on --- @Bool@s. You cannot test any other types of values for equality. --- --- However, you can extend the language with your own built-ins using the --- Haskell API, as described in the next section. - --- $extending --- --- You can use the Haskell API to extend the Dhall configuration language with --- new built-in functions. This section contains a simple Haskell recipe to add --- a new @Natural/equal@ built-in function of type: --- --- > Natural/equal : Natural → Natural → Bool --- --- To do so, we: --- --- * extend the type-checking context to include the type of @Natural/equal@ --- * extend the normalizer to evaluate all occurrences of @Natural/equal@ --- --- ... like this: --- --- > -- example.hs --- > --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > module Main where --- > --- > import Dhall.Core (Expr(..), ReifiedNormalizer(..)) --- > --- > import qualified Data.Text.IO --- > import qualified Dhall --- > import qualified Dhall.Context --- > import qualified Lens.Family as Lens --- > --- > main :: IO () --- > main = do --- > text <- Data.Text.IO.getContents --- > --- > let startingContext = transform Dhall.Context.empty --- > where --- > transform = Dhall.Context.insert "Natural/equal" naturalEqualType --- > --- > naturalEqualType = --- > Pi "_" Natural (Pi "_" Natural Bool) --- > --- > let normalizer (App (App (Var "Natural/equal") (NaturalLit x)) (NaturalLit y)) = --- > Just (BoolLit (x == y)) --- > normalizer _ = --- > Nothing --- > --- > let inputSettings = transform Dhall.defaultInputSettings --- > where --- > transform = --- > Lens.set Dhall.normalizer (ReifiedNormalizer (pure . normalizer)) --- > . Lens.set Dhall.startingContext startingContext --- > --- > x <- Dhall.inputWithSettings inputSettings Dhall.auto text --- > --- > Data.Text.IO.putStrLn x --- --- Here is an example use of the above program: --- --- > $ ./example <<< 'if Natural/equal 2 (1 + 1) then "Equal" else "Not equal"' --- > Equal --- --- Note that existing Dhall tools that type-check expressions will reject --- expressions containing unexpected free variable such as @Natural/equal@: --- --- > $ dhall <<< 'Natural/equal 2 (1 + 1)' --- > --- > Use "dhall --explain" for detailed errors --- > --- > Error: Unbound variable --- > --- > Natural/equal --- > --- > (stdin):1:1 --- --- You will need to either: --- --- * create your own parallel versions of these tools, or: --- * < https://github.com/dhall-lang/dhall-lang/blob/master/.github/CONTRIBUTING.md#how-do-i-change-the-language try to upstream your built-ins into the language> --- --- The general guidelines for adding new built-ins to the language are: --- --- * Keep built-ins easy to implement across language bindings --- * Prefer general purpose built-ins or built-ins appropriate for the task of program configuration --- * Design built-ins to catch errors as early as possible (i.e. when type-checking the configuration) - --- $builtinOverview --- --- Each of the following sections provides an overview of builtin functions and --- operators for each type. For each function you get: --- --- * An example use of that function --- --- * A \"type judgement\" explaining when that function or operator is well --- typed --- --- For example, for the following judgement: --- --- > Γ ⊢ x : Bool Γ ⊢ y : Bool --- > ─────────────────────────── --- > Γ ⊢ x && y : Bool --- --- ... you can read that as saying: "if @x@ has type @Bool@ and @y@ has type --- @Bool@, then @x && y@ has type @Bool@" --- --- Similarly, for the following judgement: --- --- > ───────────────────────────────── --- > Γ ⊢ Natural/even : Natural → Bool --- --- ... you can read that as saying: "@Natural/even@ always has type --- @Natural → Bool@" --- --- * Rules for how that function or operator behaves --- --- These rules are just equalities that come in handy when reasoning about code. --- For example, the section on @(&&)@ has the following rules: --- --- > (x && y) && z = x && (y && z) --- > --- > x && True = x --- > --- > True && x = x --- --- These rules are also a contract for how the compiler should behave. If you --- ever observe code that does not obey these rules you should file a bug --- report. - --- $bool --- --- There are two values that have type @Bool@ named @True@ and @False@: --- --- > ─────────────── --- > Γ ⊢ True : Bool --- --- > ──────────────── --- > Γ ⊢ False : Bool --- --- The built-in operations for values of type @Bool@ are: --- - --- $or --- --- Example: --- --- > $ dhall --- > True || False --- > --- > Bool --- > --- > True --- --- Type: --- --- > Γ ⊢ x : Bool Γ ⊢ y : Bool --- > ─────────────────────────── --- > Γ ⊢ x || y : Bool --- --- Rules: --- --- > (x || y) || z = x || (y || z) --- > --- > x || False = x --- > --- > False || x = x --- > --- > x || (y && z) = (x || y) && (x || z) --- > --- > x || True = True --- > --- > True || x = True - --- $and --- --- Example: --- --- > $ dhall --- > True && False --- > --- > Bool --- > --- > False --- --- Type: --- --- > Γ ⊢ x : Bool Γ ⊢ y : Bool --- > ─────────────────────────── --- > Γ ⊢ x && y : Bool --- --- Rules: --- --- > (x && y) && z = x && (y && z) --- > --- > x && True = x --- > --- > True && x = x --- > --- > x && (y || z) = (x && y) || (x && z) --- > --- > x && False = False --- > --- > False && x = False - --- $equal --- --- Example: --- --- > $ dhall --- > True == False --- > --- > Bool --- > --- > False --- --- Type: --- --- > Γ ⊢ x : Bool Γ ⊢ y : Bool --- > ─────────────────────────── --- > Γ ⊢ x == y : Bool --- --- Rules: --- --- > (x == y) == z = x == (y == z) --- > --- > x == True = x --- > --- > True == x = x --- > --- > x == x = True - --- $unequal --- --- Example: --- --- > $ dhall --- > True != False --- > --- > Bool --- > --- > True --- --- Type: --- --- > Γ ⊢ x : Bool Γ ⊢ y : Bool --- > ─────────────────────────── --- > Γ ⊢ x != y : Bool --- --- Rules: --- --- > (x != y) != z = x != (y != z) --- > --- > x != False = x --- > --- > False != x = x --- > --- > x != x = False - --- $ifthenelse --- --- Example: --- --- > $ dhall --- > if True then 3 else 5 --- > --- > Natural --- > --- > 3 --- --- Type: --- --- > Γ ⊢ t : Type --- > ───────────────────── --- > Γ ⊢ b : Bool Γ ⊢ l : t Γ ⊢ r : t --- > ──────────────────────────────────── --- > Γ ⊢ if b then l else r : t --- --- Rules: --- --- > if b then True else False = b --- > --- > if True then l else r = l --- > --- > if False then l else r = r - --- $natural --- --- @Natural@ literals are non-negative numbers without any leading sign, like --- this: --- --- > 4 : Natural --- --- If you add a @+@ or @-@ sign then you get an @Integer@ literal, which is a --- different type of value - --- $plus --- --- Example: --- --- > $ dhall --- > 2 + 3 --- > --- > Natural --- > --- > 5 --- --- Type: --- --- > Γ ⊢ x : Natural Γ ⊢ y : Natural --- > ───────────────────────────────── --- > Γ ⊢ x + y : Natural --- --- Rules: --- --- > (x + y) + z = x + (y + z) --- > --- > x + 0 = x --- > --- > 0 + x = x - --- $times --- --- Example: --- --- > $ dhall --- > 2 * 3 --- > --- > Natural --- > --- > 6 --- --- Type: --- --- > Γ ⊢ x : Natural Γ ⊢ y : Natural --- > ───────────────────────────────── --- > Γ ⊢ x * y : Natural --- --- Rules: --- --- > (x * y) * z = x * (y * z) --- > --- > x * 1 = x --- > --- > 1 * x = x --- > --- > (x + y) * z = (x * z) + (y * z) --- > --- > x * (y + z) = (x * y) + (x * z) --- > --- > x * 0 = 0 --- > --- > 0 * x = 0 - --- $even --- --- Example: --- --- > $ dhall --- > Natural/even 6 --- > --- > Bool --- > --- > True --- --- Type: --- --- > ───────────────────────────────── --- > Γ ⊢ Natural/even : Natural → Bool --- --- Rules: --- --- > Natural/even (x + y) = Natural/even x == Natural/even y --- > --- > Natural/even 0 = True --- > --- > Natural/even (x * y) = Natural/even x || Natural/even y --- > --- > Natural/even 1 = False - --- $odd --- --- Example: --- --- > $ dhall --- > Natural/odd 6 --- > --- > Bool --- > --- > False --- --- Type: --- --- > ──────────────────────────────── --- > Γ ⊢ Natural/odd : Natural → Bool --- --- Rules: --- --- > Natural/odd (x + y) = Natural/odd x != Natural/odd y --- > --- > Natural/odd 0 = False --- > --- > Natural/odd (x * y) = Natural/odd x && Natural/odd y --- > --- > Natural/odd 1 = True - --- $isZero --- --- Example: --- --- > $ dhall --- > Natural/isZero 6 --- > --- > Bool --- > --- > False --- --- Type: --- --- > ─────────────────────────────────── --- > Γ ⊢ Natural/isZero : Natural → Bool --- --- Rules: --- --- > Natural/isZero (x + y) = Natural/isZero x && Natural/isZero y --- > --- > Natural/isZero 0 = True --- > --- > Natural/isZero (x * y) = Natural/isZero x || Natural/isZero y --- > --- > Natural/isZero 1 = False - --- $naturalFold --- --- Example: --- --- > $ dhall --- > Natural/fold 40 Text (λ(t : Text) → t ++ "!") "You're welcome" --- > --- > Text --- > --- > "You're welcome!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" --- --- Type: --- --- > ────────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ Natural/fold : Natural → ∀(natural : Type) → ∀(succ : natural → natural) → ∀(zero : natural) → natural --- --- Rules: --- --- > Natural/fold (x + y) n s z = Natural/fold x n s (Natural/fold y n s z) --- > --- > Natural/fold 0 n s z = z --- > --- > Natural/fold (x * y) n s = Natural/fold x n (Natural/fold y n s) --- > --- > Natural/fold 1 n s = s - --- $naturalBuild --- --- Example: --- --- > $ dhall --- > Natural/build (λ(natural : Type) → λ(succ : natural → natural) → λ(zero : natural) → succ (succ zero)) --- > --- > Natural --- > --- > 2 --- --- Type: --- --- > ───────────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ Natural/build : (∀(natural : Type) → ∀(succ : natural → natural) → ∀(zero : natural) → natural) → Natural --- --- Rules: --- --- > Natural/fold (Natural/build x) = x --- > --- > Natural/build (Natural/fold x) = x - --- $integer --- --- @Integer@ literals are prefixed with a @+@ (if they are non-negative) or a --- @-@ sign (if they are negative), like this: --- --- > +3 : Integer --- > -2 : Integer --- --- If you omit the sign then they are @Natural@ literals and not @Integer@s --- --- There are no built-in operations on @Integer@s. For all practical purposes --- they are opaque values within the Dhall language - --- $double --- --- A @Double@ literal is a floating point value with at least one decimal --- place, such as: --- --- > -2.0 : Double --- > 3.14159 : Double --- --- There are no built-in operations on @Double@s. For all practical purposes --- they are opaque values within the Dhall language - --- $text --- --- A @Text@ literal is just a sequence of characters enclosed in double quotes, --- like: --- --- > "ABC" : Text --- --- The only thing you can do with @Text@ values is concatenate them - --- $textAppend --- --- Example: --- --- > $ dhall --- > "Hello, " ++ "world!" --- > --- > Text --- > --- > "Hello, world!" --- --- Type: --- --- > Γ ⊢ x : Text Γ ⊢ y : Text --- > ─────────────────────────── --- > Γ ⊢ x && y : Text --- --- Rules: --- --- > (x ++ y) ++ z = x ++ (y ++ z) --- > --- > x ++ "" = x --- > --- > "" ++ x = x - --- $list --- --- Dhall @List@ literals are a sequence of values inside of brackets separated by --- commas: --- --- > Γ ⊢ t : Type Γ ⊢ x : t Γ ⊢ y : t ... --- > ────────────────────────────────────────── --- > Γ ⊢ [x, y, ... ] : List t --- --- Also, every empty @List@ must end with a mandatory type annotation, for example: --- --- > [] : List Natural --- --- The built-in operations on @List@s are: - --- $listAppend --- --- Example: --- --- > $ dhall --- > [1, 2, 3] # [4, 5, 6] --- > --- > List Natural --- > --- > [1, 2, 3, 4, 5, 6] --- --- Type: --- --- > Γ ⊢ x : List a Γ ⊢ y : List a --- > ───────────────────────────────── --- > Γ ⊢ x # y : List a --- --- Rules: --- --- > ([] : List a) # xs = xs --- > --- > xs # ([] : List a) = xs --- > --- > (xs # ys) # zs = xs # (ys # zs) - --- $listFold --- --- Example: --- --- > $ dhall --- > List/fold Bool [True, False, True] Bool (λ(x : Bool) → λ(y : Bool) → x && y) True --- > --- > Bool --- > --- > False --- --- Type: --- --- > ──────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ List/fold : ∀(a : Type) → List a → ∀(list : Type) → ∀(cons : a → list → list) → ∀(nil : list) → list --- --- Rules: --- --- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat --- > --- > List/fold a (Prelude/List/concat a xss) b c --- > = List/fold (List a) xss b (λ(x : List a) → List/fold a x b c) --- > --- > List/fold a ([] : List a) b c n = n --- > --- > List/fold a ([x] : List a) b c = c x - --- $listBuild --- --- Example: --- --- > $ dhall --- > List/build Natural (λ(list : Type) → λ(cons : Natural → list → list) → λ(nil : list) → cons 1 (cons 2 (cons 3 nil))) --- > --- > List Natural --- > --- > [1, 2, 3] : List Natural --- --- Type: --- --- > ─────────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ List/build : ∀(a : Type) → (∀(list : Type) → ∀(cons : a → list → list) → ∀(nil : list) → list) → List a --- --- Rules: --- --- > List/build t (List/fold t x) = x --- > --- > List/fold t (List/build t x) = x - --- $listLength --- --- Example: --- --- > $ dhall --- > List/length Natural [1, 2, 3] --- > --- > Natural --- > --- > 3 --- --- Type: --- --- > ──────────────────────────────────────────────── --- > Γ ⊢ List/length : ∀(a : Type) → List a → Natural --- --- Rules: --- --- > List/length t xs = List/fold t xs Natural (λ(_ : t) → λ(n : Natural) → n + 1) 0 - --- $listHead --- --- Example: --- --- > $ dhall --- > List/head Natural [1, 2, 3] --- > --- > Optional Natural --- > --- > Some 1 --- --- Type: --- --- > ─────────────────────────────────────────────── --- > Γ ⊢ List/head ∀(a : Type) → List a → Optional a --- --- Rules: --- --- > let Prelude/Optional/head = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Optional/head --- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat --- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap --- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map --- > --- > List/head a (Prelude/List/concat a xss) = --- > Prelude/Optional/head a (Prelude/List/map (List a) (Optional a) (List/head a) xss) --- > --- > List/head a ([x] : List a) = Some x --- > --- > List/head b (Prelude/List/concatMap a b f m) --- > = Prelude/Optional/concatMap a b (λ(x : a) → List/head b (f x)) (List/head a m) - --- $listLast --- --- Example: --- --- > $ dhall --- > List/last Natural [1, 2, 3] --- > --- > Optional Natural --- > --- > Some 1 --- --- Type: --- --- > ───────────────────────────────────────────────── --- > Γ ⊢ List/last : ∀(a : Type) → List a → Optional a --- --- Rules: --- --- > let Prelude/Optional/last = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Optional/last --- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat --- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap --- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map --- > --- > List/last a (Prelude/List/concat a xss) = --- > Prelude/Optional/last a (Prelude/List/map (List a) (Optional a) (List/last a) xss) --- > --- > List/last a ([x] : List a) = Some x --- > --- > List/last b (Prelude/List/concatMap a b f m) --- > = Prelude/Optional/concatMap a b (λ(x : a) → List/last b (f x)) (List/last a m) - --- $listIndexed --- --- Example --- --- > $ dhall --- > List/indexed Text ["ABC", "DEF", "GHI"] --- > --- > List { index : Natural, value : Text } --- > --- > [{ index = 0, value = "ABC" }, { index = 1, value = "DEF" }, { index = 2, value = "GHI" }] : List { index : Natural, value : Text } --- --- Type: --- --- > ───────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ List/indexed : ∀(a : Type) → List a → List { index : Natural, value : a } --- --- Rules: --- --- > let Prelude/List/shifted = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/shifted --- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat --- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map --- > --- > List/indexed a (Prelude/List/concat a xss) = --- > Prelude/List/shifted a (Prelude/List/map (List a) (List { index : Natural, value : a }) (List/indexed a) xss) - --- $listReverse --- --- Example: --- --- > $ dhall --- > List/reverse Natural [1, 2, 3] --- > --- > List Natural --- > --- > [3, 2, 1] : List Natural --- --- Type: --- --- > ───────────────────────────────────────────────── --- > Γ ⊢ List/reverse : ∀(a : Type) → List a → List a --- --- Rules: --- --- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map --- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat --- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap --- > --- > List/reverse a (Prelude/List/concat a xss) --- > = Prelude/List/concat a (List/reverse (List a) (Prelude/List/map (List a) (List a) (List/reverse a) xss)) --- > --- > List/reverse a ([x] : List a) = [x] : List a --- > --- > List/reverse b (Prelude/List/concatMap a b f xs) --- > = Prelude/List/concatMap a b (λ(x : a) → List/reverse b (f x)) (List/reverse a xs) --- > --- > List/reverse a ([x, y] : List a) = [y, x] : List a - --- $optional1 --- --- Dhall @Optional@ literals are either @Some@ followed by a value: --- --- > Γ ⊢ x : t Γ ⊢ t : Type --- > ──────────────────────── --- > Γ ⊢ Some x : Optional t --- --- ... or @None@ followed by a type: --- --- > ─────────────────────────────────── --- > Γ ⊢ None : ∀(t : Type) → Optional t --- --- Note that `None` is a valid standalone function --- --- The built-in operations on @Optional@ values are: - --- $optionalFold --- --- Example: --- --- > $ dhall --- > Optional/fold Text (Some "ABC") Text (λ(t : Text) → t) "" --- > --- > Text --- > --- > "ABC" --- --- Type: --- --- > ────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ Optional/fold : ∀(a : Type) → Optional a → ∀(optional : Type) → ∀(some : a → optional) → ∀(none : optional) → optional --- --- Rules: --- --- > Optional/fold a (None a) o j n = n --- > --- > Optional/fold a (Some x) o j n = j x - --- $prelude --- --- There is also a Prelude available at: --- --- --- --- ... which currenty redirects to: --- --- --- --- There is nothing \"official\" or \"standard\" about this Prelude other than --- the fact that it is mentioned in this tutorial. The \"Prelude\" is just a --- set of convenient utilities which didn't quite make the cut to be built into --- the language. Feel free to host your own custom Prelude if you want! --- --- If you visit the above link you can browse the Prelude, which has a few --- subdirectories. For example, the @Bool@ subdirectory has a @not@ file --- located here: --- --- --- --- The @not@ function is just a UTF8-encoded text file hosted online with the --- following contents --- --- > $ curl https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not --- > {- --- > Flip the value of a `Bool` --- > --- > Examples: --- > --- > ``` --- > ./not True = False --- > --- > ./not False = True --- > ``` --- > -} --- > let not : Bool → Bool --- > = λ(b : Bool) → b == False --- > --- > in not --- --- The file could have been much shorter, like this: --- --- > λ(b : Bool) → b == False --- --- ... but all the functions exported from the Prelude try to be as --- self-documenting as possible by including: --- --- * the name of the function --- * the type of the function --- * documentation (including a few examples) --- --- The performance penalty for adding these helpful features is negligible. --- --- You can use this @not@ function either directly: --- --- > $ dhall --- > https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not True --- > --- > Bool --- > --- > False --- --- ... or assign the URL to a shorter name: --- --- > $ dhall --- > let Bool/not = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not --- > in Bool/not True --- > --- > Bool --- > --- > False --- --- Some functions in the Prelude just re-export built-in functions for --- consistency and documentation, such as @Prelude\/Natural\/even@, which --- re-exports the built-in @Natural/even@ function: --- --- > $ curl https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Natural/even --- > {- --- > Returns `True` if a number if even and returns `False` otherwise --- > --- > Examples: --- > --- > ``` --- > ./even 3 = False --- > --- > ./even 0 = True --- > ``` --- > -} --- > let even : Natural → Bool --- > = Natural/even --- > --- > in even --- --- You can also clone the Prelude locally to your filesystem if you prefer --- using `git clone`, like this: --- --- > $ git clone https://github.com/dhall-lang/Prelude.git --- > $ tree Prelude --- > Prelude --- > ├── Bool --- > │   ├── and --- > │   ├── build --- > │   ├── even --- > │   ├── fold --- > │   ├── not --- > │   ├── odd --- > │   ├── or --- > │   ├── package.dhall --- > │   └── show --- > ├── Double --- > │   ├── package.dhall --- > │   └── show --- > ├── Integer --- > │   ├── package.dhall --- > │   └── show --- > ├── List --- > │   ├── all --- > │   ├── any --- > │   ├── build --- > │   ├── concat --- > │   ├── concatMap --- > │   ├── filter --- > │   ├── fold --- > │   ├── generate --- > │   ├── head --- > │   ├── indexed --- > │   ├── iterate --- > │   ├── last --- > │   ├── length --- > │   ├── map --- > │   ├── null --- > │   ├── package.dhall --- > │   ├── replicate --- > │   ├── reverse --- > │   ├── shifted --- > │   └── unzip --- > ├── Monoid --- > ├── Natural --- > │   ├── build --- > │   ├── enumerate --- > │   ├── even --- > │   ├── fold --- > │   ├── isZero --- > │   ├── odd --- > │   ├── package.dhall --- > │   ├── product --- > │   ├── show --- > │   ├── sum --- > │   └── toInteger --- > ├── Optional --- > │   ├── None --- > │   ├── Some --- > │   ├── all --- > │   ├── any --- > │   ├── build --- > │   ├── concat --- > │   ├── filter --- > │   ├── fold --- > │   ├── head --- > │   ├── last --- > │   ├── length --- > │   ├── map --- > │   ├── null --- > │   ├── package.dhall --- > │   ├── toList --- > │   └── unzip --- > ├── Record --- > │   ├── keyText --- > │   ├── keyValue --- > │   └── package.dhall --- > ├── Text --- > │   ├── concat --- > │   ├── concatMap --- > │   ├── concatMapSep --- > │   ├── concatSep --- > │   └── package.dhall --- > └── package.dhall --- > --- > 8 directories, 70 files --- --- Browse the Prelude online to learn more by seeing what functions are --- available and reading their inline documentation: --- --- --- --- __Exercise__: Try to use a new Prelude function that has not been covered --- previously in this tutorial --- --- You can also import the entire Prelude as a single large record for --- convenience: --- --- > $ dhall --- > let Prelude = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/package.dhall --- > --- > in λ(x : Text) --- > → Prelude.`List`.length Text (Prelude.`List`.replicate 10 Text x) --- > --- > ∀(x : Text) → Natural --- > --- > λ(x : Text) → 10 --- --- The organization of the package mirrors the layout of the Prelude, meaning --- that every directory is stored as a record whose children are the fields of --- that record. --- --- __Exercise__: Browse the Prelude by running: --- --- > $ dhall <<< 'https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/package.dhall' - --- $conclusion --- --- By this point you should be able to use the Dhall configuration language to --- author, import, and program configuration files. If you run into any issues --- you can report them at: --- --- --- --- You can also request features, support, or documentation improvements on the --- above issue tracker. --- --- If you would like to contribute to the Dhall project you can try to port Dhall --- to other languages besides Haskell so that Dhall configuration files can be --- read into those languages, too. - --- $faq --- --- * Why do empty lists require a type annotation? --- --- Unlike Haskell, Dhall cannot infer a polymorphic type for the empty list --- because Dhall represents polymorphic values as functions of types, like this: --- --- > λ(a : Type) → [] : List a --- --- If the compiler treated an empty list literal as syntactic short-hand for --- the above polymorphic function then you'd get the unexpected behavior where --- a list literal is a function if the list has 0 elements but not a function --- otherwise. --- --- * Does Dhall support user-defined recursive types? --- --- No, but you can translate recursive code to non-recursive code by following --- this guide: --- --- + module contains a tutorial explaining how to author configuration files + using this language +-} +module Dhall.Tutorial ( + -- * Introduction + -- $introduction + + -- * Types + -- $types + + -- * Imports + -- $imports + + -- * Lists + -- $lists + + -- * Optional values + -- $optional0 + + -- * Records + -- $records + + -- * Functions + -- $functions + + -- * Compiler + -- $compiler + + -- * Strings + -- $strings + + -- * Combine + -- $combine + + -- * Let expressions + -- $let + + -- * Defaults + -- $defaults + + -- * Unions + -- $unions + + -- * Polymorphic functions + -- $polymorphic + + -- * Total + -- $total + + -- * Assertions + -- $assertions + + -- * Headers + -- $headers + + -- * Import integrity + -- $integrity + + -- * Raw text + -- $rawText + + -- * Formatting code + -- $format + + -- * Built-in functions + -- $builtins + + -- ** Caveats + -- $caveats + + -- ** Extending the language + -- $extending + + -- * Prelude + -- $prelude + + -- * Conclusion + -- $conclusion + + -- * Frequently Asked Questions (FAQ) + -- $faq + ) where + +import Data.Vector (Vector) +import Dhall + +-- $setup +-- +-- >>> :set -XOverloadedStrings + +-- $introduction +-- +-- The simplest way to use Dhall is to ignore the programming language features +-- and use it as a strongly typed configuration format. For example, suppose +-- that you create the following configuration file: +-- +-- > -- ./config.dhall +-- > { foo = 1 +-- > , bar = [3.0, 4.0, 5.0] +-- > } +-- +-- You can read the above configuration file into Haskell using the following +-- code: +-- +-- > -- example.hs +-- > +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Dhall +-- > +-- > data Example = Example { foo :: Natural, bar :: Vector Double } +-- > deriving (Generic, Show) +-- > +-- > instance FromDhall Example +-- > +-- > main :: IO () +-- > main = do +-- > x <- input auto "./config.dhall" +-- > print (x :: Example) +-- +-- If you compile and run the above example, the program prints the corresponding +-- Haskell record: +-- +-- > $ ./example +-- > Example {foo = 1, bar = [3.0,4.0,5.0]} +-- +-- You can also load some types directly into Haskell without having to define a +-- record, like this: +-- +-- >>> import Dhall +-- >>> :set -XOverloadedStrings +-- >>> input auto "True" :: IO Bool +-- True +-- +-- The `input` function can decode any value if we specify the value's expected +-- `Type`: +-- +-- > input +-- > :: Type a -- Expected type +-- > -> Text -- Dhall program +-- > -> IO a -- Decoded expression +-- +-- ... and we can either specify an explicit type like `bool`: +-- +-- > bool :: Type Bool +-- > +-- > input bool :: Text -> IO Bool +-- > +-- > input bool "True" :: IO Bool +-- +-- >>> input bool "True" +-- True +-- +-- ... or we can use `auto` to let the compiler infer what type to decode from +-- the expected return type: +-- +-- > auto :: FromDhall a => Type a +-- > +-- > input auto :: FromDhall a => Text -> IO a +-- +-- >>> input auto "True" :: IO Bool +-- True +-- +-- You can see what types `auto` supports \"out-of-the-box\" by browsing the +-- instances for the `FromDhall` class. For example, the following instance +-- says that we can directly decode any Dhall expression that evaluates to a +-- @Bool@ into a Haskell `Bool`: +-- +-- > instance FromDhall Bool +-- +-- ... which is why we could directly decode the string @\"True\"@ into the +-- value `True`. +-- +-- There is also another instance that says that if we can decode a value of +-- type @a@, then we can also decode a @List@ of values as a `Vector` of @a@s: +-- +-- > instance FromDhall a => FromDhall (Vector a) +-- +-- Therefore, since we can decode a @Bool@, we must also be able to decode a +-- @List@ of @Bool@s, like this: +-- +-- >>> input auto "[True, False]" :: IO (Vector Bool) +-- [True,False] +-- +-- We could also specify what type to decode by providing an explicit `Type` +-- instead of using `auto` with a type annotation: +-- +-- >>> input (vector bool) "[True, False]" +-- [True,False] +-- +-- __Exercise:__ Create a @./config.dhall@ file that the following program can +-- decode: +-- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Dhall +-- > +-- > data Person = Person { age :: Natural, name :: Text } +-- > deriving (Generic, FromDhall, Show) +-- > +-- > main :: IO () +-- > main = do +-- > x <- input auto "./config.dhall" +-- > print (x :: Person) +-- +-- __Exercise:__ Create a @./config.dhall@ file that the following program can +-- decode: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.Functor.Identity +-- > import Dhall +-- > +-- > instance FromDhall a => FromDhall (Identity a) +-- > +-- > main :: IO () +-- > main = do +-- > x <- input auto "./config.dhall" +-- > print (x :: Identity Double) + +-- $types +-- +-- Suppose that we try to decode a value of the wrong type, like this: +-- +-- >>> input auto "1" :: IO Bool +-- *** Exception: +-- ...Error...: Expression doesn't match annotation +-- ... +-- - Bool +-- + Natural +-- ... +-- 1│ 1 : Bool +-- ... +-- (input):1:1 +-- ... +-- +-- The interpreter complains because the string @\"1\"@ cannot be decoded into a +-- Haskell value of type `Bool`. This part of the type error: +-- +-- > - Bool +-- > + Natural +-- +-- ... means that the expected type was @Bool@ but the inferred type of the +-- expression @1@ was @Natural@. +-- +-- The code excerpt from the above error message has two components: +-- +-- * the expression being type checked (i.e. @1@) +-- * the expression's expected type (i.e. @Bool@) +-- +-- > Expression +-- > ⇩ +-- > 1 : Bool +-- > ⇧ +-- > Expected type +-- +-- The @(:)@ symbol is how Dhall annotates values with their expected types. +-- This notation is equivalent to type annotations in Haskell using the @(::)@ +-- symbol. Whenever you see: +-- +-- > x : t +-- +-- ... you should read that as \"we expect the expression @x@ to have type +-- @t@\". However, we might be wrong and if our expected type does not match the +-- expression's actual type then the type checker will complain. +-- +-- In this case, the expression @1@ does not have type @Bool@ so type checking +-- fails with an exception. +-- +-- __Exercise:__ Load the Dhall library into @ghci@ and run these commands to get +-- get a more detailed error message: +-- +-- > >>> import Dhall +-- > >>> :set -XOverloadedStrings +-- > >>> detailed (input auto "1") :: IO Bool +-- > ... +-- +-- ... then read the entire error message +-- +-- __Exercise:__ Fix the type error, either by changing the value to decode or +-- changing the expected type + +-- $imports +-- +-- You might wonder why in some cases we can decode a configuration file: +-- +-- >>> writeFile "bool" "True" +-- >>> input auto "./bool" :: IO Bool +-- True +-- +-- ... and in other cases we can decode a value directly: +-- +-- >>> input auto "True" :: IO Bool +-- True +-- +-- This is because importing a configuration from a file is a special case of a +-- more general language feature: Dhall expressions can reference other +-- expressions by their file path. +-- +-- To illustrate this, let's create three files: +-- +-- > $ echo "True" > bool1 +-- > $ echo "False" > bool2 +-- > $ echo "./bool1 && ./bool2" > both +-- +-- ... and read in all three files in a single expression: +-- +-- >>> input auto "[ ./bool1 , ./bool2 , ./both ]" :: IO (Vector Bool) +-- [True,False,False] +-- +-- Each file path is replaced with the Dhall expression contained within that +-- file. If that file contains references to other files then those references +-- are transitively resolved. +-- +-- In other words: configuration files can reference other configuration files, +-- either by their relative or absolute paths. This means that we can split a +-- configuration file into multiple files, like this: +-- +-- > -- ./config.dhall +-- > { foo = 1 +-- > , bar = ./bar.dhall +-- > } +-- +-- > -- ./bar.dhall +-- > [3.0, 4.0, 5.0] +-- +-- ... which is equivalent to our original configuration: +-- +-- > -- ./config.dhall +-- > { foo = 1 +-- > , bar = [3.0, 4.0, 5.0] +-- > } +-- +-- However, the Dhall language will forbid cycles in these file references. For +-- example, if we create the following cycle: +-- +-- > $ echo './file1' > file2 +-- > $ echo './file2' > file1 +-- +-- ... then the interpreter will reject the import: +-- +-- >>> input auto "./file1" :: IO Natural +-- *** Exception: +-- ↳ ./file1 +-- ↳ ./file2 +-- ... +-- Cyclic import: ./file1 +-- ... +-- +-- You can also import expressions by URL. For example, you can find a Dhall +-- expression hosted at this GitHub URL: +-- +-- +-- +-- > $ curl https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True +-- > True +-- +-- ... and you can reference that expression either directly: +-- +-- >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- True +-- +-- ... or inside of a larger expression: +-- +-- >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- False +-- +-- You're not limited to hosting Dhall expressions on GitHub. You can host a +-- Dhall expression anywhere that you can host UTF8-encoded text on the web, +-- such as a pastebin, or your own web server. +-- +-- You can also import Dhall expressions from environment variables, too: +-- +-- >>> System.Environment.setEnv "FOO" "1" +-- >>> input auto "env:FOO" :: IO Natural +-- 1 +-- +-- You can import types, too. For example, we can change our @./bar@ file to: +-- +-- > -- ./bar.dhall +-- > [3.0, 4.0, 5.0] : List ./type.dhall +-- +-- ... then specify the type in a separate file: +-- +-- > -- ./type.dhall +-- > Double +-- +-- ... and everything still type checks: +-- +-- > $ ./example +-- > Example {foo = 1, bar = [3.0,4.0,5.0]} +-- +-- Note that imports should be terminated by whitespace or parentheses otherwise +-- you will get either an import error or a parse error, like this: +-- +-- >>> writeFile "baz" "2.0" +-- >>> input auto "./baz: Double" :: IO Double +-- *** Exception: +-- ↳ ./baz: +-- ... +-- ...Error...: Missing file ...baz: +-- ... +-- +-- This is because the parser thinks that @./baz:@ is a single token due to +-- the missing whitespace before the colon and tries to import a file named +-- @./baz:@, which does not exist. To fix the problem we have to add a space +-- after @./baz@: +-- +-- >>> input auto "./baz : Double" :: IO Double +-- 2.0 +-- +-- __Exercise:__ There is a @not@ function hosted online here: +-- +-- +-- +-- Visit that link and read the documentation. Then try to guess what this +-- code returns: +-- +-- > >>> input auto "https://prelude.dhall-lang.org/Bool/not https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- > ??? +-- +-- Run the code to test your guess + +-- $lists +-- +-- You can store 0 or more values of the same type in a list, like this: +-- +-- > [1, 2, 3] +-- +-- Every list can be followed by the type of the list. The type annotation is +-- required for empty lists but optional for non-empty lists. You will get a +-- type error if you provide an empty list without a type annotation: +-- +-- >>> input auto "[]" :: IO (Vector Natural) +-- *** Exception: +-- ...Error...: An empty list requires a type annotation +-- ... +-- 1│ [] +-- ... +-- (input):1:1 +-- +-- Also, list elements must all have the same type. You will get an error if +-- you try to store elements of different types in a list: +-- +-- >>> input auto "[1, True, 3]" :: IO (Vector Natural) +-- *** Exception: +-- ...Error...: List elements should all have the same type +-- ... +-- - Natural +-- + Bool +-- ... +-- 1│ True +-- ... +-- (input):1:5 +-- ... +-- +-- __Exercise:__ Replace the @\"???\"@ with an expression that successfully +-- decodes to the specified type: +-- +-- > >>> input auto "???" :: IO (Vector (Vector Natural)) + +-- $optional0 +-- +-- @Optional@ values are either of the form @Some value@ or @None type@. +-- +-- For example, these are valid @Optional@ values: +-- +-- > Some 1 +-- > +-- > None Natural +-- +-- ... which both have type @Optional Natural@ +-- +-- An @Optional@ corresponds to Haskell's `Maybe` type for decoding purposes: +-- +-- >>> input auto "Some 1" :: IO (Maybe Natural) +-- Just 1 +-- >>> input auto "None Natural" :: IO (Maybe Natural) +-- Nothing +-- +-- __Exercise:__ Replace the @\"???\"@ with an expression that successfully +-- decodes to the specified type: +-- +-- > >>> input auto "???" :: IO (Maybe (Maybe (Maybe Natural))) + +-- $records +-- +-- Record literals are delimited by curly braces and their fields are separated +-- by commas. For example, this is a valid record literal: +-- +-- > { foo = True +-- > , bar = 2 +-- > , baz = 4.2 +-- > } +-- +-- A record type is like a record literal except instead of specifying each +-- field's value we specify each field's type. For example, the preceding +-- record literal has the following record type: +-- +-- > { foo : Bool +-- > , bar : Natural +-- > , baz : Double +-- > } +-- +-- If you want to specify an empty record literal, you must use @{=}@, which is +-- special syntax reserved for empty records. If you want to specify the empty +-- record type, then you use @{}@. If you forget which is which you can always +-- ask the @dhall@ compiler to remind you of the type for each one: +-- +-- > $ dhall type <<< '{=}' +-- > {} +-- +-- > $ dhall type <<< '{}' +-- > Type +-- +-- This is our first use of the @dhall@ command-line tool (provided by this +-- package), which provides a @type@ subcommand for inferring an expression's +-- type. By default the tool reads the expression on standard input and outputs +-- the type to standard output. +-- +-- Note that @<<<@ is a feature specific to the Bash shell to feed a string to +-- a command's standard input. If you are using another shell, then you can +-- instead do this: +-- +-- > $ echo '{=}' | dhall type +-- > {} +-- +-- __Exercise__: Use the @dhall type@ command to infer the type of this record: +-- +-- > -- ./nested.dhall +-- > { foo = 1 +-- > , bar = +-- > { baz = 2.0 +-- > , qux = True +-- > } +-- > } +-- +-- You can access a field of a record using the following syntax: +-- +-- > record.fieldName +-- +-- ... which means to access the value of the field named @fieldName@ from the +-- @record@. For example: +-- +-- >>> input auto "{ foo = True, bar = 2, baz = 4.2 }.baz" :: IO Double +-- 4.2 +-- +-- ... and you can project out multiple fields into a new record using this +-- syntax: +-- +-- > someRecord.{ field₀, field₁, … } +-- +-- For example: +-- +-- > $ dhall <<< '{ x = 1, y = True, z = "ABC" }.{ x, y }' +-- > { x = 1, y = True } +-- +-- This is our first example of using the @dhall@ command-line tool with no +-- subcommand (like @type@), which evaluates the provided expression. By +-- default, this reads the expression on standard input and outputs the +-- evaluated result on standard output. +-- +-- __Exercise__: Save the above @./nested.dhall@ file and then try to access the +-- value of the @baz@ field. Test that this works by interpreting your code +-- using the @dhall@ command. +-- +-- You can convert a record to a list of key-value pairs (a.k.a. a \"Map\") by +-- using the `toMap` keyword. For example: +-- +-- > $ dhall <<< 'toMap { foo = 1, bar = 2 }' +-- > [ { mapKey = "bar", mapValue = 2 }, { mapKey = "foo", mapValue = 1 } ] +-- +-- This conversion only works if all field of the record have the same type. +-- This comes in handy when you need to convert a Dhall record to the Dhall +-- equivalent of a homogeneous map (i.e. Haskell's @"Data.Map"@). + +-- $functions +-- +-- The Dhall programming language also supports user-defined anonymous +-- functions. For example, we can save the following anonymous function to a +-- file: +-- +-- > -- ./makeBools.dhall +-- > \(n : Bool) -> +-- > [ n && True, n && False, n || True, n || False ] +-- +-- ... or we can use Dhall's support for Unicode characters to use @λ@ (U+03BB) +-- instead of @\\@ and @→@ (U+2192) instead of @->@ (for people who are into that +-- sort of thing): +-- +-- > $ -- ./makeBools.dhall +-- > λ(n : Bool) → +-- > [ n && True, n && False, n || True, n || False ] +-- > +-- +-- You can read this as a function of one argument named @n@ that has type +-- @Bool@. This function returns a @List@ of @Bool@s. Each element of the +-- @List@ depends on the input argument named @n@. +-- +-- The (ASCII) syntax for anonymous functions resembles the syntax for anonymous +-- functions in Haskell. The only difference is that Dhall requires you to +-- annotate the type of the function's input. +-- +-- You can import this function into Haskell, too: +-- +-- >>> makeBools <- input auto "./makeBools.dhall" :: IO (Bool -> Vector Bool) +-- >>> makeBools True +-- [True,False,True,True] +-- +-- The reason this works is that there is an `FromDhall` instance for simple +-- functions: +-- +-- > instance (ToDhall a, FromDhall b) => FromDhall (a -> b) +-- +-- Thanks to currying, this instance works for functions of multiple simple +-- arguments: +-- +-- >>> dhallAnd <- input auto "λ(x : Bool) → λ(y : Bool) → x && y" :: IO (Bool -> Bool -> Bool) +-- >>> dhallAnd True False +-- False +-- +-- However, you can't convert anything more complex than that (like a polymorphic +-- or higher-order function). You will need to apply those functions to their +-- arguments within Dhall before converting their result to a Haskell value. +-- +-- Just like `FromDhall`, you can derive `ToDhall` for user-defined data types: +-- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main where +-- > +-- > import Dhall +-- > +-- > data Example0 = Example0 { foo :: Bool, bar :: Bool } +-- > deriving (Generic, ToDhall) +-- > +-- > main = do +-- > f <- input auto "λ(r : { foo : Bool, bar : Bool }) → r.foo && r.bar" +-- > print (f (Example0 { foo = True, bar = False }) :: Bool) +-- > print (f (Example0 { foo = True, bar = True }) :: Bool) +-- +-- The above program prints: +-- +-- > False +-- > True + +-- $compiler +-- +-- We can also test our @makeBools@ function directly from the command line. +-- This library comes with a command-line executable program named @dhall@ that +-- you can use to both type-check files and convert them to a normal form. Our +-- compiler takes a program on standard input and then prints the program's type +-- to standard error followed by the program's normal form to standard output: +-- +-- > $ dhall --annotate <<< './makeBools.dhall' +-- > (λ(n : Bool) → [ n, False, True, n ]) : ∀(n : Bool) → List Bool +-- +-- The @--annotate@ flag adds a type signature to the output to let us know +-- what type the interpreter inferred for our expression. The type signature +-- is @∀(n : Bool) → List Bool@ which says that @makeBools@ is a function of one +-- argument named @n@ that has type @Bool@ and the function returns a @List@ of +-- @Bool@s. The @∀@ (U+2200) symbol is shorthand for the ASCII @forall@ +-- keyword: +-- +-- > ∀(x : a) → b -- This type ... +-- > +-- > forall (x : a) → b -- ... is the same as this type +-- +-- ... and Dhall's @forall@ keyword behaves the same way as Haskell's @forall@ +-- keyword for input values that are @Type@s: +-- +-- > forall (x : Type) → b -- This Dhall type ... +-- +-- > forall x . b -- ... is the same as this Haskell type +-- +-- The part where Dhall differs from Haskell is that you can also use +-- @∀@/@forall@ to give names to non-@Type@ arguments (such as the first +-- argument to @makeBools@). +-- +-- This expression is our program's normal form: +-- +-- > λ(n : Bool) → [ n, False, True, n ] +-- +-- ... and the interpreter was able to simplify our expression by noting that: +-- +-- * @n && True = n@ +-- * @n && False = False@ +-- * @n || True = True@ +-- * @n || False = n@ +-- +-- To apply a function to an argument you separate the function and argument by +-- whitespace (just like Haskell): +-- +-- @f x@ +-- +-- You can read the above as \"apply the function @f@ to the argument @x@\". This +-- means that we can \"apply\" our @./makeBools@ function to a @Bool@ argument +-- like this: +-- +-- > $ dhall <<< './makeBools.dhall True' +-- > [True, False, True, True] +-- +-- Remember that file paths are synonymous with their contents, so the above +-- code is exactly equivalent to: +-- +-- > $ dhall <<< '(λ(n : Bool) → [n && True, n && False, n || True, n || False]) True' +-- > [True, False, True, True] +-- +-- When you apply an anonymous function to an argument, you substitute the +-- \"bound variable" with the function's argument: +-- +-- > Bound variable +-- > ⇩ +-- > (λ(n : Bool) → ...) True +-- > ⇧ +-- > Function argument +-- +-- So in our above example, we would replace all occurrences of @n@ with @True@, +-- like this: +-- +-- > -- If we replace all of these `n`s with `True` ... +-- > [n && True, n && False, n || True, n || False] +-- > +-- > -- ... then we get this: +-- > [True && True, True && False, True || True, True || False] +-- > +-- > -- ... which reduces to the following normal form: +-- > [True, False, True, True] +-- +-- Now that we've verified that our function type checks and works, we can use +-- the same function within Haskell: +-- +-- >>> input auto "./makeBools.dhall True" :: IO (Vector Bool) +-- [True,False,True,True] +-- +-- __Exercise__: Create a file named @getFoo@ that is a function of the following +-- type: +-- +-- > ∀(r : { foo : Bool, bar : Text }) → Bool +-- +-- This function should take a single input argument named @r@ that is a record +-- with two fields. The function should return the value of the @foo@ field. +-- +-- __Exercise__: Use the @dhall@ command to infer the type of the function you +-- just created and verify that your function has the correct type +-- +-- __Exercise__: Use the @dhall@ command to apply your function to a sample +-- record + +-- $strings +-- Dhall supports ordinary string literals with Haskell-style escaping rules: +-- +-- > $ dhall +-- > "Hello, \"world\"!" +-- > +-- > "Hello, \"world\"!" +-- +-- ... and Dhall also supports Nix-style multi-line string literals: +-- +-- > $ dhall +-- > '' +-- > #!/bin/bash +-- > +-- > echo "Hi!" +-- > '' +-- > +-- > "\n#!/bin/bash\n\necho \"Hi!\"\n" +-- +-- These \"double single quote strings\" ignore all special characters, with one +-- exception: if you want to include a @''@ in the string, you will need to +-- escape it with a preceding @'@ (i.e. use @'''@ to insert @''@ into the final +-- string). +-- +-- These strings also strip leading whitespace using the same rules as Nix. +-- Specifically: \"it strips from each line a number of spaces equal to the +-- minimal indentation of the string as a whole (disregarding the indentation +-- of empty lines).\" +-- +-- You can also interpolate expressions into strings using @${...}@ syntax. For +-- example: +-- +-- > $ dhall +-- > let name = "John Doe" +-- > let age = 21 +-- > in "My name is ${name} and my age is ${Natural/show age}" +-- > +-- > "My name is John Doe and my age is 21" +-- +-- Note that you can only interpolate expressions of type @Text@ +-- +-- If you need to insert a @"${"@ into a string without interpolation then use +-- @"''${"@ (same as Nix) +-- +-- > '' +-- > for file in *; do +-- > echo "Found ''${file}" +-- > done +-- > '' + +-- $combine +-- +-- You can combine two records, using either the @(//)@ operator or the +-- @(/\\)@ operator. +-- +-- The @(//)@ operator (or @(⫽)@ U+2AFD) combines the fields of both records, +-- preferring fields from the right record if they share fields in common: +-- +-- > $ dhall +-- > { foo = 1, bar = "ABC" } // { baz = True } +-- > +-- > { bar = "ABC", baz = True, foo = 1 } +-- > $ dhall +-- > { foo = 1, bar = "ABC" } ⫽ { bar = True } -- Fancy unicode +-- > +-- > { bar = True, foo = 1 } +-- +-- Note that the order of record fields does not matter. The compiler +-- automatically sorts the fields. +-- +-- The @(/\\)@ operator (or @(∧)@ U+2227) also lets you combine records, but +-- behaves differently if the records share fields in common. The operator +-- combines shared fields recursively if they are both records: +-- +-- > $ dhall +-- > { foo = { bar = True }, baz = "ABC" } /\ { foo = { qux = 1.0 } } +-- > +-- > { baz = "ABC", foo = { bar = True, qux = 1.0 } } +-- +-- ... but fails with a type error if either shared field is not a record: +-- +-- > $ dhall +-- > { foo = 1, bar = "ABC" } ∧ { foo = True } +-- > +-- > Use "dhall --explain" for detailed errors +-- > +-- > Error: Field collision +-- > +-- > { foo = 1, bar = "ABC" } ∧ { foo = True } +-- > +-- > (stdin):1:1 +-- +-- __Exercise__: Combine any record with the empty record. What do you expect +-- to happen? +-- +-- You can analogously combine record types using the @//\\\\@ operator (or @(⩓)@ U+2A53): +-- +-- > $ dhall +-- > { foo : Natural } ⩓ { bar : Text } +-- > +-- > { foo : Natural, bar : Text } +-- +-- ... which behaves the exact same, except at the type level, meaning that the +-- operator descends recursively into record types: +-- +-- > $ dhall +-- > { foo : { bar : Text } } ⩓ { foo : { baz : Bool }, qux : Natural } +-- > +-- > { foo : { bar : Text, baz : Bool }, qux : Natural } + +-- $let +-- +-- Dhall also supports @let@ expressions, which you can use to define +-- intermediate values in the course of a computation, like this: +-- +-- > $ dhall +-- > let x = "ha" in x ++ x +-- > +-- > "haha" +-- +-- You can also annotate the types of values defined within a @let@ expression, +-- like this: +-- +-- > $ dhall +-- > let x : Text = "ha" in x ++ x +-- > +-- > "haha" +-- +-- You need to nest @let@ expressions if you want to define more than one value +-- in this way: +-- +-- > $ dhall +-- > let x = "Hello, " +-- > let y = "world!" +-- > in x ++ y +-- > +-- > "Hello, world!" +-- +-- Dhall is whitespace-insensitive, so feel free to format things over multiple +-- lines or indent in any way that you please. +-- +-- If you want to define a named function, just give a name to an anonymous +-- function: +-- +-- > $ dhall +-- > let twice = λ(x : Text) → x ++ x in twice "ha" +-- > +-- > "haha" +-- +-- Unlike Haskell, Dhall does not support function arguments on the left-hand +-- side of the equals sign, so this will not work: +-- +-- > $ dhall +-- > let twice (x : Text) = x ++ x in twice "ha" +-- > +-- > Error: Invalid input +-- > +-- > (stdin):1:11: +-- > | +-- > 1 | let twice (x : Text) = x ++ x in twice "ha" +-- > | ^ +-- > unexpected '(' +-- > expecting ':', '=', or the rest of label +-- +-- The error message says that Dhall expected either a @(:)@ (i.e. the beginning +-- of a type annotation) or a @(=)@ (the beginning of the assignment) and not a +-- function argument. +-- +-- You can also use @let@ expressions to rename imports, like this: +-- +-- > $ dhall +-- > let not = https://prelude.dhall-lang.org/Bool/not +-- > in not True +-- > +-- > False +-- +-- ... or to define synonyms for types: +-- +-- > $ dhall <<< 'let Name : Type = Text in [ "John", "Mary" ] : List Name' +-- > List Text +-- > +-- > [ "John", "Mary" ] +-- +-- __Exercise:__ What do you think the following code will normalize to? +-- +-- > let x = 1 +-- > let x = 2 +-- > in x +-- +-- Test your guess using the @dhall@ compiler +-- +-- __Exercise:__ Now try to guess what this code will normalize to: +-- +-- > let x = "ha" +-- > let x = x ++ "ha" +-- > in x +-- +-- __Exercise:__ What about this code? +-- +-- > let x = x ++ "ha" +-- > in x + +-- $defaults +-- +-- For records with a large number of defaultable fields you can use the +-- @::@ operator to auto-complete a record. For example: +-- +-- > let greet = +-- > \(args : { greeting : Text, name : Text }) +-- > -> "${args.greeting}, ${args.name}!" +-- > +-- > let Greeting = +-- > { Type = { greeting : Text, name : Text } +-- > , default = { greeting = "Hello", name = "John" } +-- > } +-- > +-- > in '' +-- > ${greet Greeting::{=}} +-- > ${greet Greeting::{ greeting = "Hola" }} +-- > ${greet Greeting::{ name = "Jane" }} +-- > ${greet Greeting::{ greeting = "Hola", name = "Jane" }} +-- > '' +-- +-- This operator is syntactic sugar. Specifically an expression of the form: +-- +-- > T::r +-- +-- ... is equivalent to: +-- +-- > (T.default // r) : T.Type +-- +-- So, for example: +-- +-- > Greeting::{ greeting = "Hola" } +-- +-- ... is the same thing as: +-- +-- > (Greeting.default // { greeting = "Hola" }) : Greeting.Type +-- +-- ... which is the same thing as: +-- +-- > ({ greeting = "Hello", name = "John" } // { greeting = "Hola" }) : { greeting : Text, name : Text } +-- +-- ... which is the same thing as: +-- +-- > { greeting = "Hola", name = "John" } + +-- $unions +-- +-- A union is a value that can be one of many alternative types of values. For +-- example, the following union type: +-- +-- > < Left : Natural | Right : Bool > +-- +-- ... represents a value that can be either a @Natural@ or a @Bool@ value. If +-- you are familiar with Haskell these are exactly analogous to Haskell's +-- \"sum types\" and the above type is equivalent to @Either Natural Bool@. +-- +-- Each alternative is associated with a tag that distinguishes that alternative +-- from other alternatives. In the above example, the @Left@ tag is used for +-- the @Natural@ alternative and the @Right@ tag is used for the @Bool@ +-- alternative. +-- +-- You can specify the value of a union constructor like this: +-- +-- > let Union = < Left : Natural | Right : Bool> +-- > +-- > in [ Union.Left 0, Union.Right True ] +-- +-- In other words, you can access a union constructor as a field of a union +-- type and use that constructor to wrap a value of a type appropriate for +-- that alternative. In the above example, the @Left@ constructor can wrap +-- a @Natural@ value and the @Right@ constructor can wrap a @Bool@ value. We +-- can also confirm that by inspecting their type: +-- +-- > $ echo '< Left : Natural | Right : Bool>' > ./Union +-- +-- > $ dhall --annotate <<< '(./Union).Left' +-- > < Left : Natural | Right : Bool >.Left +-- > : ∀(Left : Natural) → < Left : Natural | Right : Bool > +-- +-- > $ dhall --annotate <<< '(./Union).Right' +-- > < Left : Natural | Right : Bool >.Right +-- > : ∀(Right : Bool) → < Left : Natural | Right : Bool > +-- +-- In other words, the @Left@ constructor is a function from a @Natural@ to a +-- value of our @Union@ type and the @Right@ constructor is a separate function +-- from a @Bool@ to that same @Union@ type. +-- +-- You can consume a union using the built-in @merge@ function. For example, +-- suppose we want to convert our union to a @Bool@ but we want to behave +-- differently depending on whether or not the union is a @Natural@ wrapped in +-- the @Left@ constructor or a @Bool@ wrapped in the @Right@ constructor . We +-- would write: +-- +-- > $ cat > process < λ(union : < Left : Natural | Right : Bool >) +-- > → let handlers = +-- > { Left = Natural/even -- Natural/even is a built-in function +-- > , Right = λ(b : Bool) → b +-- > } +-- > in merge handlers union +-- > EOF +-- +-- Now our @./process@ function can handle both alternatives: +-- +-- > $ dhall <<< './process ((./Union).Left 3)' +-- > False +-- +-- > $ dhall <<< './process ((./Union).Right True)' +-- > True +-- +-- Every @merge@ has the following form: +-- +-- > merge handlers union [ : type ] +-- +-- ... where: +-- +-- * @union@ is the union you want to consume +-- * @handlers@ is a record with one function per alternative of the union +-- * @type@ is an optional declared result type of the @merge@ +-- +-- The @merge@ function selects which function to apply from the record based on +-- which alternative the union selects: +-- +-- > merge { Foo = f, ... } (< … >.Foo x) = f x +-- +-- So, for example: +-- +-- > merge { Left = Natural/even, Right = λ(b : Bool) → b } (< Left : Natural | Right : Bool >.Left 3) +-- > = Natural/even 3 +-- > = False +-- +-- ... and similarly: +-- +-- > merge { Left = Natural/even, Right = λ(b : Bool) → b } (< Left : Natural | Right : Bool >.Right True) +-- > = (λ(b : Bool) → b) True +-- > = True +-- +-- Notice that each handler has to return the same type of result (@Bool@ in +-- this case). +-- +-- You can also store more than one value within alternatives using Dhall's +-- support for anonymous records. You can nest an anonymous record within a +-- union such as in this type: +-- +-- > < Empty : {} | Person : { name : Text, age : Natural } > +-- +-- You can even go a step further and omit the type of an alternative if it +-- stores no data, like this: +-- +-- > < Empty | Person : { name : Text, age : Natural } > +-- +-- The above Dhall type resembles the following equivalent Haskell data type: +-- +-- > data Example = Empty | Person { name :: Text, age :: Text } +-- +-- Empty alternatives like @Empty@ require no argument: +-- +-- > let Example = < Empty | Person : { name : Text, age : Natural } > +-- > +-- > in [ Example.Empty -- Note the absence of any argument to `Empty` +-- > , Example.Person { name = "John", age = 23 } +-- > , Example.Person { name = "Amy" , age = 25 } +-- > ] +-- +-- ... and when you @merge@ an empty alternative the correspond handler takes no +-- argument: +-- +-- > λ(x : < Empty | Person : { name : Text, age : Natural } >) +-- > → merge +-- > { Empty = "Unknown" -- Note the absence of a `λ` +-- > +-- > , Person = +-- > λ(person : { name : Text, age : Natural }) +-- > → "Name: ${person.name}, Age: ${Natural/show person.age}" +-- > } +-- > x +-- +-- __Exercise__: Create a list of the following type with at least one element +-- per alternative: +-- +-- > List < Left : Natural | Right : Double > + +-- $polymorphic +-- +-- The Dhall language supports defining polymorphic functions (a.k.a. +-- \"generic\" functions) that work on more than one type of value. However, +-- Dhall differs from Haskell by not inferring the types of these polymorphic +-- functions. Instead, you must be explicit about what type of value the +-- function is specialized to. +-- +-- Take, for example, Haskell's identity function named @id@: +-- +-- > id :: a -> a +-- > id = \x -> x +-- +-- The identity function is polymorphic, meaning that `id` works on values of +-- different types: +-- +-- >>> id 4 +-- 4 +-- >>> id True +-- True +-- +-- The equivalent function in Dhall is: +-- +-- > λ(a : Type) → λ(x : a) → x +-- +-- Notice how this function takes two arguments instead of one. The first +-- argument is the type of the second argument. +-- +-- Let's illustrate how this works by actually using the above function: +-- +-- > $ echo "λ(a : Type) → λ(x : a) → x" > id +-- +-- Let's ask the interpreter for the type of this function: +-- the first line: +-- +-- > $ dhall type <<< './id' +-- > ∀(a : Type) → ∀(x : a) → a +-- +-- You can read the type @(∀(a : Type) → ∀(x : a) → a)@ as saying: \"This is the +-- type of a function whose first argument is named @a@ and is a @Type@. The +-- second argument is named @x@ and has type @a@ (i.e. the value of the first +-- argument). The result also has type @a@.\" +-- +-- This means that the type of the second argument changes depending on what +-- type we provide for the first argument. When we apply @./id@ to @Natural@, +-- we create a function that expects an @Natural@ argument: +-- +-- > $ dhall type <<< './id Natural' +-- > ∀(x : Natural) → Natural +-- +-- Similarly, when we apply @./id@ to @Bool@, we create a function that expects a +-- @Bool@ argument: +-- +-- > $ dhall type <<< './id Bool' +-- > ∀(x : Bool) → Bool +-- +-- We can then supply the final argument to each of those functions to show +-- that they both work on their respective types: +-- +-- > $ dhall <<< './id Natural 4' +-- > 4 +-- +-- > $ dhall <<< './id Bool True' +-- > True +-- +-- Built-in functions can also be polymorphic, too. For example, we can ask +-- the compiler for the type of @List/reverse@, the function that reverses a +-- list: +-- +-- > $ dhall --annotate +-- > List/reverse +-- > +-- > List/reverse : ∀(a : Type) → List a → List a +-- +-- The first argument to @List/reverse@ is the type of the list to reverse: +-- +-- > $ dhall +-- > List/reverse Bool +-- > +-- > List/reverse Bool : List Bool → List Bool +-- +-- ... and the second argument is the list to reverse: +-- +-- > $ dhall +-- > List/reverse Bool [True, False] +-- > +-- > [False, True] +-- +-- Note that the second argument has no name. This type: +-- +-- > ∀(a : Type) → List a → List a +-- +-- ... is equivalent to this type: +-- +-- > ∀(a : Type) → ∀(_ : List a) → List a +-- +-- In other words, if you don't see the @∀@ symbol surrounding a function +-- argument type then that means that the name of the argument is @"_"@. This +-- is true even for user-defined functions: +-- +-- > $ dhall type <<< 'λ(_ : Text) → 1' +-- > Text → Natural +-- +-- The type @Text → Natural@ is the same as @∀(_ : Text) → Natural@ +-- +-- __Exercise__ : Translate Haskell's `flip` function to Dhall + +-- $total +-- +-- Dhall is a total programming language, which means that Dhall is not +-- Turing-complete and evaluation of every Dhall program is guaranteed to +-- eventually halt. There is no upper bound on how long the program might take +-- to evaluate, but the program is guaranteed to terminate in a finite amount of +-- time and not hang forever. +-- +-- This guarantees that all Dhall programs can be safely reduced to a normal +-- form where as many functions have been evaluated as possible. In fact, Dhall +-- expressions can be evaluated even if all function arguments haven't been fully +-- applied. For example, the following program is an anonymous function: +-- +-- > $ dhall +-- > \(n : Bool) -> 10 * 10 +-- > +-- > λ(n : Bool) → 100 +-- +-- ... and even though the function is still missing the first argument named +-- @n@ the compiler is smart enough to evaluate the body of the anonymous +-- function ahead of time before the function has even been invoked. +-- +-- We can use the @map@ function from the Prelude to illustrate an even more +-- complex example: +-- +-- > $ dhall +-- > let List/map = https://prelude.dhall-lang.org/List/map +-- > in λ(f : Natural → Natural) → List/map Natural Natural f [1, 2, 3] +-- > +-- > λ(f : Natural → Natural) → [f 1, f 2, f 3] +-- +-- Dhall can apply our function to each element of the list even before we specify +-- which function to apply. +-- +-- The language will also never crash or throw any exceptions. Every +-- computation will succeed and produce something, even if the result might be +-- an @Optional@ value: +-- +-- > $ dhall <<< 'List/head Natural ([] : List Natural)' +-- > None Natural +-- +-- __Exercise__: The Dhall Prelude provides a @replicate@ function which you can +-- find here: +-- +-- +-- +-- Test what the following Dhall expression normalizes to: +-- +-- > let replicate = https://prelude.dhall-lang.org/List/replicate +-- > in replicate 10 +-- +-- __Exercise__: If you have a lot of spare time, try to \"break the compiler\" +-- by finding an input expression that crashes or loops forever (and file a bug +-- report if you succeed). + +-- $assertions +-- +-- You can add compile-time assertions which you can use to add tests to your +-- code. For example, we can add some tests to our @not@ function like this: +-- +-- > let not +-- > : Bool → Bool +-- > = λ(b : Bool) → b == False +-- > +-- > let example0 = assert : not False === True +-- > +-- > let example1 = assert : not True === False +-- > +-- > in not +-- +-- The expression @assert : not False == True@ is a type-checking assertion +-- that two expressions have the same normal form. If the two expressions differ +-- then type-checking rejects the code. +-- +-- For example, suppose that we change the example to add an incorrect assertion: +-- +-- > -- ./test.dhall +-- > +-- > let not +-- > : Bool → Bool +-- > = λ(b : Bool) → b == False +-- > +-- > let example0 = assert : not False === True +-- > +-- > let example1 = assert : not True === True -- Oops! +-- > +-- > in not +-- +-- The type-checker then rejects the assertion with the following error message: +-- +-- > $ dhall <<< './test.dhall' +-- > +-- > ↳ ./test.dhall +-- > +-- > Error: Assertion failed +-- > +-- > - False +-- > + True +-- > +-- > 7│ assert : not True === True -- Oops! +-- > 8│ +-- > +-- > ./test.dhall:7:16 +-- > +-- > 1│ ./test.dhall +-- > +-- > (stdin):1:1 +-- +-- You can compare expressions that contain variables, too, which is equivalent +-- to symbolic reasoning: +-- +-- > $ dhall <<< '\(n : Natural) -> assert : n === (n + 0)' +-- > λ(n : Natural) → assert : n ≡ n +-- +-- Dhall accepts this because the language has built-in support for normalizing +-- @n + 0@ to @n@, so both sides of the comparison normalize to the same value: +-- @n@. +-- +-- Note that this sort of symbolic reasoning is limited and can only detect +-- equality of normal forms. Some equivalent expressions will be rejected +-- if they don't share the same normal form, such as these: +-- +-- > $ dhall <<< '\(n : Natural) -> assert : Natural/even (n + n) === True' +-- > +-- > Use "dhall --explain" for detailed errors +-- > +-- > n : Natural +-- > +-- > Error: Assertion failed +-- > +-- > - … … +-- > + True +-- > +-- > 1│ assert : Natural/even (n + n) === True +-- > +-- > (stdin):1:19 +-- +-- Here the interpreter is not smart enough to simplify @Natural/even (n + n)@ +-- to @True@ so the assertion fails. +-- +-- If you prefer to use Unicode, then the Unicode equivalent of @===@ is @≡@ +-- (U+2261). + +-- $headers +-- +-- Sometimes you would like to provide additional request headers when importing +-- Dhall expressions from URLs. For example, you might want to provide an +-- authorization header or specify the expected content type. +-- +-- Dhall URL imports let you add or modify request headers with the @using@ +-- keyword: +-- +-- > https://example.com/example.dhall using ./headers +-- +-- ... where you can replace @./headers@ with any import that points to a Dhall +-- expression of the following type: +-- +-- > List { header : Text, value : Text } +-- +-- For example, if you needed to specify the content type correctly in order to +-- download the file, then your @./headers@ file might look like this: +-- +-- > $ cat headers +-- > [ { header = "Accept", value = "application/dhall" } ] +-- +-- ... or if you needed to provide an authorization token to access a private +-- GitHub repository, then your headers could look like this: +-- +-- > [ { header = "Authorization", value = "token ${env:GITHUB_TOKEN as Text}" } ] +-- +-- This would read your GitHub API token from the @GITHUB_TOKEN@ environment +-- variable and supply that token in the authorization header. +-- +-- You cannot inline the headers within the same file as the URL. You must +-- provide them as a separate import. That means that this is /not/ legal code: +-- +-- > http://example.com/example.dhall using [ { header = "Accept", value = "application/dhall" } ] -- NOT legal +-- +-- Dhall will forward imports if you import an expression from a URL that +-- contains a relative import. For example, if you import an expression like +-- this: +-- +-- > http://example.com/example.dhall using ./headers +-- +-- ... and @http:\/\/example.com/example.dhall@ contains a relative import of @./foo@ +-- then Dhall will import @http:\/\/example.com/foo@ using the same @./headers@ file. + +-- $integrity +-- +-- Sometimes you want to use share code while still ensuring that the imported +-- value never changes and can't be corrupted by a malicious attacker. Dhall +-- provides built-in support for hashing imported values to verify that their +-- value never changes +-- +-- For example, suppose you save the following two files: +-- +-- > $ cat ./foo +-- > ./bar sha256:d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 +-- +-- > $ cat ./bar +-- > ./baz +-- +-- > $ cat ./baz +-- > 1 +-- +-- The first file named @./foo@ contains an example of an integrity check. You +-- can add @sha256:XXX@ after any import (such as after @./bar@), where @XXX@ is +-- an expected 64-character @sha256@ hash of the Dhall value. To be precise, +-- the hash represents a @sha256@ hash of the UTF-8 encoding of a canonical text +-- representation of the fully resolved and normalized abstract syntax tree of +-- the imported expression. +-- +-- Dhall will verify that the expected hash matches the actual hash of the +-- imported Dhall value and reject the import if there is a hash mismatch: +-- +-- > $ dhall <<< './foo' +-- > Natural +-- > +-- > 1 +-- +-- Any import protected by a semantic integrity check is automatically cached +-- locally underneath either @~\/.cache\/dhall\/1220${HASH}@ or +-- @${XDG_CACHE_HOME}\/dhall/1220${HASH}@ if you define the @XDG_CACHE_HOME@ +-- environment variable. +-- +-- For example, after you import @./foo@ the contents of `./bar` are locally +-- cached in a fully-evaluated and binary-encoded form which you can inspect by +-- running: +-- +-- > $ dhall decode < ~/.cache/dhall/1220d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 +-- > 1 +-- +-- Subsequent attempts to resolve the same import will automatically retrieve +-- the import from the cache. This matters less for local imports, but comes in +-- handy for remote imports to avoid redownloading them. +-- +-- The local cache takes precedence when resolving imports, so changing the +-- original import afterwards will have no affect until you update the hash. +-- From Dhall's point of view, the hash is the true address and the file path +-- is just a suggestion for how to obtain the import if it's not already cached. +-- +-- You can disable the cache by setting `XDG_CACHE_HOME` to `/var/empty` (an +-- empty and unwritable directory), like this: +-- +-- > $ XDG_CACHE_HOME=/var/empty dhall <<< './foo' +-- > Natural +-- > +-- > 1 +-- +-- 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: +-- +-- > $ cat ./bar +-- > -- This comment does not change the hash +-- > ./baz +-- +-- ... then @./foo@ will still successfully import @./bar@ because the hash +-- only depends on the normalized value and does not depend on meaningless +-- changes to whitespace or comments: +-- +-- > $ XDG_CACHE_HOME=/var/empty dhall <<< './foo' # This still succeeds +-- > Natural +-- > +-- > 1 +-- +-- You can compute the Hash for any import by using the hash subcommand +-- of this package. For example: +-- +-- > $ dhall hash <<< './bar' +-- > sha256:d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 +-- +-- Now suppose that you actually change the value of the @./baz@ file: +-- +-- > $ cat ./baz +-- > 2 +-- +-- ... then the @./foo@ file will fail to import @./bar@, even though the +-- text of the @./bar@ file technically never changed: +-- +-- > XDG_CACHE_HOME=/var/empty dhall <<< './foo' +-- > +-- > Error: Import integrity check failed +-- > +-- > Expected hash: +-- > +-- > ↳ d60d8415e36e86dae7f42933d3b0c4fe3ca238f057fba206c7e9fbf5d784fe15 +-- > +-- > Actual hash: +-- > +-- > ↳ 4caf97e8c445d4d4b5c5b992973e098ed4ae88a355915f5a59db640a589bc9cb +-- +-- This is because the @./bar@ file now represents a new value (@2@ instead of +-- @1@), even though the text of the @./bar@ file is still the same. Since the +-- value changed the hash must change as well. However, we could change @./baz@ +-- to: +-- +-- > $ cat baz +-- > if True then 1 else 2 +-- +-- ... and the import would now succeed again because the final result is @1@. +-- +-- The integrity hash ensures that your import's final meaning can never change, +-- so an attacker can never compromise an imported value protected by a hash +-- unless they can break SHA-256 encryption. The hash not only protects the +-- file that you immediately import, but also protects every transitive import +-- as well. +-- +-- You can also safely refactor your imported dependencies knowing that the +-- refactor will not change your hash so long as your refactor is +-- behavior-preserving. This provides an easy way to detect refactoring errors +-- that you might accidentally introduce. The hash not only protects you +-- from attackers, but also protects against human error, too! +-- +-- If you have a file which either doesn't already use hashed imports, +-- or you changed some of the imports and want to update the hashes you can use the +-- freeze command to either add or update hashes: +-- +-- > $ cat foo.dhall +-- > let replicate = https://prelude.dhall-lang.org/List/replicate +-- > in replicate 5 +-- > $ +-- > $ dhall freeze --inplace ./foo.dhall +-- > $ cat ./foo.dhall +-- > let replicate = +-- > https://prelude.dhall-lang.org/List/replicate sha256:d4250b45278f2d692302489ac3e78280acb238d27541c837ce46911ff3baa347 +-- > +-- > in replicate 5 + +-- $rawText +-- +-- Sometimes you want to import the contents of a raw text file as a Dhall +-- value of type `Text`. For example, one of the fields of a record might be +-- the contents of a software license: +-- +-- > { package = "dhall" +-- > , author = "Gabriel Gonzalez" +-- > , license = ./LICENSE +-- > } +-- +-- Normally if you wanted to import a text file you would need to wrap the +-- contents of the file in double single-quotes, like this: +-- +-- > $ cat LICENSE +-- > '' +-- > Copyright (c) 2017 Gabriel Gonzalez +-- > All rights reserved. +-- > +-- > ... +-- > (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- > SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- > '' +-- +-- ... which does not work well if you need to reuse the same text file for +-- other programs +-- +-- However, Dhall supports importing a raw text file by adding @as Text@ to the +-- end of the import, like this: +-- +-- > { package = "dhall" +-- > , author = "Gabriel Gonzalez" +-- > , license = ./LICENSE as Text +-- > } +-- +-- ... and then you can use the original text file unmodified: +-- +-- > $ cat LICENSE +-- > Copyright (c) 2017 Gabriel Gonzalez +-- > All rights reserved. +-- > +-- > ... +-- > (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- > SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-- $format +-- +-- A format subcommand is also available that you can use to +-- automatically format Dhall expressions. For example, we can take the +-- following unformatted Dhall expression: +-- +-- > $ cat ./unformatted +-- > λ(a : Type) → λ(kvss : List (List { index : Natural, value : a })) → +-- > List/build { index : Natural, value : a } (λ(list : Type) → λ(cons : { +-- > index : Natural, value : a } → list → list) → λ(nil : list) → +-- > (List/fold (List { index : Natural, value : a }) kvss { count : Natural, diff : +-- > Natural → list } (λ(kvs : List { index : Natural, value : a }) → λ(y : { +-- > count : Natural, diff : Natural → list }) → { count = y.count + List/length +-- > { index : Natural, value : a } kvs, diff = λ(n : Natural) → List/fold { +-- > index : Natural, value : a } kvs list (λ(kvOld : { index : Natural, value : a +-- > }) → λ(z : list) → cons { index = kvOld.index + n, value = kvOld.value } +-- > z) (y.diff (n + List/length { index : Natural, value : a } kvs)) }) { count = +-- > 0, diff = λ(_ : Natural) → nil }).diff 0) +-- +-- ... and run the expression through the formatter: +-- +-- > $ dhall format < ./unformatted +-- > λ(a : Type) +-- > → λ(kvss : List (List { index : Natural, value : a })) +-- > → List/build +-- > { index : Natural, value : a } +-- > ( λ(list : Type) +-- > → λ(cons : { index : Natural, value : a } → list → list) +-- > → λ(nil : list) +-- > → ( List/fold +-- > (List { index : Natural, value : a }) +-- > kvss +-- > { count : Natural, diff : Natural → list } +-- > ( λ(kvs : List { index : Natural, value : a }) +-- > → λ(y : { count : Natural, diff : Natural → list }) +-- > → { count = +-- > y.count + List/length { index : Natural, value : a } kvs +-- > , diff = +-- > λ(n : Natural) +-- > → List/fold +-- > { index : Natural, value : a } +-- > kvs +-- > list +-- > ( λ(kvOld : { index : Natural, value : a }) +-- > → λ(z : list) +-- > → cons +-- > { index = kvOld.index + n, value = kvOld.value } +-- > z +-- > ) +-- > ( y.diff +-- > (n + List/length { index : Natural, value : a } kvs) +-- > ) +-- > } +-- > ) +-- > { count = 0, diff = λ(_ : Natural) → nil } +-- > ).diff +-- > 0 +-- > ) +-- +-- The executable formats expressions without resolving, type-checking, or +-- normalizing them: +-- +-- > $ dhall format +-- > let replicate = https://prelude.dhall-lang.org/List/replicate +-- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) +-- > +-- > let replicate = https://prelude.dhall-lang.org/List/replicate +-- > +-- > in replicate +-- > 5 +-- > (List (List Natural)) +-- > (replicate 5 (List Natural) (replicate 5 Natural 1)) +-- +-- You can also use the formatter to modify files in place using the +-- @--inplace@ flag (i.e. for formatting source code): +-- +-- > $ dhall format --inplace ./unformatted +-- +-- Carefully note that the code formatter does not preserve all comments. +-- Currently, the formatter only preserves two types of comments: +-- +-- * Leading comments at the beginning of the file +-- * Comments within a @let@ binding +-- +-- For example: +-- +-- > $ dhall format +-- > {- This comment will be preserved by the formatter -} +-- > -- ... and this comment will be preserved, too +-- > {- This comment will *NOT* be preserved -} 1 +-- > -- ... and this comment will also *NOT* be preserved +-- > +-- > {- This comment will be preserved by the formatter -} +-- > -- ... and this comment will be preserved, too +-- > 1 +-- +-- Also: +-- +-- > let {- This comment will be preserved -} +-- > x {- This comment will also be preserved-} = +-- > {- ... and this one will be preserved, too -} +-- > 1 +-- > +-- > in x +-- +-- Note that you do not need to format the output of the +-- @dhall@ interpreter. The interpreter already automatically formats +-- multi-line expressions, too: +-- +-- > $ dhall +-- > let replicate = https://prelude.dhall-lang.org/List/replicate +-- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) +-- > +-- > [ [ [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > ] +-- > , [ [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > ] +-- > , [ [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > ] +-- > , [ [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > ] +-- > , [ [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > , [ 1, 1, 1, 1, 1 ] +-- > ] +-- > ] + +-- $builtins +-- +-- Dhall is a restricted programming language that only supports simple built-in +-- functions and operators. If you want to do anything fancier you will need to +-- load your data into Haskell for further processing +-- +-- This section covers types, functions, and operators that are built into the +-- language, meaning that you do not need to import any code to use them. +-- Additionally, Dhall also comes with a Prelude (covered in the next section) +-- hosted online that contains functions derived from these base utilities. The +-- Prelude also re-exports all built-in functions for people who prefer +-- consistency. +-- +-- The language provides built-in support for the following primitive types: +-- +-- * @Bool@ values +-- * @Natural@ values +-- * @Integer@ values +-- * @Double@ values +-- * @Text@ values +-- +-- ... as well as support for the following derived types: +-- +-- * @List@s of values +-- * @Optional@ values +-- * Anonymous records +-- * Anonymous unions +-- +-- You can find an up-to-date list of available built-in functions and operators +-- here: +-- +-- + +-- $caveats +-- +-- Dhall differs in a few important ways from other programming languages, so +-- you should keep the following caveats in mind: +-- +-- First, Dhall only supports addition and multiplication on @Natural@ numbers +-- (i.e. non-negative integers), which are not the same type of number as +-- @Integer@s (which can be negative). An @Integer@ number is a number prefixed +-- with either a @+@ or @-@ symbol whereas a @Natural@ number has no leading +-- sign. If you try to add or multiply two @Integer@s you will get a type +-- error: +-- +-- > $ dhall +-- > +2 + +2 +-- > +-- > Use "dhall --explain" for detailed errors +-- > +-- > Error: ❰+❱ only works on ❰Natural❱s +-- > +-- > +2 + +2 +-- > +-- > (stdin):1:1 +-- +-- In fact, there are no built-in functions for @Integer@s (or @Double@s) other +-- than @Integer/show@ and @Double/show@. As far as the language is concerned +-- they are opaque values that can only be shuffled around but not used in any +-- meaningful way until they have been loaded into Haskell. +-- +-- Second, the equality @(==)@ and inequality @(!=)@ operators only work on +-- @Bool@s. You cannot test any other types of values for equality. +-- +-- However, you can extend the language with your own built-ins using the +-- Haskell API, as described in the next section. + +-- $extending +-- +-- You can use the Haskell API to extend the Dhall configuration language with +-- new built-in functions. This section contains a simple Haskell recipe to add +-- a new @Natural/equal@ built-in function of type: +-- +-- > Natural/equal : Natural → Natural → Bool +-- +-- To do so, we: +-- +-- * extend the type-checking context to include the type of @Natural/equal@ +-- * extend the normalizer to evaluate all occurrences of @Natural/equal@ +-- +-- ... like this: +-- +-- > -- example.hs +-- > +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main where +-- > +-- > import Dhall.Core (Expr(..), ReifiedNormalizer(..)) +-- > +-- > import qualified Data.Text.IO +-- > import qualified Dhall +-- > import qualified Dhall.Context +-- > import qualified Lens.Family as Lens +-- > +-- > main :: IO () +-- > main = do +-- > text <- Data.Text.IO.getContents +-- > +-- > let startingContext = transform Dhall.Context.empty +-- > where +-- > transform = Dhall.Context.insert "Natural/equal" naturalEqualType +-- > +-- > naturalEqualType = +-- > Pi "_" Natural (Pi "_" Natural Bool) +-- > +-- > let normalizer (App (App (Var "Natural/equal") (NaturalLit x)) (NaturalLit y)) = +-- > Just (BoolLit (x == y)) +-- > normalizer _ = +-- > Nothing +-- > +-- > let inputSettings = transform Dhall.defaultInputSettings +-- > where +-- > transform = +-- > Lens.set Dhall.normalizer (ReifiedNormalizer (pure . normalizer)) +-- > . Lens.set Dhall.startingContext startingContext +-- > +-- > x <- Dhall.inputWithSettings inputSettings Dhall.auto text +-- > +-- > Data.Text.IO.putStrLn x +-- +-- Here is an example use of the above program: +-- +-- > $ ./example <<< 'if Natural/equal 2 (1 + 1) then "Equal" else "Not equal"' +-- > Equal +-- +-- Note that existing Dhall tools that type-check expressions will reject +-- expressions containing unexpected free variable such as @Natural/equal@: +-- +-- > $ dhall <<< 'Natural/equal 2 (1 + 1)' +-- > +-- > Use "dhall --explain" for detailed errors +-- > +-- > Error: Unbound variable +-- > +-- > Natural/equal +-- > +-- > (stdin):1:1 +-- +-- You will need to either: +-- +-- * create your own parallel versions of these tools, or: +-- * < https://github.com/dhall-lang/dhall-lang/blob/master/.github/CONTRIBUTING.md#how-do-i-change-the-language try to upstream your built-ins into the language> +-- +-- The general guidelines for adding new built-ins to the language are: +-- +-- * Keep built-ins easy to implement across language bindings +-- * Prefer general purpose built-ins or built-ins appropriate for the task of program configuration +-- * Design built-ins to catch errors as early as possible (i.e. when type-checking the configuration) + +-- $prelude +-- +-- There is also a Prelude available at: +-- +-- +-- +-- If you visit the above link you can browse the Prelude, which has a few +-- subdirectories. For example, the @Bool@ subdirectory has a @not@ file, which +-- you can reference using this URL: +-- +-- +-- +-- The @not@ function is just a UTF8-encoded text file hosted online with the +-- following contents +-- +-- > $ $ dhall <<< 'https://prelude.dhall-lang.org/Bool/not as Text' +-- > '' +-- > {- +-- > Flip the value of a `Bool` +-- > -} +-- > let not : Bool → Bool = λ(b : Bool) → b == False +-- > +-- > let example0 = assert : not True ≡ False +-- > +-- > let example1 = assert : not False ≡ True +-- > +-- > in not +-- > '' +-- +-- The file could have been much shorter, like this: +-- +-- > λ(b : Bool) → b == False +-- +-- ... but all the functions exported from the Prelude try to be as +-- self-documenting as possible by including: +-- +-- * the name of the function +-- * the type of the function +-- * documentation +-- * tests +-- +-- The performance penalty for adding these helpful features is negligible, +-- especially if you protect the import with a semantic integrity check because +-- then the import would be cached compactly as @λ(_ : Bool) → _ == False@. +-- +-- You can use this @not@ function either directly: +-- +-- > $ dhall +-- > https://prelude.dhall-lang.org/Bool/not True +-- > +-- > False +-- +-- ... or assign the URL to a shorter name: +-- +-- > $ dhall +-- > let Bool/not = https://prelude.dhall-lang.org/Bool/not +-- > in Bool/not True +-- > +-- > False +-- +-- Some functions in the Prelude just re-export built-in functions for +-- consistency and documentation, such as @Prelude\/Natural\/even@, which +-- re-exports the built-in @Natural/even@ function: +-- +-- > $ dhall <<< 'https://prelude.dhall-lang.org/Natural/even as Text' +-- > '' +-- > {- +-- > Returns `True` if a number if even and returns `False` otherwise +-- > -} +-- > let even : Natural → Bool = Natural/even +-- > +-- > let example0 = assert : even 3 ≡ False +-- > +-- > let example1 = assert : even 0 ≡ True +-- > +-- > in even +-- > '' +-- +-- You can also clone the Prelude locally to your filesystem if you prefer +-- using `git clone`, like this: +-- +-- > $ git clone https://github.com/dhall-lang/dhall-lang.git +-- > $ tree dhall-lang/Prelude +-- > dhall-lang/Prelude +-- > ├── Bool +-- > │   ├── and +-- > │   ├── build +-- > │   ├── even +-- > │   ├── fold +-- > │   ├── not +-- > │   ├── odd +-- > │   ├── or +-- > │   ├── package.dhall +-- > │   └── show +-- > ├── Double +-- > │   ├── package.dhall +-- > │   └── show +-- > ├── Function +-- > │   ├── compose +-- > │   └── package.dhall +-- > ├── Integer +-- > │   ├── package.dhall +-- > │   ├── show +-- > │   └── toDouble +-- > ├── JSON +-- > │   ├── Nesting +-- > │   ├── Tagged +-- > │   ├── Type +-- > │   ├── array +-- > │   ├── bool +-- > │   ├── keyText +-- > │   ├── keyValue +-- > │   ├── null +-- > │   ├── number +-- > │   ├── object +-- > │   ├── package.dhall +-- > │   ├── render +-- > │   └── string +-- > ├── List +-- > │   ├── all +-- > │   ├── any +-- > │   ├── build +-- > │   ├── concat +-- > │   ├── concatMap +-- > │   ├── default +-- > │   ├── empty +-- > │   ├── filter +-- > │   ├── fold +-- > │   ├── generate +-- > │   ├── head +-- > │   ├── indexed +-- > │   ├── iterate +-- > │   ├── last +-- > │   ├── length +-- > │   ├── map +-- > │   ├── null +-- > │   ├── package.dhall +-- > │   ├── replicate +-- > │   ├── reverse +-- > │   ├── shifted +-- > │   └── unzip +-- > ├── Location +-- > │   ├── Type +-- > │   └── package.dhall +-- > ├── Map +-- > │   ├── Entry +-- > │   ├── Type +-- > │   ├── empty +-- > │   ├── keyText +-- > │   ├── keyValue +-- > │   ├── keys +-- > │   ├── map +-- > │   ├── package.dhall +-- > │   └── values +-- > ├── Monoid +-- > ├── Natural +-- > │   ├── build +-- > │   ├── enumerate +-- > │   ├── equal +-- > │   ├── even +-- > │   ├── fold +-- > │   ├── greaterThan +-- > │   ├── greaterThanEqual +-- > │   ├── isZero +-- > │   ├── lessThan +-- > │   ├── lessThanEqual +-- > │   ├── odd +-- > │   ├── package.dhall +-- > │   ├── product +-- > │   ├── show +-- > │   ├── subtract +-- > │   ├── sum +-- > │   ├── toDouble +-- > │   └── toInteger +-- > ├── Optional +-- > │   ├── all +-- > │   ├── any +-- > │   ├── build +-- > │   ├── concat +-- > │   ├── default +-- > │   ├── filter +-- > │   ├── fold +-- > │   ├── head +-- > │   ├── last +-- > │   ├── length +-- > │   ├── map +-- > │   ├── null +-- > │   ├── package.dhall +-- > │   ├── toList +-- > │   └── unzip +-- > ├── Text +-- > │   ├── concat +-- > │   ├── concatMap +-- > │   ├── concatMapSep +-- > │   ├── concatSep +-- > │   ├── default +-- > │   ├── defaultMap +-- > │   ├── package.dhall +-- > │   └── show +-- > ├── XML +-- > │   ├── Type +-- > │   ├── attribute +-- > │   ├── element +-- > │   ├── emptyAttributes +-- > │   ├── leaf +-- > │   ├── package.dhall +-- > │   ├── render +-- > │   └── text +-- > └── package.dhall +-- +-- Browse the Prelude online to learn more by seeing what functions are +-- available and reading their inline documentation: +-- +-- +-- +-- __Exercise__: Try to use a new Prelude function that has not been covered +-- previously in this tutorial +-- +-- You can also import the entire Prelude as a single large record for +-- convenience: +-- +-- > $ dhall +-- > let Prelude = https://prelude.dhall-lang.org/package.dhall +-- > +-- > in λ(x : Text) +-- > → Prelude.List.length Text (Prelude.List.replicate 10 Text x) +-- > +-- > ∀(x : Text) → Natural +-- > +-- > λ(x : Text) → 10 +-- +-- The organization of the package mirrors the layout of the Prelude, meaning +-- that every directory is stored as a record whose children are the fields of +-- that record. +-- +-- __Exercise__: Browse the Prelude by running: +-- +-- > $ dhall <<< 'https://prelude.dhall-lang.org/package.dhall' + +-- $conclusion +-- +-- By this point you should be able to use the Dhall configuration language to +-- author, import, and program configuration files. If you run into any issues +-- you can report them at: +-- +-- +-- +-- You can also request features, support, or documentation improvements on the +-- above issue tracker. +-- +-- If you would like to contribute to the Dhall project you can try to port +-- Dhall to languages that do not yet have Dhall integrations so that Dhall configuration files +-- can be read into those languages, too. + +-- $faq +-- +-- diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -53,6 +53,7 @@ import qualified Data.Text as Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty +import qualified Data.Traversable import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Diff @@ -61,8 +62,16 @@ import qualified Dhall.Set import qualified Dhall.Pretty.Internal import qualified Dhall.Util +import qualified Lens.Family +{-| A type synonym for `Void` + + This is provided for backwards compatibility, since Dhall used to use its + own `X` type instead of @"Data.Void".`Void`@. You should use `Void` instead + of `X` now +-} type X = Void +{-# DEPRECATED X "Use Data.Void.Void instead" #-} traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f () traverseWithIndex_ k xs = @@ -305,7 +314,7 @@ if Eval.conv values _T₀' _T₁' then do - return _T₀' + return _T₁' else do let _T₀'' = quote names _T₀' @@ -593,35 +602,20 @@ die MissingListType ListLit (Just _T₀) ts -> do - _ <- loop ctx _T₀ - - let _T₀' = eval values _T₀ - - let _T₀'' = quote names _T₀' - - case _T₀' of - VList _T₁' -> do - tT₁' <- loop ctx (quote names _T₁') - - case tT₁' of - VConst Type -> return () - _ -> die (InvalidListType _T₀'') - - _ -> do - die (InvalidListType _T₀'') + if Data.Sequence.null ts + then do + _ <- loop ctx _T₀ - let process i t = do - _T₁' <- loop ctx t + let _T₀' = eval values _T₀ - if Eval.conv values _T₀' _T₁' - then return () - else do - let _T₁'' = quote names _T₁' - die (InvalidListElement i _T₀'' t _T₁'') + let _T₀'' = quote names _T₀' - traverseWithIndex_ process ts + case _T₀' of + VList _ -> return _T₀' + _ -> die (InvalidListType _T₀'') - return _T₀' + -- See https://github.com/dhall-lang/dhall-haskell/issues/1359. + else die ListLitInvariant ListAppend x y -> do tx' <- loop ctx x @@ -757,18 +751,16 @@ return (VConst c) RecordLit xts -> do - let process x t = do + let process t = do _T' <- loop ctx t let _T'' = quote names _T' - tT' <- loop ctx _T'' + _ <- loop ctx _T'' - case tT' of - VConst _ -> return _T' - _ -> die (InvalidFieldType x _T'') + return _T' - xTs <- Dhall.Map.unorderedTraverseWithKey process (Dhall.Map.sort xts) + xTs <- traverse process (Dhall.Map.sort xts) return (VRecord xTs) @@ -904,6 +896,9 @@ return (VRecord (Dhall.Map.union xRs' xLs')) + RecordCompletion l r -> do + loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type")) + Merge t u mT₁ -> do _T' <- loop ctx t @@ -937,86 +932,100 @@ then return () else die (UnusedHandler diffT) - (my₀, _T₁') <- do - case mT₁ of - Just _T₁ -> do - return (Nothing, eval values _T₁) + if Data.Set.null diffU + then return () + else die (MissingHandler diffU) - Nothing -> do - case Dhall.Map.uncons yTs' of - Nothing -> do - die MissingMergeType + let match _y _T₀' Nothing = + return _T₀' - Just (y₀, _T', _) -> do - _T₁' <- do - case Dhall.Map.lookup y₀ yUs' of - Nothing -> do - die (UnusedHandler diffU) + match y handler' (Just _A₁') = + case Eval.toVHPi handler' of + Just (x, _A₀', _T₀') -> do + if Eval.conv values _A₀' _A₁' + then do + let _T₁' = _T₀' (fresh ctx x) - Just Nothing -> do - return _T' + let _T₁'' = quote names _T₁' - Just (Just _) -> do - case Eval.toVHPi _T' of - Just (x, _A₀', _T₀') -> do - return (_T₀' (fresh ctx x)) + -- x appearing in _T₁'' would indicate a disallowed + -- handler type (see + -- https://github.com/dhall-lang/dhall-lang/issues/749). + -- + -- If x appears in _T₁'', quote will have given it index + -- -1. Any well-typed variable has a non-negative index, + -- so we can simply look for negative indices to detect x. + let containsBadVar (Var (V _ n)) = + n < 0 - Nothing -> do - let _T'' = quote names _T' + containsBadVar e = + Lens.Family.anyOf + Dhall.Core.subExpressions + containsBadVar + e - die (HandlerNotAFunction y₀ _T'') + if containsBadVar _T₁'' + then do + let handler'' = quote names handler' - return (Just y₀, _T₁') + let outputType = Dhall.Core.shift 1 (V x (-1)) _T₁'' - let _T₁'' = quote names _T₁' + die (DisallowedHandlerType y handler'' outputType x) - _ <- loop ctx _T₁'' + else return _T₁' - let process y mU = do - case Dhall.Map.lookup y yTs' of - Nothing -> do - die (MissingHandler diffU) + else do + let _A₀'' = quote names _A₀' + let _A₁'' = quote names _A₁' - Just _T' -> do - _T₃' <- do - case mU of - Nothing -> do - return _T' + die (HandlerInputTypeMismatch y _A₁'' _A₀'') - Just _A₁' -> do - case Eval.toVHPi _T' of - Just (x, _A₀', _T₂') -> do - if Eval.conv values _A₀' _A₁' - then do - return () + Nothing -> do + let handler'' = quote names handler' - else do - let _A₀'' = quote names _A₀' - let _A₁'' = quote names _A₁' + die (HandlerNotAFunction y handler'') - die (HandlerInputTypeMismatch y _A₁'' _A₀'') + matched <- + sequence + (Data.Map.intersectionWithKey match (Dhall.Map.toMap yTs') (Dhall.Map.toMap yUs')) - return (_T₂' (fresh ctx x)) + let checkMatched :: Data.Map.Map Text (Val a) -> Either (TypeError s a) (Maybe (Val a)) + checkMatched = fmap (fmap snd) . Data.Foldable.foldlM go Nothing . Data.Map.toList + where + go Nothing (y₁, _T₁') = + return (Just (y₁, _T₁')) - Nothing -> do - let _T'' = quote names _T' + go yT₀'@(Just (y₀, _T₀')) (y₁, _T₁') = + if Eval.conv values _T₀' _T₁' + then return yT₀' - die (HandlerNotAFunction y _T'') + else do + let _T₀'' = quote names _T₀' + let _T₁'' = quote names _T₁' + die (HandlerOutputTypeMismatch y₀ _T₀'' y₁ _T₁'') - if Eval.conv values _T₁' _T₃' - then do - return () + mT₀' <- checkMatched matched - else do - let _T₃'' = quote names _T₃' + mT₁' <- Data.Traversable.for mT₁ $ \_T₁ -> do + _ <- loop ctx _T₁ - case my₀ of - Nothing -> die (InvalidHandlerOutputType y _T₁'' _T₃'') - Just y₀ -> die (HandlerOutputTypeMismatch y₀ _T₁'' y _T₃'') + return (eval values _T₁) - Dhall.Map.unorderedTraverseWithKey_ process yUs' + case (mT₀', mT₁') of + (Nothing, Nothing) -> + die MissingMergeType + (Nothing, Just _T₁') -> + return _T₁' + (Just _T₀', Nothing) -> + return _T₀' + (Just _T₀', Just _T₁') -> do + if Eval.conv values _T₀' _T₁' + then return _T₀' - return _T₁' + else do + let _T₀'' = quote names _T₀' + let _T₁'' = quote names _T₁' + die (AnnotMismatch (Merge t u Nothing) _T₁'' _T₀'') ToMap e mT₁ -> do _E' <- loop ctx e @@ -1080,7 +1089,7 @@ die (InvalidToMapType _T₁'') (Just (Right _T'), Just _T₁') | Eval.conv values (mapType _T') _T₁' -> do - pure _T₁' + pure (mapType _T') | otherwise -> do let _T₁'' = quote names _T₁' @@ -1093,8 +1102,6 @@ case _E' of VRecord xTs' -> do - _ <- loop ctx _E'' - case Dhall.Map.lookup x xTs' of Just _T' -> return _T' Nothing -> die (MissingField x _E'') @@ -1121,8 +1128,6 @@ case _E' of VRecord xTs' -> do - _ <- loop ctx _E'' - let process x = case Dhall.Map.lookup x xTs' of Just _T' -> return (x, _T') @@ -1269,6 +1274,7 @@ | MismatchedListElements Int (Expr s a) (Expr s a) (Expr s a) | InvalidListElement Int (Expr s a) (Expr s a) (Expr s a) | InvalidListType (Expr s a) + | ListLitInvariant | InvalidSome (Expr s a) (Expr s a) (Expr s a) | InvalidPredicate (Expr s a) (Expr s a) | IfBranchMismatch (Expr s a) (Expr s a) (Expr s a) (Expr s a) @@ -1292,6 +1298,7 @@ | UnusedHandler (Set Text) | MissingHandler (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) | InvalidHandlerOutputType Text (Expr s a) (Expr s a) | MissingMergeType @@ -2240,6 +2247,21 @@ txt2 = insert expr2 txt3 = insert expr3 +prettyTypeMessage (ListLitInvariant) = ErrorMessages {..} + where + short = "Internal error: A non-empty list literal violated an internal invariant" + + long = + "Explanation: Internal error: A non-empty list literal violated an internal \n\ + \invariant. \n\ + \ \n\ + \A non-empty list literal must always be represented as \n\ + \ \n\ + \ ListLit Nothing [x, y, ...] \n\ + \ \n\ + \Please file a bug report at https://github.com/dhall-lang/dhall-haskell/issues, \n\ + \ideally including the offending source code. \n" + prettyTypeMessage (InvalidListType expr0) = ErrorMessages {..} where short = "Invalid type for ❰List❱" @@ -3140,6 +3162,52 @@ txt1 = insert expr1 txt2 = insert expr2 +prettyTypeMessage (DisallowedHandlerType label handlerType handlerOutputType variable) = + ErrorMessages {..} + where + short = "Disallowed handler type" + + long = + "Explanation: You can ❰merge❱ the alternatives of a union using a record with one\n\ + \handler per alternative, like this: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────────────────┐ \n\ + \ │ let union = < Left : Natural | Right : Bool >.Left 2 │ \n\ + \ │ let handlers = { Left = Natural/even, Right = λ(x : Bool) → x } │ \n\ + \ │ in merge handlers union : Bool │ \n\ + \ └─────────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but the output type of a handler may not depend on the input value. \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ Invalid: The output type is ❰Optional A❱, which references the input \n\ + \ value ❰A❱. \n\ + \ ⇩ \n\ + \ ┌──────────────────────────────────────────┐ \n\ + \ │ merge { x = None } (< x : Type >.x Bool) │ \n\ + \ └──────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Your handler for the following alternative: \n\ + \ \n\ + \" <> insert label <> "\n\ + \ \n\ + \... has type: \n\ + \ \n\ + \" <> insert handlerType <> "\n\ + \ \n\ + \... where the output type: \n\ + \ \n\ + \" <> insert handlerOutputType <> "\n\ + \ \n\ + \... references the handler's input value: \n\ + \ \n\ + \" <> insert variable <> "\n" + prettyTypeMessage (InvalidHandlerOutputType expr0 expr1 expr2) = ErrorMessages {..} where @@ -3316,7 +3384,19 @@ \ └─────────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ - \... but the argument to ❰toMap❱ must be a record and not some other type. \n" + \... but the argument to ❰toMap❱ must be a record and not some other type. \n\ + \ \n\ + \Some common reasons why you might get this error: \n\ + \ \n\ + \● You accidentally provide an empty record type instead of an empty record when \n\ + \ using ❰toMap❱: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────────────────┐ \n\ + \ │ toMap {} : List { mapKey : Text, mapValue : Natural } │ \n\ + \ └───────────────────────────────────────────────────────┘ \n\ + \ ⇧ \n\ + \ This should be ❰{=}❱ instead \n" prettyTypeMessage (InvalidToMapRecordKind type_ kind) = ErrorMessages {..} where @@ -3430,9 +3510,9 @@ "Explanation: You can only access fields on records or unions, like this: \n\ \ \n\ \ \n\ - \ ┌───────────────────────────────────┐ \n\ + \ ┌─────────────────────────────────┐ \n\ \ │ { foo = True, bar = \"ABC\" }.foo │ This is valid ... \n\ - \ └───────────────────────────────────┘ \n\ + \ └─────────────────────────────────┘ \n\ \ \n\ \ \n\ \ ┌───────────────────────────────────────────┐ \n\ @@ -4249,6 +4329,8 @@ InvalidListElement <$> pure a <*> f b <*> f c <*> f d InvalidListType a -> InvalidListType <$> f a + ListLitInvariant -> + pure ListLitInvariant InvalidSome a b c -> InvalidSome <$> f a <*> f b <*> f c InvalidPredicate a b -> @@ -4295,6 +4377,8 @@ MissingHandler <$> pure a HandlerInputTypeMismatch a b c -> HandlerInputTypeMismatch <$> pure a <*> f b <*> f c + DisallowedHandlerType a b c d -> + DisallowedHandlerType <$> pure a <*> f b <*> f c <*> pure d HandlerOutputTypeMismatch a b c d -> HandlerOutputTypeMismatch <$> pure a <*> f b <*> pure c <*> f d InvalidHandlerOutputType a b c -> diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -9,6 +9,7 @@ , _ERROR , Censor(..) , Input(..) + , Output(..) , getExpression , getExpressionAndHeader ) where @@ -97,13 +98,13 @@ get parser censor input = do inText <- do case input of - File file -> Data.Text.IO.readFile file - StandardInput -> Data.Text.IO.getContents + InputFile file -> Data.Text.IO.readFile file + StandardInput -> Data.Text.IO.getContents let name = case input of - File file -> file - StandardInput -> "(stdin)" + InputFile file -> file + StandardInput -> "(stdin)" let result = parser name inText @@ -118,7 +119,10 @@ data Censor = NoCensor | Censor -- | Path to input -data Input = StandardInput | File FilePath +data Input = StandardInput | InputFile FilePath + +-- | Path to output +data Output = StandardOutput | OutputFile FilePath -- | Convenient utility for retrieving an expression getExpression :: Censor -> Input -> IO (Expr Src Import) diff --git a/src/Dhall/Version.hs b/src/Dhall/Version.hs --- a/src/Dhall/Version.hs +++ b/src/Dhall/Version.hs @@ -1,3 +1,6 @@ +{-| Utilities for getting the current version of the Haskell implementation of + Dhall +-} module Dhall.Version ( dhallVersion , dhallVersionString ) where @@ -5,8 +8,10 @@ import qualified Data.Version as V import qualified Paths_dhall as P +-- | The current `Version` of the Haskell implementation dhallVersion :: V.Version dhallVersion = P.version +-- | The current version `String` for the Haskell implementation dhallVersionString :: String dhallVersionString = V.showVersion dhallVersion 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 @@ -22,7 +22,7 @@ import Data.Scientific (Scientific) import Data.Text (Text) import Data.Vector (Vector) -import Dhall (Inject, Interpret) +import Dhall (ToDhall, FromDhall) import Dhall.Core (Expr(..)) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -40,14 +40,14 @@ = LitF Natural | AddF expr expr | MulF expr expr - deriving (Eq, Functor, Generic, Interpret, Show) + deriving (Eq, Functor, Generic, FromDhall, Show) tests :: TestTree tests = testGroup "Input" [ shouldShowDetailedTypeError , shouldHandleUnionLiteral - , shouldHaveWorkingRecursiveInterpret + , shouldHaveWorkingRecursiveFromDhall , shouldHaveWorkingGenericAuto , shouldHandleUnionsCorrectly , shouldTreatAConstructorStoringUnitAsEmptyAlternative @@ -116,8 +116,8 @@ Dhall.embed exampleInputType () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A" -shouldHaveWorkingRecursiveInterpret :: TestTree -shouldHaveWorkingRecursiveInterpret = testGroup "recursive Interpret instance" +shouldHaveWorkingRecursiveFromDhall :: TestTree +shouldHaveWorkingRecursiveFromDhall = testGroup "recursive FromDhall instance" [ testCase "works for a recursive expression" $ do actual <- Dhall.input Dhall.auto "./tests/recursive/expr0.dhall" @@ -156,10 +156,10 @@ ] data NonEmptyUnion = N0 Bool | N1 Natural | N2 Text - deriving (Eq, Generic, Inject, Interpret, Show) + deriving (Eq, Generic, ToDhall, FromDhall, Show) data Enum = E0 | E1 | E2 - deriving (Eq, Generic, Inject, Interpret, Show) + deriving (Eq, Generic, ToDhall, FromDhall, Show) data Records = R0 {} @@ -167,12 +167,10 @@ | R2 { x :: Double } | R3 { a :: (), b :: () } | R4 { x :: Double, y :: Double } - deriving (Eq, Generic, Inject, Interpret, Show) + deriving (Eq, Generic, ToDhall, FromDhall, Show) data Products = P0 | P1 () | P2 Double | P3 () () | P4 Double Double - deriving (Eq, Generic, Inject, Interpret, Show) - -deriving instance Interpret () + deriving (Eq, Generic, ToDhall, FromDhall, Show) shouldHandleUnionsCorrectly :: TestTree shouldHandleUnionsCorrectly = @@ -257,52 +255,52 @@ `shouldMarshalIntoSmart` P4 1.0 2.0 , N0 True - `shouldInjectInto` + `shouldEmbedAs` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N0 { _1 = True }" , N1 5 - `shouldInjectInto` + `shouldEmbedAs` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N1 { _1 = 5 }" , N2 "ABC" - `shouldInjectInto` + `shouldEmbedAs` "(< N0 : { _1 : Bool } | N1 : { _1 : Natural } | N2 : { _1 : Text } >).N2 { _1 = \"ABC\" }" , N0 True - `shouldInjectIntoSmart` + `shouldEmbedAsSmart` "(< N0 : Bool | N1 : Natural | N2 : Text >).N0 True" , N1 5 - `shouldInjectIntoSmart` + `shouldEmbedAsSmart` "(< N0 : Bool | N1 : Natural | N2 : Text >).N1 5" , N2 "ABC" - `shouldInjectIntoSmart` + `shouldEmbedAsSmart` "(< N0 : Bool | N1 : Natural | N2 : Text >).N2 \"ABC\"" - , E0 `shouldInjectInto` "< E0 | E1 | E2 >.E0" - , E1 `shouldInjectInto` "< E0 | E1 | E2 >.E1" - , E2 `shouldInjectInto` "< E0 | E1 | E2 >.E2" + , E0 `shouldEmbedAs` "< E0 | E1 | E2 >.E0" + , E1 `shouldEmbedAs` "< E0 | E1 | E2 >.E1" + , E2 `shouldEmbedAs` "< E0 | E1 | E2 >.E2" - , R0 `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" - , R1 { a = () } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" - , R2 { x = 1.0 } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" - , R3 { a = (), b = () } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" - , R4 { x = 1.0, y = 2.0 } `shouldInjectInto` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" + , R0 `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" + , R1 { a = () } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" + , R2 { x = 1.0 } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" + , R3 { a = (), b = () } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" + , R4 { x = 1.0, y = 2.0 } `shouldEmbedAs` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" - , R0 `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" - , R1 { a = () } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" - , R2 { x = 1.0 } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" - , R3 { a = (), b = () } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" - , R4 { x = 1.0, y = 2.0 } `shouldInjectIntoSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" + , R0 `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R0" + , R1 { a = () } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R1 { a = {=} }" + , R2 { x = 1.0 } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R2 { x = 1.0}" + , R3 { a = (), b = () } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R3 { a = {=}, b = {=} }" + , R4 { x = 1.0, y = 2.0 } `shouldEmbedAsSmart` "< R0 | R1 : { a : {} } | R2 : { x : Double } | R3 : { a : {}, b : {} } | R4 : { x : Double, y : Double } >.R4 { x = 1.0, y = 2.0 }" - , P0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" - , P1 () `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }" - , P2 1.0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }" - , P3 () () `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" - , P4 1.0 2.0 `shouldInjectInto` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" + , P0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" + , P1 () `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1 { _1 = {=} }" + , P2 1.0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 { _1 = 1.0 }" + , P3 () () `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" + , P4 1.0 2.0 `shouldEmbedAs` "< P0 | P1 : { _1 : {} } | P2 : { _1 : Double } | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" - , P0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" - , P1 () `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1" - , P2 1.0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0" - , P3 () () `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" - , P4 1.0 2.0 `shouldInjectIntoSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" + , P0 `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P0" + , P1 () `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P1" + , P2 1.0 `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P2 1.0" + , P3 () () `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P3 { _1 = {=}, _2 = {=} }" + , P4 1.0 2.0 `shouldEmbedAsSmart` "< P0 | P1 | P2 : Double | P3 : { _1 : {}, _2 : {} } | P4 : { _1 : Double, _2 : Double } >.P4 { _1 = 1.0, _2 = 2.0 }" ] where smartOptions = @@ -329,14 +327,14 @@ expectedValue @=? actualValue - value `shouldInjectInto` expectedCode = testCase "Inject" $ do + value `shouldEmbedAs` expectedCode = testCase "ToDhall" $ do parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) resolvedExpression <- Dhall.Import.assertNoImports parsedExpression Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value - value `shouldInjectIntoSmart` expectedCode = testCase "Inject" $ do + value `shouldEmbedAsSmart` expectedCode = testCase "ToDhall" $ do parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) resolvedExpression <- Dhall.Import.assertNoImports parsedExpression @@ -366,7 +364,7 @@ , "{ _1 = True, _2 = {=} }" `correspondsTo` (True, ()) ] where - correspondsTo :: (Eq a, Interpret a, Show a) => Text -> a -> TestTree + correspondsTo :: (Eq a, FromDhall a, Show a) => Text -> a -> TestTree dhallCode `correspondsTo` expectedHaskellValue = testCase "Marshall Dhall code to Haskell" $ do actualHaskellValue <- Dhall.input Dhall.auto dhallCode @@ -396,7 +394,7 @@ , "{ _1 = True, _2 = {=} }" `correspondsTo` (True, ()) ] where - correspondsTo :: Inject a => Text -> a -> TestTree + correspondsTo :: ToDhall a => Text -> a -> TestTree expectedDhallCode `correspondsTo` haskellValue = testCase "Marshall Haskell to Dhall code" $ do let actualDhallCode = 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 @@ -55,12 +55,17 @@ let doc = Doc.pretty header <> Pretty.prettyCharacterSet characterSet expr + <> "\n" let docStream = Doc.layoutSmart Pretty.layoutOpts doc let actualText = Doc.Render.Text.renderStrict docStream expectedText <- Text.IO.readFile outputFile let message = - "The formatted expression did not match the expected output" + "The formatted expression did not match the expected output\n" + <> "Expected:\n\n" <> Text.unpack expectedText <> "\n\n" + <> "Actual:\n\n" <> Text.unpack actualText <> "\n\n" + <> "Expected (show): " <> show expectedText <> "\n" + <> "Actual (show): " <> show actualText <> "\n" - Tasty.HUnit.assertEqual message expectedText actualText + Tasty.HUnit.assertBool message (actualText == expectedText) diff --git a/tests/Dhall/Test/Lint.hs b/tests/Dhall/Test/Lint.hs --- a/tests/Dhall/Test/Lint.hs +++ b/tests/Dhall/Test/Lint.hs @@ -4,8 +4,8 @@ import Data.Monoid (mempty, (<>)) import Data.Text (Text) +import Data.Void (Void) import Dhall.Core (Expr, Import) -import Dhall.TypeCheck (X) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath) @@ -41,14 +41,14 @@ parsedInput <- Core.throws (Parser.exprFromText mempty inputText) - let actualExpression :: Expr X Import + let actualExpression :: Expr Void Import actualExpression = Core.denote (Lint.lint parsedInput) outputText <- Text.IO.readFile outputFile parsedOutput <- Core.throws (Parser.exprFromText mempty outputText) - let expectedExpression :: Expr X Import + let expectedExpression :: Expr Void Import expectedExpression = Core.denote parsedOutput let message = "The linted expression did not match the expected output" diff --git a/tests/Dhall/Test/Main.hs b/tests/Dhall/Test/Main.hs --- a/tests/Dhall/Test/Main.hs +++ b/tests/Dhall/Test/Main.hs @@ -5,6 +5,7 @@ import qualified Dhall.Test.Dhall import qualified Dhall.Test.Diff +import qualified Dhall.Test.Tags import qualified Dhall.Test.Format import qualified Dhall.Test.SemanticHash import qualified Dhall.Test.Import @@ -35,6 +36,8 @@ lintTests <- Dhall.Test.Lint.getTests + tagsTests <- Dhall.Test.Tags.getTests + diffTests <- Dhall.Test.Diff.getTests semanticHashTests <- Dhall.Test.SemanticHash.getTests @@ -49,6 +52,7 @@ , lintTests , diffTests , semanticHashTests + , tagsTests , Dhall.Test.Regression.tests , Dhall.Test.Tutorial.tests , Dhall.Test.QuickCheck.tests diff --git a/tests/Dhall/Test/Normalization.hs b/tests/Dhall/Test/Normalization.hs --- a/tests/Dhall/Test/Normalization.hs +++ b/tests/Dhall/Test/Normalization.hs @@ -4,8 +4,8 @@ import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Void (Void) import Dhall.Core (Expr(..), Var(..), throws) -import Dhall.TypeCheck (X) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath, ()) @@ -86,7 +86,7 @@ nestedReduction = Tasty.HUnit.testCase "doubleReduction" $ do minType <- Context.insert "min" <$> Test.Util.code "Natural → Natural → Natural" fiveorlessType <- Context.insert "fiveorless" <$> Test.Util.code "Natural → Natural" - wurbleType <- Context.insert "wurble" <$> Test.Util.code "Natural → Integer" + wurbleType <- Context.insert "wurble" <$> Test.Util.code "Natural → Natural" let tyCtx = minType . fiveorlessType . wurbleType $ Context.empty @@ -126,7 +126,7 @@ expectedResolved <- Import.assertNoImports expectedExpr - let expectedNormalized = Core.denote expectedResolved :: Expr X X + let expectedNormalized = Core.denote expectedResolved :: Expr Void Void let message = "The normalized expression did not match the expected output" @@ -138,11 +138,11 @@ -} unitTest :: Text -> TestTree unitTest prefix = do - let skip = [] + let expectedFailures = [] let prefixString = Text.unpack prefix - Test.Util.testCase prefix skip $ do + Test.Util.testCase prefix expectedFailures $ do let actualPath = prefixString <> "A.dhall" let expectedPath = prefixString <> "B.dhall" @@ -155,7 +155,7 @@ let actualNormalized = Core.alphaNormalize - (Core.normalize actualResolved :: Expr X X) + (Core.normalize actualResolved :: Expr Void Void) expectedExpr <- throws (Parser.exprFromText mempty expectedCode) @@ -183,7 +183,7 @@ let actualNormalized = Core.alphaNormalize - (Core.normalize actualResolved :: Expr X X) + (Core.normalize actualResolved :: Expr Void Void) expectedExpr <- throws (Parser.exprFromText mempty expectedCode) 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 @@ -4,8 +4,8 @@ import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Void (Void) import Dhall.Core (Binding(..), Expr(..), Import, Var(..)) -import Dhall.TypeCheck (X) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath, ()) @@ -121,14 +121,14 @@ shouldParse :: Text -> TestTree shouldParse path = do - let skip = + let expectedFailures = -- This is a bug created by a parsing performance -- improvement [ parseDirectory "success/unit/MergeParenAnnotation" ] let pathString = Text.unpack path - Test.Util.testCase path skip $ do + Test.Util.testCase path expectedFailures $ do text <- Text.IO.readFile (pathString <> "A.dhall") encoded <- ByteString.Lazy.readFile (pathString <> "B.dhallb") @@ -151,7 +151,7 @@ shouldNotParse :: Text -> TestTree shouldNotParse path = do - let skip = + let expectedFailures = [ -- These two unexpected successes are due to not correctly -- requiring non-empty whitespace after the `:` in a type -- annotation @@ -180,6 +180,7 @@ -- 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/ListLitEmptyAnnotation.dhall" -- The same performance improvements also broke the @@ -189,7 +190,7 @@ let pathString = Text.unpack path - Test.Util.testCase path skip (do + Test.Util.testCase path expectedFailures (do bytes <- ByteString.readFile pathString case Text.Encoding.decodeUtf8' bytes of @@ -201,11 +202,11 @@ shouldDecode :: Text -> TestTree shouldDecode pathText = do - let skip = [] + let expectedFailures = [] let pathString = Text.unpack pathText - Test.Util.testCase pathText skip (do + Test.Util.testCase pathText expectedFailures (do bytes <- ByteString.Lazy.readFile (pathString <> "A.dhallb") term <- Core.throws (Serialise.deserialiseOrFail bytes) @@ -216,7 +217,7 @@ parsedExpression <- Core.throws (Parser.exprFromText mempty text) - let strippedExpression :: Expr X Import + let strippedExpression :: Expr Void Import strippedExpression = Core.denote parsedExpression let message = @@ -226,15 +227,15 @@ shouldNotDecode :: Text -> TestTree shouldNotDecode pathText = do - let skip = [] + let expectedFailures = [] let pathString = Text.unpack pathText - Test.Util.testCase pathText skip (do + 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 X Import) of + case Binary.decodeExpression term :: 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,8 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,12 +12,15 @@ import Codec.Serialise (DeserialiseFailure(..)) import Data.Either (isRight) +import Data.Either.Validation (Validation(..)) +import Dhall (ToDhall(..), FromDhall(..), auto, extract, inject, embed, Vector) import Dhall.Map (Map) import Dhall.Core ( Binding(..) , Chunks(..) , Const(..) , Directory(..) + , DhallDouble(..) , Expr(..) , File(..) , FilePrefix(..) @@ -29,9 +34,11 @@ ) import Data.Functor.Identity (Identity(..)) +import Data.Typeable (Typeable, typeRep) +import Data.Proxy (Proxy(..)) import Dhall.Set (Set) import Dhall.Src (Src(..)) -import Dhall.TypeCheck (Typer) +import Dhall.TypeCheck (Typer, TypeError) import Generic.Random (Weights, W, (%), (:+)(..)) import Test.QuickCheck (Arbitrary(..), Gen, Positive(..), Property, NonNegative(..), genericShrink, (===), (==>)) @@ -45,7 +52,12 @@ import qualified Data.Coerce import qualified Data.List import qualified Data.Sequence +import qualified Data.SpecialValues +import qualified Data.HashSet +import qualified Data.Set import qualified Data.Text as Text +import qualified Data.Map +import qualified Data.HashMap.Strict as HashMap import qualified Dhall.Binary import qualified Dhall.Context import qualified Dhall.Core @@ -54,6 +66,7 @@ import qualified Dhall.Set import qualified Dhall.TypeCheck import qualified Generic.Random +import qualified Numeric.Natural as Nat import qualified Test.QuickCheck import qualified Test.Tasty import qualified Test.Tasty.QuickCheck @@ -161,6 +174,13 @@ shrink = genericShrink +instance Arbitrary DhallDouble where + arbitrary = fmap DhallDouble (Test.QuickCheck.oneof [ arbitrary, special ]) + where + special = Test.QuickCheck.elements Data.SpecialValues.specialValues + + shrink = genericShrink + instance Arbitrary Directory where arbitrary = lift1 Directory @@ -169,7 +189,10 @@ instance (Arbitrary s, Arbitrary a) => Arbitrary (Expr s a) where arbitrary = Test.QuickCheck.suchThat - (Generic.Random.genericArbitraryRecG customGens weights) + (Generic.Random.withBaseCase + (Generic.Random.genericArbitraryRecG customGens weights) + (Var <$> arbitrary) + ) standardizedExpression where customGens @@ -248,6 +271,7 @@ % (7 :: W "Combine") % (1 :: W "CombineTypes") % (7 :: W "Prefer") + % (7 :: W "RecordCompletion") % (1 :: W "Merge") % (1 :: W "ToMap") % (7 :: W "Field") @@ -396,6 +420,48 @@ Right importlessExpression -> isRight (Dhall.TypeCheck.typeOf importlessExpression) Left _ -> False +inferredTypesAreNormalized :: Expr () Import -> Property +inferredTypesAreNormalized expression = + Test.Tasty.QuickCheck.counterexample report (all Dhall.Core.isNormalized result) + where + report = "Got: " ++ show result + ++ "\nExpected: " ++ show (fmap Dhall.Core.normalize result + :: Either (TypeError () Import) (Expr () Import)) + + result = Dhall.TypeCheck.typeWithA filterOutEmbeds Dhall.Context.empty expression + + filterOutEmbeds :: Typer a + filterOutEmbeds _ = Const Sort -- This could be any ill-typed expression. + +normalizingAnExpressionDoesntChangeItsInferredType :: Expr () Import -> Property +normalizingAnExpressionDoesntChangeItsInferredType expression = + case (eT0, eT1) of + (Right t0, Right t1) -> t0 === t1 + _ -> Test.QuickCheck.discard + where + eT0 = typeCheck expression + eT1 = typeCheck (Dhall.Core.normalize expression) + + typeCheck = Dhall.TypeCheck.typeWithA filterOutEmbeds Dhall.Context.empty + + filterOutEmbeds :: Typer a + filterOutEmbeds _ = Const Sort -- This could be any ill-typed expression. + +embedThenExtractIsIdentity + :: forall a. (ToDhall a, FromDhall a, Eq a, Typeable a, Arbitrary a, Show a) + => Proxy a + -> (String, Property, QuickCheckTests) +embedThenExtractIsIdentity p = + ( "Embedding then extracting is identity for " ++ show (typeRep p) + , Test.QuickCheck.property (prop :: a -> Bool) + , QuickCheckTests 1000 + ) + where + prop a = case extract auto (embed inject a) of + Success a' -> a == a' + Failure _ -> False + + tests :: TestTree tests = testProperties' @@ -420,7 +486,27 @@ , Test.QuickCheck.property isSameAsSelf , QuickCheckTests 10000 ) + , ( "Inferred types should be normalized" + , Test.QuickCheck.property inferredTypesAreNormalized + , QuickCheckTests 10000 + ) + , ( "Normalizing an expression doesn't change its inferred type" + , Test.QuickCheck.property normalizingAnExpressionDoesntChangeItsInferredType + , QuickCheckTests 10000 + ) + , embedThenExtractIsIdentity (Proxy :: Proxy (Text.Text)) + , embedThenExtractIsIdentity (Proxy :: Proxy [Nat.Natural]) + , embedThenExtractIsIdentity (Proxy :: Proxy (Bool, Double)) + , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Sequence.Seq ())) + , embedThenExtractIsIdentity (Proxy :: Proxy (Maybe Integer)) + , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Set.Set Nat.Natural)) + , embedThenExtractIsIdentity (Proxy :: Proxy (Data.HashSet.HashSet Text.Text)) + , embedThenExtractIsIdentity (Proxy :: Proxy (Vector Double)) + , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Map.Map Double Bool)) + , embedThenExtractIsIdentity (Proxy :: Proxy (HashMap.HashMap Double Bool)) ] + + testProperties' :: String -> [(String, Property, QuickCheckTests)] -> TestTree testProperties' name = Test.Tasty.testGroup name . map f 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 @@ -22,9 +22,10 @@ import qualified Test.Tasty import qualified Test.Tasty.HUnit +import Data.Void (Void) import Dhall.Import (Imported, MissingImports(..)) import Dhall.Parser (Src, SourcedException(..)) -import Dhall.TypeCheck (TypeError, X) +import Dhall.TypeCheck (TypeError) import Test.Tasty (TestTree) import Test.Tasty.HUnit ((@?=)) @@ -40,6 +41,7 @@ , issue253 , issue1131a , issue1131b + , issue1341 , parsing0 , typeChecking0 , typeChecking1 @@ -49,7 +51,7 @@ ] data Foo = Foo Integer Bool | Bar Bool Bool Bool | Baz Integer Integer - deriving (Show, Dhall.Generic, Dhall.Interpret, Dhall.Inject) + deriving (Show, Dhall.Generic, Dhall.FromDhall, Dhall.ToDhall) unnamedFields :: TestTree unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do @@ -68,7 +70,7 @@ ) let inj = Dhall.inject :: Dhall.InputType Foo - Test.Tasty.HUnit.assertEqual "Good Inject" (Dhall.declared inj) (Dhall.expected ty) + Test.Tasty.HUnit.assertEqual "Good ToDhall" (Dhall.declared inj) (Dhall.expected ty) let tu_ty = Dhall.auto :: Dhall.Type (Integer, Bool) Test.Tasty.HUnit.assertEqual "Auto Tuple" (Dhall.expected tu_ty) (Dhall.Core.Record ( @@ -95,7 +97,7 @@ let shouldNotTypeCheck text = do let handler :: SourcedException MissingImports -> IO Bool handler (SourcedException _ (MissingImports [e])) = - case Control.Exception.fromException e :: Maybe (Imported (TypeError Src X)) of + case Control.Exception.fromException e :: Maybe (Imported (TypeError Src Void)) of Just _ -> return True Nothing -> return False handler _ = do @@ -170,6 +172,13 @@ issue1131b :: TestTree issue1131b = Test.Tasty.HUnit.testCase "Issue #1131 b" (Util.assertDoesntTypeCheck "toMap {=} : List {mapKey : Text, mapValue : 0}") + +issue1341 :: TestTree +issue1341 = Test.Tasty.HUnit.testCase "Issue #1341" (do + let nan = Dhall.Core.DoubleLit (Dhall.Core.DhallDouble (0/0)) :: Dhall.Core.Expr () () + 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) parsing0 :: TestTree parsing0 = Test.Tasty.HUnit.testCase "Parsing regression #0" (do diff --git a/tests/Dhall/Test/Tags.hs b/tests/Dhall/Test/Tags.hs new file mode 100644 --- /dev/null +++ b/tests/Dhall/Test/Tags.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Test.Tags where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import Dhall.Util (Input(..)) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath) + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Tags as Tags +import qualified Dhall.Test.Util as Test.Util +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle + +tagsDirectory :: FilePath +tagsDirectory = "./tests/tags" + +getTests :: IO TestTree +getTests = do + tagsTests <- Test.Util.discover (Turtle.chars <* ".dhall") tagsTest (Turtle.lstree tagsDirectory) + + let testTree = Tasty.testGroup "tags tests" [ tagsTests, tagsDirTest ] + + return testTree + +tagsTest :: Text -> TestTree +tagsTest prefix = + Tasty.HUnit.testCase (Text.unpack prefix) $ do + let inputFile = Text.unpack (prefix <> ".dhall") + let outputFile = Text.unpack (prefix <> ".tags") + + actualTags <- fixPathSeparators <$> Tags.generate (InputFile inputFile) Nothing False + + expectedTags <- Text.IO.readFile outputFile + + let message = "The actual tags did not match the expected tags" + + Tasty.HUnit.assertEqual message expectedTags actualTags + +tagsDirTest :: TestTree +tagsDirTest = + Tasty.HUnit.testCase "all" $ do + let outputFile = Text.unpack . Turtle.format Turtle.fp $ tagsDirectory Turtle. "all.tags" + + actualTags <- fmap fixPathSeparators + (Tags.generate + (InputFile (Text.unpack . Turtle.format Turtle.fp $ tagsDirectory)) + (Just [".dhall"]) + False) + + expectedTags <- Text.IO.readFile outputFile + + let message = "The actual tags did not match the expected tags for directory test" + + Tasty.HUnit.assertEqual message expectedTags actualTags + +fixPathSeparators :: Text -> Text +fixPathSeparators = Text.replace "\\" "/" diff --git a/tests/Dhall/Test/Tutorial.hs b/tests/Dhall/Test/Tutorial.hs --- a/tests/Dhall/Test/Tutorial.hs +++ b/tests/Dhall/Test/Tutorial.hs @@ -12,7 +12,7 @@ import Data.Monoid ((<>)) import Data.Text (Text) -import Dhall (Inject) +import Dhall (ToDhall) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Test.Tasty (TestTree) @@ -69,7 +69,7 @@ makeBools True False @?= False ) data Example0 = Example0 { foo :: Bool, bar :: Bool } - deriving (Generic, Inject) + deriving (Generic, ToDhall) _Functions_2 :: TestTree _Functions_2 = Test.Tasty.HUnit.testCase "Example #2" (do diff --git a/tests/Dhall/Test/TypeInference.hs b/tests/Dhall/Test/TypeInference.hs --- a/tests/Dhall/Test/TypeInference.hs +++ b/tests/Dhall/Test/TypeInference.hs @@ -44,14 +44,9 @@ successTest :: Text -> TestTree successTest prefix = do - let skip = [ -- We correctly infer the expected type @NaN ≡ NaN@ here, - -- but the comparison between the inferred and the expected type - -- fails due to `Expr`'s 'Eq' instance, which inherits the - -- @NaN /= NaN@ inequality from 'Double'. - typeInferenceDirectory "success/unit/AssertNaN" - ] + let expectedFailures = [] - Test.Util.testCase prefix skip $ do + Test.Util.testCase prefix expectedFailures $ do let prefixFP = Text.unpack prefix actualCode <- Text.IO.readFile (prefixFP <> "A.dhall") @@ -85,17 +80,18 @@ failureTest :: Text -> TestTree failureTest prefix = do - let skip = [ typeInferenceDirectory "failure/unit/MergeEmptyNeedsDirectAnnotation1" + let expectedFailures = [ typeInferenceDirectory "failure/unit/MergeEmptyNeedsDirectAnnotation1" -- Duplicate fields are incorrectly caught during parsing: -- https://github.com/dhall-lang/dhall-haskell/issues/772 , typeInferenceDirectory "failure/unit/RecordLitDuplicateFields" + , typeInferenceDirectory "failure/unit/RecordProjectionDuplicateFields" , typeInferenceDirectory "failure/unit/RecordTypeDuplicateFields" , typeInferenceDirectory "failure/unit/UnionTypeDuplicateVariants1" , typeInferenceDirectory "failure/unit/UnionTypeDuplicateVariants2" ] - Test.Util.testCase prefix skip $ do + Test.Util.testCase prefix expectedFailures $ do let prefixFP = Text.unpack prefix code <- Text.IO.readFile (prefixFP <> ".dhall") @@ -104,16 +100,8 @@ Left _ -> Tasty.HUnit.assertFailure (prefixFP <> " should have parsed") Right e -> return e - tryResolvedExpr <- - Exception.try - (Test.Util.loadRelativeTo - (FilePath.takeDirectory prefixFP) - Import.IgnoreSemanticCache - expression) - - case tryResolvedExpr of - Left (SomeException _) -> return () + resolved <- Import.assertNoImports expression - Right resolved -> case TypeCheck.typeOf resolved of - Left _ -> return () - Right _ -> Tasty.HUnit.assertFailure (prefixFP <> " should not have type-checked") + case TypeCheck.typeOf resolved of + Left _ -> return () + Right _ -> Tasty.HUnit.assertFailure (prefixFP <> " should not have type-checked") diff --git a/tests/Dhall/Test/Util.hs b/tests/Dhall/Test/Util.hs --- a/tests/Dhall/Test/Util.hs +++ b/tests/Dhall/Test/Util.hs @@ -24,12 +24,12 @@ import Control.Monad.Trans.State.Strict (StateT) import Data.Bifunctor (first) import Data.Text (Text) +import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core (Expr, Normalizer, ReifiedNormalizer(..), Import) import Dhall.Import (Status(..), SemanticCacheMode(..)) import Data.Monoid((<>)) import Dhall.Parser (Src) -import Dhall.TypeCheck (X) import Prelude hiding (FilePath) import Test.Tasty.HUnit import Test.Tasty (TestTree) @@ -60,17 +60,17 @@ import qualified Data.Text.IO #endif -normalize' :: Expr Src X -> Text +normalize' :: Expr Src Void -> Text normalize' = Dhall.Core.pretty . Dhall.Core.normalize -normalizeWith' :: Normalizer X -> Expr Src X -> Text +normalizeWith' :: Normalizer Void -> Expr Src Void -> Text normalizeWith' ctx t = Dhall.Core.pretty (Dhall.Core.normalizeWith (Just (ReifiedNormalizer ctx)) t) -code :: Text -> IO (Expr Src X) +code :: Text -> IO (Expr Src Void) code = codeWith Dhall.Context.empty -codeWith :: Context (Expr Src X) -> Text -> IO (Expr Src X) +codeWith :: Context (Expr Src Void) -> Text -> IO (Expr Src Void) codeWith ctx expr = do expr0 <- case Dhall.Parser.exprFromText mempty expr of Left parseError -> Control.Exception.throwIO parseError @@ -81,21 +81,21 @@ Right _ -> return () return expr1 -load :: Expr Src Import -> IO (Expr Src X) +load :: Expr Src Import -> IO (Expr Src Void) load = loadRelativeTo "." UseSemanticCache -loadRelativeTo :: FilePath.FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src X) +loadRelativeTo :: FilePath.FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) loadRelativeTo rootDirectory semanticCacheMode expression = State.evalStateT (loadWith expression) (Dhall.Import.emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode } #ifdef WITH_HTTP -loadWith :: Expr Src Import -> StateT Status IO (Expr Src X) +loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith = Dhall.Import.loadWith #else -loadWith :: Expr Src Import -> StateT Status IO (Expr Src X) +loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith expr = do let mockRemote' url = do liftIO . putStrLn $ "\nTesting without real HTTP support --" @@ -155,23 +155,23 @@ equivalent :: Text -> Text -> IO () equivalent text0 text1 = do - expr0 <- fmap Dhall.Core.normalize (code text0) :: IO (Expr X X) - expr1 <- fmap Dhall.Core.normalize (code text1) :: IO (Expr X X) + expr0 <- fmap Dhall.Core.normalize (code text0) :: IO (Expr Void Void) + expr1 <- fmap Dhall.Core.normalize (code text1) :: IO (Expr Void Void) assertEqual "Expressions are not equivalent" expr0 expr1 -assertNormalizesTo :: Expr Src X -> Text -> IO () +assertNormalizesTo :: Expr Src Void -> Text -> IO () assertNormalizesTo e expected = do assertBool msg (not $ Dhall.Core.isNormalized e) normalize' e @?= expected where msg = "Given expression is already in normal form" -assertNormalizesToWith :: Normalizer X -> Expr Src X -> Text -> IO () +assertNormalizesToWith :: Normalizer Void -> Expr Src Void -> Text -> IO () assertNormalizesToWith ctx e expected = do assertBool msg (not $ Dhall.Core.isNormalizedWith ctx (first (const ()) e)) normalizeWith' ctx e @?= expected where msg = "Given expression is already in normal form" -assertNormalized :: Expr Src X -> IO () +assertNormalized :: Expr Src Void -> IO () assertNormalized e = do assertBool msg1 (Dhall.Core.isNormalized e) assertEqual msg2 (normalize' e) (Dhall.Core.pretty e) @@ -210,8 +210,8 @@ return (Tasty.testGroup "discover" tests) testCase :: Text -> [ FilePath ] -> Assertion -> TestTree -testCase prefix skip assertion = - if prefix `elem` map (Turtle.format fp) skip +testCase prefix expectedFailures assertion = + if prefix `elem` map (Turtle.format fp) expectedFailures then Tasty.ExpectedFailure.expectFail test else test where diff --git a/tests/format/applicationMultilineA.dhall b/tests/format/applicationMultilineA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/applicationMultilineA.dhall @@ -0,0 +1,30 @@ +{ app = + ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + aaaaaaaaaaaaaaaaa +, app2 = + f + a + b + cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +, app3 = + f + a + b + c + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd +, some = + Some + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, merge = + merge + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb +, merge3 = + merge + a + b + ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +, toMap = + toMap + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +} diff --git a/tests/format/applicationMultilineB.dhall b/tests/format/applicationMultilineB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/applicationMultilineB.dhall @@ -0,0 +1,30 @@ +{ app = + ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + aaaaaaaaaaaaaaaaa +, app2 = + f + a + b + cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +, app3 = + f + a + b + c + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd +, some = + Some + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, merge = + merge + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb +, merge3 = + merge + a + b + ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +, toMap = + toMap + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +} diff --git a/tests/format/asciiB.dhall b/tests/format/asciiB.dhall --- a/tests/format/asciiB.dhall +++ b/tests/format/asciiB.dhall diff --git a/tests/format/concatSepA.dhall b/tests/format/concatSepA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/concatSepA.dhall @@ -0,0 +1,30 @@ +{- +Concatenate a `List` of `Text` values with a separator in between each value +-} +let Status = < Empty | NonEmpty : Text > + +let concatSep + : ∀(separator : Text) → ∀(elements : List Text) → Text + = λ(separator : Text) + → λ(elements : List Text) + → let status = + List/fold Text elements Status + ( λ(element : Text) + → λ(status : Status) + → merge + { Empty = Status.NonEmpty element + , NonEmpty = + λ(result : Text) + → Status.NonEmpty (element ++ separator ++ result) + } + status + ) + Status.Empty + + in merge { Empty = "", NonEmpty = λ(result : Text) → result } status + +let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI" + +let example1 = assert : concatSep ", " ([] : List Text) ≡ "" + +in concatSep diff --git a/tests/format/concatSepB.dhall b/tests/format/concatSepB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/concatSepB.dhall @@ -0,0 +1,33 @@ +{- +Concatenate a `List` of `Text` values with a separator in between each value +-} +let Status = < Empty | NonEmpty : Text > + +let concatSep + : ∀(separator : Text) → ∀(elements : List Text) → Text + = λ(separator : Text) + → λ(elements : List Text) + → let status = + List/fold + Text + elements + Status + ( λ(element : Text) + → λ(status : Status) + → merge + { Empty = Status.NonEmpty element + , NonEmpty = + λ(result : Text) + → Status.NonEmpty (element ++ separator ++ result) + } + status + ) + Status.Empty + + in merge { Empty = "", NonEmpty = λ(result : Text) → result } status + +let example0 = assert : concatSep ", " [ "ABC", "DEF", "GHI" ] ≡ "ABC, DEF, GHI" + +let example1 = assert : concatSep ", " ([] : List Text) ≡ "" + +in concatSep diff --git a/tests/format/doubleRoundB.dhall b/tests/format/doubleRoundB.dhall --- a/tests/format/doubleRoundB.dhall +++ b/tests/format/doubleRoundB.dhall diff --git a/tests/format/emptyRecordB.dhall b/tests/format/emptyRecordB.dhall --- a/tests/format/emptyRecordB.dhall +++ b/tests/format/emptyRecordB.dhall diff --git a/tests/format/escapeNumericLabelB.dhall b/tests/format/escapeNumericLabelB.dhall --- a/tests/format/escapeNumericLabelB.dhall +++ b/tests/format/escapeNumericLabelB.dhall diff --git a/tests/format/escapeSingleQuotedOpenInterpolationB.dhall b/tests/format/escapeSingleQuotedOpenInterpolationB.dhall --- a/tests/format/escapeSingleQuotedOpenInterpolationB.dhall +++ b/tests/format/escapeSingleQuotedOpenInterpolationB.dhall diff --git a/tests/format/fieldOrderB.dhall b/tests/format/fieldOrderB.dhall --- a/tests/format/fieldOrderB.dhall +++ b/tests/format/fieldOrderB.dhall diff --git a/tests/format/functionLikeA.dhall b/tests/format/functionLikeA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/functionLikeA.dhall @@ -0,0 +1,6 @@ +{ example0 = merge a b + merge a b +, example1 = (merge a b : T) + (merge a b : T) +, example2 = toMap a + toMap a +, example3 = (toMap a b : T) + (toMap a b : T) +, example4 = Some a + Some a +} diff --git a/tests/format/functionLikeB.dhall b/tests/format/functionLikeB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/functionLikeB.dhall @@ -0,0 +1,6 @@ +{ example0 = merge a b + merge a b +, example1 = (merge a b : T) + (merge a b : T) +, example2 = toMap a + toMap a +, example3 = (toMap a b : T) + (toMap a b : T) +, example4 = Some a + Some a +} diff --git a/tests/format/headerB.dhall b/tests/format/headerB.dhall --- a/tests/format/headerB.dhall +++ b/tests/format/headerB.dhall diff --git a/tests/format/ifThenElseB.dhall b/tests/format/ifThenElseB.dhall --- a/tests/format/ifThenElseB.dhall +++ b/tests/format/ifThenElseB.dhall diff --git a/tests/format/importAccessB.dhall b/tests/format/importAccessB.dhall --- a/tests/format/importAccessB.dhall +++ b/tests/format/importAccessB.dhall diff --git a/tests/format/importLines2A.dhall b/tests/format/importLines2A.dhall --- a/tests/format/importLines2A.dhall +++ b/tests/format/importLines2A.dhall diff --git a/tests/format/importLines2B.dhall b/tests/format/importLines2B.dhall --- a/tests/format/importLines2B.dhall +++ b/tests/format/importLines2B.dhall diff --git a/tests/format/importLinesB.dhall b/tests/format/importLinesB.dhall --- a/tests/format/importLinesB.dhall +++ b/tests/format/importLinesB.dhall diff --git a/tests/format/importSuffixB.dhall b/tests/format/importSuffixB.dhall --- a/tests/format/importSuffixB.dhall +++ b/tests/format/importSuffixB.dhall diff --git a/tests/format/innerMultilineB.dhall b/tests/format/innerMultilineB.dhall --- a/tests/format/innerMultilineB.dhall +++ b/tests/format/innerMultilineB.dhall diff --git a/tests/format/issue1301B.dhall b/tests/format/issue1301B.dhall --- a/tests/format/issue1301B.dhall +++ b/tests/format/issue1301B.dhall diff --git a/tests/format/issue1413A.dhall b/tests/format/issue1413A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1413A.dhall @@ -0,0 +1,6 @@ +let foo = + + {- test -} + "hello" + +in foo diff --git a/tests/format/issue1413B.dhall b/tests/format/issue1413B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1413B.dhall @@ -0,0 +1,6 @@ +let foo = + + {- test -} + "hello" + +in foo diff --git a/tests/format/largeExponentB.dhall b/tests/format/largeExponentB.dhall --- a/tests/format/largeExponentB.dhall +++ b/tests/format/largeExponentB.dhall diff --git a/tests/format/largeRecordB.dhall b/tests/format/largeRecordB.dhall --- a/tests/format/largeRecordB.dhall +++ b/tests/format/largeRecordB.dhall @@ -34,15 +34,15 @@ , dark_room = Some False , disclose = Some - ( defaults.Disclose - ⫽ { inventory = Some { prompt = True, default = True } - , attributes = Some { prompt = True, default = False } - , monsters_killed = Some { prompt = False, default = True } - , monsters_genocided = Some { prompt = False, default = False } - , conduct = Some { prompt = False, default = False } - , dungeon_overview = Some { prompt = False, default = False } - } - ) + ( defaults.Disclose + ⫽ { inventory = Some { prompt = True, default = True } + , attributes = Some { prompt = True, default = False } + , monsters_killed = Some { prompt = False, default = True } + , monsters_genocided = Some { prompt = False, default = False } + , conduct = Some { prompt = False, default = False } + , dungeon_overview = Some { prompt = False, default = False } + } + ) , dogname = Some "Cujo" , extmenu = Some False , fixinv = Some True diff --git a/tests/format/letB.dhall b/tests/format/letB.dhall --- a/tests/format/letB.dhall +++ b/tests/format/letB.dhall diff --git a/tests/format/letCommentsB.dhall b/tests/format/letCommentsB.dhall --- a/tests/format/letCommentsB.dhall +++ b/tests/format/letCommentsB.dhall diff --git a/tests/format/letLineCommentsAfterVariableA.dhall b/tests/format/letLineCommentsAfterVariableA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/letLineCommentsAfterVariableA.dhall @@ -0,0 +1,10 @@ +let x -- xxxxxxxxxx xxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx + : Natural + = 0 + +let y -- yyyyyyyyyy yyyyyyyyyyyyyyyyy yyyyyyyyyyyyyyyyy + -- yyyyyyyyyyyyyy yyyyyyyyyyyyyyyyyyyyyyy + : Natural + = 1 + +in x + y diff --git a/tests/format/letLineCommentsAfterVariableB.dhall b/tests/format/letLineCommentsAfterVariableB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/letLineCommentsAfterVariableB.dhall @@ -0,0 +1,12 @@ +let x + -- xxxxxxxxxx xxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxx + : Natural + = 0 + +let y + -- yyyyyyyyyy yyyyyyyyyyyyyyyyy yyyyyyyyyyyyyyyyy + -- yyyyyyyyyyyyyy yyyyyyyyyyyyyyyyyyyyyyy + : Natural + = 1 + +in x + y diff --git a/tests/format/letLongCommentsB.dhall b/tests/format/letLongCommentsB.dhall --- a/tests/format/letLongCommentsB.dhall +++ b/tests/format/letLongCommentsB.dhall diff --git a/tests/format/letNewlineCommentsB.dhall b/tests/format/letNewlineCommentsB.dhall --- a/tests/format/letNewlineCommentsB.dhall +++ b/tests/format/letNewlineCommentsB.dhall diff --git a/tests/format/letShortCommentsB.dhall b/tests/format/letShortCommentsB.dhall --- a/tests/format/letShortCommentsB.dhall +++ b/tests/format/letShortCommentsB.dhall @@ -1,1 +1,7 @@ -let x = True let {- 0 -} y {- 1 -} : {- 2 -} Bool = {- 3-} False in x +let x = True + +let {- 0 -} y + {- 1 -} : {- 2 -} Bool + = {- 3-} False + +in x diff --git a/tests/format/multilineB.dhall b/tests/format/multilineB.dhall --- a/tests/format/multilineB.dhall +++ b/tests/format/multilineB.dhall diff --git a/tests/format/parentB.dhall b/tests/format/parentB.dhall --- a/tests/format/parentB.dhall +++ b/tests/format/parentB.dhall diff --git a/tests/format/projectionOrderB.dhall b/tests/format/projectionOrderB.dhall --- a/tests/format/projectionOrderB.dhall +++ b/tests/format/projectionOrderB.dhall diff --git a/tests/format/recordCompletionA.dhall b/tests/format/recordCompletionA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/recordCompletionA.dhall @@ -0,0 +1,25 @@ +{ field0 = +T::{ +, a = 1 +, b = 1 +, c = 1 +, d = 1 +, e = 1 +, f = 1 +, g = 1 +, h = 1 +, i = 1 +, j = 1 +, k = 1 +, l = 1 +, m = 1 +, n = 1 +, o = 1 +, p = 1 +, q = 1 +, r = 1 +, s = 1 +, t = 1 +} +, field1 = T::{ a = 1 } +} diff --git a/tests/format/recordCompletionB.dhall b/tests/format/recordCompletionB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/recordCompletionB.dhall @@ -0,0 +1,25 @@ +{ field0 = + T::{ + , a = 1 + , b = 1 + , c = 1 + , d = 1 + , e = 1 + , f = 1 + , g = 1 + , h = 1 + , i = 1 + , j = 1 + , k = 1 + , l = 1 + , m = 1 + , n = 1 + , o = 1 + , p = 1 + , q = 1 + , r = 1 + , s = 1 + , t = 1 + } +, field1 = T::{ a = 1 } +} diff --git a/tests/format/sha256PrintingB.dhall b/tests/format/sha256PrintingB.dhall --- a/tests/format/sha256PrintingB.dhall +++ b/tests/format/sha256PrintingB.dhall diff --git a/tests/format/unicodeB.dhall b/tests/format/unicodeB.dhall --- a/tests/format/unicodeB.dhall +++ b/tests/format/unicodeB.dhall diff --git a/tests/format/urlsB.dhall b/tests/format/urlsB.dhall --- a/tests/format/urlsB.dhall +++ b/tests/format/urlsB.dhall diff --git a/tests/lint/success/fixAssertA.dhall b/tests/lint/success/fixAssertA.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/fixAssertA.dhall @@ -0,0 +1,1 @@ +let example = 1 ≡ 1 in 1 diff --git a/tests/lint/success/fixAssertB.dhall b/tests/lint/success/fixAssertB.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/fixAssertB.dhall @@ -0,0 +1,1 @@ +let example = assert : 1 ≡ 1 in 1 diff --git a/tests/tags/all.tags b/tests/tags/all.tags new file mode 100644 --- /dev/null +++ b/tests/tags/all.tags @@ -0,0 +1,61 @@ + +./tests/tags/let.dhall,66 +let.dhall1,1 +/let.dhall1,1 +let foo foo1,5 +let bar bar3,22 + +./tests/tags/nonunicode.dhall,63 +nonunicode.dhall1,1 +/nonunicode.dhall1,1 +let foo foo2,12 + +./tests/tags/record.dhall,335 +record.dhall1,1 +/record.dhall1,1 +let Config Config6,81 + { home home8,161 + , privateKey privateKey9,181 + , publicKey publicKey10,207 + , name name11,232 + , name : { firstName firstName11,241 + , secondName secondName12,275 +let makeUser makeUser16,323 +let configs configs30,804 + +./tests/tags/recordlit.dhall,223 +recordlit.dhall1,1 +/recordlit.dhall1,1 +{ home home8,143 +, privateKey privateKey9,171 +, publicKey publicKey10,215 +, name name11,263 +, name = { firstName firstName11,272 + , secondName secondName12,302 + +./tests/tags/simple.dhall,254 +simple.dhall1,1 +/simple.dhall1,1 +let generate generate6,100 +let makeUser makeUser17,409 +let buildUser buildUser26,680 +let Config Config32,880 + { home home33,897 + , privateKey privateKey34,917 + , publicKey publicKey35,943 + +./tests/tags/unicode.dhall,57 +unicode.dhall1,1 +/unicode.dhall1,1 +let foo foo2,15 + +./tests/tags/union.dhall,394 +union.dhall1,1 +/union.dhall1,1 +let Element Element1,5 +let Element = < Left Left1,17 +let Element = < Left : Natural | Right Right1,34 +let Element = < Left : Natural | Right : Bool | Middle Middle1,49 +let Element = < Left : Natural | Right : Bool | Middle : < Top Top1,60 +let Element = < Left : Natural | Right : Bool | Middle : < Top : Text | Bottom Bottom1,73 +let foo foo3,95 diff --git a/tests/tags/let.dhall b/tests/tags/let.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/let.dhall @@ -0,0 +1,4 @@ +let foo = "foo" + +let bar = foo +in bar diff --git a/tests/tags/let.tags b/tests/tags/let.tags new file mode 100644 --- /dev/null +++ b/tests/tags/let.tags @@ -0,0 +1,6 @@ + +./tests/tags/let.dhall,66 +let.dhall1,1 +/let.dhall1,1 +let foo foo1,5 +let bar bar3,22 diff --git a/tests/tags/nonunicode.dhall b/tests/tags/nonunicode.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/nonunicode.dhall @@ -0,0 +1,3 @@ +-- abc +let foo = "bar" +in foo diff --git a/tests/tags/nonunicode.tags b/tests/tags/nonunicode.tags new file mode 100644 --- /dev/null +++ b/tests/tags/nonunicode.tags @@ -0,0 +1,5 @@ + +./tests/tags/nonunicode.dhall,63 +nonunicode.dhall1,1 +/nonunicode.dhall1,1 +let foo foo2,12 diff --git a/tests/tags/record.dhall b/tests/tags/record.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/record.dhall @@ -0,0 +1,35 @@ +{- You can optionally add types + + `x : T` means that `x` has type `T` +-} + +let Config : Type = + {- What happens if you add another field here? -} + { home : Text + , privateKey : Text + , publicKey : Text + , name : { firstName : Text + , secondName : Text + } + } + +let makeUser : Text -> Config = \(user : Text) -> + let home : Text = "/home/${user}" + let privateKey : Text = "${home}/.ssh/id_ed25519" + let publicKey : Text = "${privateKey}.pub" + let config : Config = + { home = home + , privateKey = privateKey + , publicKey = publicKey + , name = { firstName = user + , secondName = "" + } + } + in config + +let configs : List Config = + [ makeUser "bill" + , makeUser "jane" + ] + +in configs diff --git a/tests/tags/record.tags b/tests/tags/record.tags new file mode 100644 --- /dev/null +++ b/tests/tags/record.tags @@ -0,0 +1,13 @@ + +./tests/tags/record.dhall,335 +record.dhall1,1 +/record.dhall1,1 +let Config Config6,81 + { home home8,161 + , privateKey privateKey9,181 + , publicKey publicKey10,207 + , name name11,232 + , name : { firstName firstName11,241 + , secondName secondName12,275 +let makeUser makeUser16,323 +let configs configs30,804 diff --git a/tests/tags/recordlit.dhall b/tests/tags/recordlit.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/recordlit.dhall @@ -0,0 +1,14 @@ +{- This is an example Dhall configuration file + + Can you spot the mistake? + + Fix the typo, then move onto the "Definitions" example +-} + +{ home = "/home/bill" +, privateKey = "/home/bill/.ssh/id_ed25519" +, publicKey = "/home/blil/.ssh/id_ed25519.pub" +, name = { firstName = "Bill" + , secondName = "Bar" + } +} diff --git a/tests/tags/recordlit.tags b/tests/tags/recordlit.tags new file mode 100644 --- /dev/null +++ b/tests/tags/recordlit.tags @@ -0,0 +1,10 @@ + +./tests/tags/recordlit.dhall,223 +recordlit.dhall1,1 +/recordlit.dhall1,1 +{ home home8,143 +, privateKey privateKey9,171 +, publicKey publicKey10,215 +, name name11,263 +, name = { firstName firstName11,272 + , secondName secondName12,302 diff --git a/tests/tags/simple.dhall b/tests/tags/simple.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/simple.dhall @@ -0,0 +1,39 @@ +{- Need to generate a lot of users? + + Use the `generate` function from the Dhall Prelude +-} + +let generate = https://prelude.dhall-lang.org/List/generate + +{- You can import Dhall expressions from URLs that support + CORS + + The command-line tools also let you import from files, + environment variables, and URLs without CORS support. + + Browse https://prelude.dhall-lang.org for more utilities +-} + +let makeUser = \(user : Text) -> + let home = "/home/${user}" + let privateKey = "${home}/.ssh/id_ed25519" + let publicKey = "${privateKey}.pub" + in { home = home + , privateKey = privateKey + , publicKey = publicKey + } + +let buildUser = \(index : Natural) -> + {- `Natural/show` is a "built-in", meaning that + you can use `Natural/show` without an import + -} + makeUser "build${Natural/show index}" + +let Config = + { home : Text + , privateKey : Text + , publicKey : Text + } + +in {- Try generating 20 users instead of 10 -} + generate 10 Config buildUser diff --git a/tests/tags/simple.tags b/tests/tags/simple.tags new file mode 100644 --- /dev/null +++ b/tests/tags/simple.tags @@ -0,0 +1,11 @@ + +./tests/tags/simple.dhall,254 +simple.dhall1,1 +/simple.dhall1,1 +let generate generate6,100 +let makeUser makeUser17,409 +let buildUser buildUser26,680 +let Config Config32,880 + { home home33,897 + , privateKey privateKey34,917 + , publicKey publicKey35,943 diff --git a/tests/tags/unicode.dhall b/tests/tags/unicode.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/unicode.dhall @@ -0,0 +1,3 @@ +-- αβξ +let foo = "bar" +in foo diff --git a/tests/tags/unicode.tags b/tests/tags/unicode.tags new file mode 100644 --- /dev/null +++ b/tests/tags/unicode.tags @@ -0,0 +1,5 @@ + +./tests/tags/unicode.dhall,57 +unicode.dhall1,1 +/unicode.dhall1,1 +let foo foo2,15 diff --git a/tests/tags/union.dhall b/tests/tags/union.dhall new file mode 100644 --- /dev/null +++ b/tests/tags/union.dhall @@ -0,0 +1,4 @@ +let Element = < Left : Natural | Right : Bool | Middle : < Top : Text | Bottom : Bool> > + +let foo = Element.Left 6 +in foo diff --git a/tests/tags/union.tags b/tests/tags/union.tags new file mode 100644 --- /dev/null +++ b/tests/tags/union.tags @@ -0,0 +1,11 @@ + +./tests/tags/union.dhall,394 +union.dhall1,1 +/union.dhall1,1 +let Element Element1,5 +let Element = < Left Left1,17 +let Element = < Left : Natural | Right Right1,34 +let Element = < Left : Natural | Right : Bool | Middle Middle1,49 +let Element = < Left : Natural | Right : Bool | Middle : < Top Top1,60 +let Element = < Left : Natural | Right : Bool | Middle : < Top : Text | Bottom Bottom1,73 +let foo foo3,95