diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,83 @@ +1.18.0 + +* Supports version 3.0.0 of the language standard: + * See: https://github.com/dhall-lang/dhall-lang/releases/tag/v3.0.0 +* BREAKING CHANGE TO THE LANGUAGE AND API: New `Some`/`None` constructors for + `Optional` values + * Example: `[ Some 1, None Natural ]` + * This is a breaking change to the language because `Some` and `None` are + now reserved keywords + * This is a breaking change to the API because `Some` and `None` are new + constructors for the `Expr` type +* BREAKING CHANGE TO THE LANGUAGE AND API: Support for kind polymorphism + * This adds a new `Sort` constant above `Kind` in the hierarchy + * i.e. `Type : Kind : Sort` + * This is a breaking change to the language because `Sort` is now a + reserved keyword + * This is a breaking change to the API because `Sort` is a new + constructor for the `Expr` type +* BREAKING CHANGE TO THE API: New `Dhall.Map` module + * This replaces `InsOrdHashMap` in the API + * The primary motivation is to improve performance and to remove the + dependency on `insert-ordered-containers` +* BREAKING CHANGE TO THE API: Use standard version instead of protocol version + * The binary protocol is now versioned alongside the standard + * The `ProtocolVersion` type is renamed to `StandardVersion` and the + * `--protocol-version` option is renamed to `--standard-version` + * See: https://github.com/dhall-lang/dhall-haskell/pull/634 +* BUG FIX: Fix import chaining for custom header imports + * See: https://github.com/dhall-lang/dhall-haskell/pull/618 +* BUG FIX: Fix import chaining for imports protected by semantic integrity + checks + * See: https://github.com/dhall-lang/dhall-haskell/pull/584 +* BUG FIX: Record literals and types produced by `∧`/`⫽`/`⩓` are now sorted + * This ensures that β-normalization is idempotent + * See: https://github.com/dhall-lang/dhall-haskell/pull/572 +* BUG FIX: `dhall freeze` now correctly handles the starting file being + located outside the current working directory + * See: https://github.com/dhall-lang/dhall-haskell/commit/a22aa79d1957be9ecf166ea066e2a9a5b309e1ae +* BUG FIX: Fix parsing of IPv4-mapped IPv6 addresses + * See: https://github.com/dhall-lang/dhall-haskell/pull/632 +* FEATURE: New `--ascii` flag for ASCII output + * See: https://github.com/dhall-lang/dhall-haskell/pull/570 +* FEATURE: New `dhall encode` and `dhall decode` subcommands + * These allow you to transform Dhall source code to and from its binary + representation + * See: https://github.com/dhall-lang/dhall-haskell/pull/588 +* LARGE parsing performance improvements + * Parsing is about 10x-100x faster on most code + * See: https://github.com/dhall-lang/dhall-haskell/pull/591 + * See: https://github.com/dhall-lang/dhall-haskell/pull/592 + * See: https://github.com/dhall-lang/dhall-haskell/pull/597 + * See: https://github.com/dhall-lang/dhall-haskell/pull/601 + * See: https://github.com/dhall-lang/dhall-haskell/pull/602 + * See: https://github.com/dhall-lang/dhall-haskell/pull/604 + * See: https://github.com/dhall-lang/dhall-haskell/pull/606 +* Type-checking performance improvements: + * See: https://github.com/dhall-lang/dhall-haskell/pull/566 +* Normalization performance improvements: + * See: https://github.com/dhall-lang/dhall-haskell/pull/610 +* `dhall freeze` now caches the imports as it freezes them + * See: https://github.com/dhall-lang/dhall-haskell/pull/587 +* `dhall freeze` now refreezes imports with invalid semantic integrity checks + * See: https://github.com/dhall-lang/dhall-haskell/pull/637 +* `dhall freeze` now adds a trailing newline + * See: https://github.com/dhall-lang/dhall-haskell/pull/629 +* Build against `megaparsec-7.0.*` + * See: https://github.com/dhall-lang/dhall-haskell/pull/565 +* Support GHC 8.6 + * See: https://github.com/dhall-lang/dhall-haskell/pull/599 + * See: https://github.com/dhall-lang/dhall-haskell/pull/623 +* Support GHC all the way back to 7.10.3 + * See: https://github.com/dhall-lang/dhall-haskell/pull/595 + * See: https://github.com/dhall-lang/dhall-haskell/pull/621 +* Improvements to error messages: + * See: https://github.com/dhall-lang/dhall-haskell/pull/563 + * See: https://github.com/dhall-lang/dhall-haskell/pull/576 + * See: https://github.com/dhall-lang/dhall-haskell/pull/583 + * See: https://github.com/dhall-lang/dhall-haskell/pull/589 + + 1.17.0 * This release corresponds to version 2.0.0 of the language standard diff --git a/Prelude/Bool/and b/Prelude/Bool/and deleted file mode 100644 --- a/Prelude/Bool/and +++ /dev/null @@ -1,18 +0,0 @@ -{- -The `and` function returns `False` if there are any `False` elements in the -`List` and returns `True` otherwise - -Examples: - -``` -./and [ True, False, True ] = False - -./and ([] : List Bool) = True -``` --} - let and - : List Bool → Bool - = λ(xs : List Bool) - → List/fold Bool xs Bool (λ(l : Bool) → λ(r : Bool) → l && r) True - -in and diff --git a/Prelude/Bool/build b/Prelude/Bool/build deleted file mode 100644 --- a/Prelude/Bool/build +++ /dev/null @@ -1,17 +0,0 @@ -{- -`build` is the inverse of `fold` - -Examples: - -``` -./build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → true) = True - -./build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → false) = False -``` --} - let build - : (∀(bool : Type) → ∀(true : bool) → ∀(false : bool) → bool) → Bool - = λ(f : ∀(bool : Type) → ∀(true : bool) → ∀(false : bool) → bool) - → f Bool True False - -in build diff --git a/Prelude/Bool/even b/Prelude/Bool/even deleted file mode 100644 --- a/Prelude/Bool/even +++ /dev/null @@ -1,22 +0,0 @@ -{- -Returns `True` if there are an even number of `False` elements in the list and -returns `False` otherwise - -Examples: - -``` -./even [ False, True, False ] = True - -./even [ False, True ] = False - -./even [ False ] = False - -./even ([] : List Bool) = True -``` --} - let even - : List Bool → Bool - = λ(xs : List Bool) - → List/fold Bool xs Bool (λ(x : Bool) → λ(y : Bool) → x == y) True - -in even diff --git a/Prelude/Bool/fold b/Prelude/Bool/fold deleted file mode 100644 --- a/Prelude/Bool/fold +++ /dev/null @@ -1,20 +0,0 @@ -{- -`fold` is essentially the same as `if`/`then`/else` except as a function - -Examples: - -``` -./fold True Natural 0 1 = 0 - -./fold False Natural 0 1 = 1 -``` --} - let fold - : ∀(b : Bool) → ∀(bool : Type) → ∀(true : bool) → ∀(false : bool) → bool - = λ(b : Bool) - → λ(bool : Type) - → λ(true : bool) - → λ(false : bool) - → if b then true else false - -in fold diff --git a/Prelude/Bool/not b/Prelude/Bool/not deleted file mode 100644 --- a/Prelude/Bool/not +++ /dev/null @@ -1,12 +0,0 @@ -{- -Flip the value of a `Bool` - -Examples: - -``` -./not True = False - -./not False = True -``` --} -let not : Bool → Bool = λ(b : Bool) → b == False in not diff --git a/Prelude/Bool/odd b/Prelude/Bool/odd deleted file mode 100644 --- a/Prelude/Bool/odd +++ /dev/null @@ -1,22 +0,0 @@ -{- -Returns `True` if there are an odd number of `True` elements in the list and -returns `False` otherwise - -Examples: - -``` -./odd [ True, False, True ] = False - -./odd [ True, False ] = True - -./odd [ True ] = True - -./odd ([] : List Bool) = False -``` --} - let odd - : List Bool → Bool - = λ(xs : List Bool) - → List/fold Bool xs Bool (λ(x : Bool) → λ(y : Bool) → x != y) False - -in odd diff --git a/Prelude/Bool/or b/Prelude/Bool/or deleted file mode 100644 --- a/Prelude/Bool/or +++ /dev/null @@ -1,18 +0,0 @@ -{- -The `or` function returns `True` if there are any `True` elements in the `List` -and returns `False` otherwise - -Examples: - -``` -./or [ True, False, True ] = True - -./or ([] : List Bool) = False -``` --} - let or - : List Bool → Bool - = λ(xs : List Bool) - → List/fold Bool xs Bool (λ(l : Bool) → λ(r : Bool) → l || r) False - -in or diff --git a/Prelude/Bool/show b/Prelude/Bool/show deleted file mode 100644 --- a/Prelude/Bool/show +++ /dev/null @@ -1,13 +0,0 @@ -{- -Render a `Bool` as `Text` using the same representation as Dhall source code -(i.e. beginning with a capital letter) - -Examples: - -``` -./show True = "True" - -./show False = "False" -``` --} -let show : Bool → Text = λ(b : Bool) → if b then "True" else "False" in show diff --git a/Prelude/Double/show b/Prelude/Double/show deleted file mode 100644 --- a/Prelude/Double/show +++ /dev/null @@ -1,13 +0,0 @@ -{- -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) - -Examples: - -``` -./show -3.1 = "-3.1" - -./show 0.4 = "0.4" -``` --} -let show : Double → Text = Double/show in show diff --git a/Prelude/Integer/show b/Prelude/Integer/show deleted file mode 100644 --- a/Prelude/Integer/show +++ /dev/null @@ -1,14 +0,0 @@ -{- -Render an `Integer` as `Text` using the same representation as Dhall source -code (i.e. a decimal number with a leading `-` sign if negative and a leading -`+` sign if non-negative) - -Examples: - -``` -./show -3 = "-3" - -./show +0 = "+0" -``` --} -let show : Integer → Text = Integer/show in show diff --git a/Prelude/Integer/toDouble b/Prelude/Integer/toDouble deleted file mode 100644 --- a/Prelude/Integer/toDouble +++ /dev/null @@ -1,12 +0,0 @@ -{- -Convert an `Integer` to the corresponding `Double` - -Examples: - -``` -./toDouble -3 = -3.0 - -./toDouble +2 = 2.0 -``` --} -let toDouble : Integer → Double = Integer/toDouble in toDouble diff --git a/Prelude/List/all b/Prelude/List/all deleted file mode 100644 --- a/Prelude/List/all +++ /dev/null @@ -1,20 +0,0 @@ -{- -Returns `True` if the supplied function returns `True` for all elements in the -`List` - -Examples: - -``` -./all Natural Natural/even [ 2, 3, 5 ] = False - -./all Natural Natural/even ([] : List Natural) = True -``` --} - let all - : ∀(a : Type) → (a → Bool) → List a → Bool - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : List a) - → List/fold a xs Bool (λ(x : a) → λ(r : Bool) → f x && r) True - -in all diff --git a/Prelude/List/any b/Prelude/List/any deleted file mode 100644 --- a/Prelude/List/any +++ /dev/null @@ -1,20 +0,0 @@ -{- -Returns `True` if the supplied function returns `True` for any element in the -`List` - -Examples: - -``` -./any Natural Natural/even [ 2, 3, 5 ] = True - -./any Natural Natural/even ([] : List Natural) = False -``` --} - let any - : ∀(a : Type) → (a → Bool) → List a → Bool - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : List a) - → List/fold a xs Bool (λ(x : a) → λ(r : Bool) → f x || r) False - -in any diff --git a/Prelude/List/build b/Prelude/List/build deleted file mode 100644 --- a/Prelude/List/build +++ /dev/null @@ -1,32 +0,0 @@ -{- -`build` is the inverse of `fold` - -Examples: - -``` -./build -Text -( λ(list : Type) -→ λ(cons : Text → list → list) -→ λ(nil : list) -→ cons "ABC" (cons "DEF" nil) -) -= [ "ABC", "DEF" ] - -./build -Text -( λ(list : Type) -→ λ(cons : Text → list → list) -→ λ(nil : list) -→ nil -) -= [] : List Text -``` --} - let build - : ∀(a : Type) - → (∀(list : Type) → ∀(cons : a → list → list) → ∀(nil : list) → list) - → List a - = List/build - -in build diff --git a/Prelude/List/concat b/Prelude/List/concat deleted file mode 100644 --- a/Prelude/List/concat +++ /dev/null @@ -1,42 +0,0 @@ -{- -Concatenate a `List` of `List`s into a single `List` - -Examples: - -``` -./concat Natural -[ [0, 1, 2] -, [3, 4] -, [5, 6, 7, 8] -] -= [ 0, 1, 2, 3, 4, 5, 6, 7, 8 ] - -./concat Natural -( [ [] : List Natural - , [] : List Natural - , [] : List Natural - ] -) -= [] : List Natural - -./concat Natural ([] : List (List Natural)) = [] : List Natural -``` --} - let concat - : ∀(a : Type) → List (List a) → List a - = λ(a : Type) - → λ(xss : List (List a)) - → List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → λ(nil : list) - → List/fold - (List a) - xss - list - (λ(xs : List a) → λ(ys : list) → List/fold a xs list cons ys) - nil - ) - -in concat diff --git a/Prelude/List/concatMap b/Prelude/List/concatMap deleted file mode 100644 --- a/Prelude/List/concatMap +++ /dev/null @@ -1,28 +0,0 @@ -{- -Transform a list by applying a function to each element and flattening the -results - -Examples: - -``` -./concatMap Natural Natural (λ(n : Natural) → [n, n]) [2, 3, 5] -= [ 2, 2, 3, 3, 5, 5 ] - -./concatMap Natural Natural (λ(n : Natural) → [n, n]) ([] : List Natural) -= [] : List Natural -``` --} - let concatMap - : ∀(a : Type) → ∀(b : Type) → (a → List b) → List a → List b - = λ(a : Type) - → λ(b : Type) - → λ(f : a → List b) - → λ(xs : List a) - → List/build - b - ( λ(list : Type) - → λ(cons : b → list → list) - → List/fold a xs list (λ(x : a) → List/fold b (f x) list cons) - ) - -in concatMap diff --git a/Prelude/List/filter b/Prelude/List/filter deleted file mode 100644 --- a/Prelude/List/filter +++ /dev/null @@ -1,30 +0,0 @@ -{- -Only keep elements of the list where the supplied function returns `True` - -Examples: - -``` -./filter Natural Natural/even [ 2, 3, 5 ] -= [ 2 ] - -./filter Natural Natural/odd [ 2, 3, 5 ] -= [ 3, 5 ] -``` --} - let filter - : ∀(a : Type) → (a → Bool) → List a → List a - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : List a) - → List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → List/fold - a - xs - list - (λ(x : a) → λ(xs : list) → if f x then cons x xs else xs) - ) - -in filter diff --git a/Prelude/List/fold b/Prelude/List/fold deleted file mode 100644 --- a/Prelude/List/fold +++ /dev/null @@ -1,46 +0,0 @@ -{- -`fold` is the primitive function for consuming `List`s - -If you treat the list `[ x, y, z ]` as `cons x (cons y (cons z nil))`, then a -`fold` just replaces each `cons` and `nil` with something else - -Examples: - -``` - ./fold - Natural - [ 2, 3, 5 ] - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - 0 -= 10 - - λ(nil : Natural) -→ ./fold - Natural - [ 2, 3, 5 ] - Natural - (λ(x : Natural) → λ(y : Natural) → x + y) - nil -= λ(nil : Natural) → 2 + 3 + 5 + nil - - λ(list : Type) -→ λ(cons : Natural → list → list) -→ λ(nil : list) -→ ./fold Natural [ 2, 3, 5 ] list cons nil -= λ(list : Type) -→ λ(cons : Natural → list → list) -→ λ(nil : list) -→ cons 2 (cons 3 (cons 5 nil)) -``` --} - let fold - : ∀(a : Type) - → List a - → ∀(list : Type) - → ∀(cons : a → list → list) - → ∀(nil : list) - → list - = List/fold - -in fold diff --git a/Prelude/List/generate b/Prelude/List/generate deleted file mode 100644 --- a/Prelude/List/generate +++ /dev/null @@ -1,38 +0,0 @@ -{- -Build a list by calling the supplied function on all `Natural` numbers from `0` -up to but not including the supplied `Natural` number - -Examples: - -``` -./generate 5 Bool Natural/even = [ True, False, True, False, True ] - -./generate 0 Bool Natural/even = [] : List Bool -``` --} - let generate - : Natural → ∀(a : Type) → (Natural → a) → List a - = λ(n : Natural) - → λ(a : Type) - → λ(f : Natural → a) - → List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → List/fold - { index : Natural, value : {} } - ( List/indexed - {} - ( List/build - {} - ( λ(list : Type) - → λ(cons : {} → list → list) - → Natural/fold n list (cons {=}) - ) - ) - ) - list - (λ(x : { index : Natural, value : {} }) → cons (f x.index)) - ) - -in generate diff --git a/Prelude/List/head b/Prelude/List/head deleted file mode 100644 --- a/Prelude/List/head +++ /dev/null @@ -1,12 +0,0 @@ -{- -Retrieve the first element of the list - -Examples: - -``` -./head Natural [ 0, 1, 2 ] = [ 0 ] : Optional Natural - -./head Natural ([] : List Natural) = [] : Optional Natural -``` --} -let head : ∀(a : Type) → List a → Optional a = List/head in head diff --git a/Prelude/List/indexed b/Prelude/List/indexed deleted file mode 100644 --- a/Prelude/List/indexed +++ /dev/null @@ -1,21 +0,0 @@ -{- -Tag each element of the list with its index - -Examples: - -``` -./indexed Bool [ True, False, True ] -= [ { index = 0, value = True } - , { index = 1, value = False } - , { index = 2, value = True } - ] : List { index : Natural, value : Bool } - -./indexed Bool ([] : List Bool) -= [] : List { index : Natural, value : Bool } -``` --} - let indexed - : ∀(a : Type) → List a → List { index : Natural, value : a } - = List/indexed - -in indexed diff --git a/Prelude/List/iterate b/Prelude/List/iterate deleted file mode 100644 --- a/Prelude/List/iterate +++ /dev/null @@ -1,43 +0,0 @@ -{- -Generate a list of the specified length given a seed value and transition -function - -Examples: - -``` -./iterate 10 Natural (λ(x : Natural) → x * 2) 1 -= [ 1, 2, 4, 8, 16, 32, 64, 128, 256, 512 ] - -./iterate 0 Natural (λ(x : Natural) → x * 2) 1 -= [] : List Natural -``` --} - let iterate - : Natural → ∀(a : Type) → (a → a) → a → List a - = λ(n : Natural) - → λ(a : Type) - → λ(f : a → a) - → λ(x : a) - → List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → List/fold - { index : Natural, value : {} } - ( List/indexed - {} - ( List/build - {} - ( λ(list : Type) - → λ(cons : {} → list → list) - → Natural/fold n list (cons {=}) - ) - ) - ) - list - ( λ(y : { index : Natural, value : {} }) - → cons (Natural/fold y.index a f x) - ) - ) - -in iterate diff --git a/Prelude/List/last b/Prelude/List/last deleted file mode 100644 --- a/Prelude/List/last +++ /dev/null @@ -1,12 +0,0 @@ -{- -Retrieve the last element of the list - -Examples: - -``` -./last Natural [ 0, 1, 2 ] = [ 2 ] : Optional Natural - -./last Natural ([] : List Natural) = [] : Optional Natural -``` --} -let last : ∀(a : Type) → List a → Optional a = List/last in last diff --git a/Prelude/List/length b/Prelude/List/length deleted file mode 100644 --- a/Prelude/List/length +++ /dev/null @@ -1,12 +0,0 @@ -{- -Returns the number of elements in a list - -Examples: - -``` -./length Natural [ 0, 1, 2 ] = 3 - -./length Natural ([] : List Natural) = 0 -``` --} -let length : ∀(a : Type) → List a → Natural = List/length in length diff --git a/Prelude/List/map b/Prelude/List/map deleted file mode 100644 --- a/Prelude/List/map +++ /dev/null @@ -1,27 +0,0 @@ -{- -Transform a list by applying a function to each element - -Examples: - -``` -./map Natural Bool Natural/even [ 2, 3, 5 ] -= [ True, False, False ] - -./map Natural Bool Natural/even ([] : List Natural) -= [] : List Bool -``` --} - let map - : ∀(a : Type) → ∀(b : Type) → (a → b) → List a → List b - = λ(a : Type) - → λ(b : Type) - → λ(f : a → b) - → λ(xs : List a) - → List/build - b - ( λ(list : Type) - → λ(cons : b → list → list) - → List/fold a xs list (λ(x : a) → cons (f x)) - ) - -in map diff --git a/Prelude/List/null b/Prelude/List/null deleted file mode 100644 --- a/Prelude/List/null +++ /dev/null @@ -1,16 +0,0 @@ -{- -Returns `True` if the `List` is empty and `False` otherwise - -Examples: - -``` -./null Natural [ 0, 1, 2 ] = False - -./null Natural ([] : List Natural) = True -``` --} - let null - : ∀(a : Type) → List a → Bool - = λ(a : Type) → λ(xs : List a) → Natural/isZero (List/length a xs) - -in null diff --git a/Prelude/List/replicate b/Prelude/List/replicate deleted file mode 100644 --- a/Prelude/List/replicate +++ /dev/null @@ -1,24 +0,0 @@ -{- -Build a list by copying the given element the specified number of times - -Examples: - -``` -./replicate 9 Natural 1 = [ 1, 1, 1, 1, 1, 1, 1, 1, 1 ] - -./replicate 0 Natural 1 = [] : List Natural -``` --} - let replicate - : Natural → ∀(a : Type) → a → List a - = λ(n : Natural) - → λ(a : Type) - → λ(x : a) - → List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → Natural/fold n list (cons x) - ) - -in replicate diff --git a/Prelude/List/reverse b/Prelude/List/reverse deleted file mode 100644 --- a/Prelude/List/reverse +++ /dev/null @@ -1,12 +0,0 @@ -{- -Reverse a list - -Examples: - -``` -./reverse Natural [ 0, 1, 2 ] = [ 2, 1, 0 ] : List Natural - -./reverse Natural ([] : List Natural) = [] : List Natural -``` --} -let reverse : ∀(a : Type) → List a → List a = List/reverse in reverse diff --git a/Prelude/List/shifted b/Prelude/List/shifted deleted file mode 100644 --- a/Prelude/List/shifted +++ /dev/null @@ -1,87 +0,0 @@ -{- -Combine a `List` of `List`s, offsetting the `index` of each element by the -number of elements in preceding lists - -Examples: - -``` -./shifted -Bool -[ [ { index = 0, value = True } - , { index = 1, value = True } - , { index = 2, value = True } - ] -, [ { index = 0, value = False } - , { index = 1, value = False } - ] -, [ { index = 0, value = True } - , { index = 1, value = True } - , { index = 2, value = True } - , { index = 3, value = True } - ] -] -= [ { index = 0, value = True } - , { index = 1, value = True } - , { index = 2, value = True } - , { index = 3, value = False } - , { index = 4, value = False } - , { index = 5, value = True } - , { index = 6, value = True } - , { index = 7, value = True } - , { index = 8, value = True } - ] - -./shifted Bool ([] : List (List { index : Natural, value : Bool })) -= [] : List { index : Natural, value : Bool } -``` --} - let shifted - : ∀(a : Type) - → List (List { index : Natural, value : a }) - → List { index : Natural, value : a } - = λ(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) - → let result = - 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 }) - → let length = - List/length - { index : Natural, value : a } - kvs - - in { count = y.count + length - , diff = - λ(n : Natural) - → List/fold - { index : Natural, value : a } - kvs - list - ( λ ( kvOld - : { index : Natural, value : a } - ) - → λ(z : list) - → let kvNew = - { index = kvOld.index + n - , value = kvOld.value - } - - in cons kvNew z - ) - (y.diff (n + length)) - } - ) - { count = 0, diff = λ(_ : Natural) → nil } - - in result.diff 0 - ) - -in shifted diff --git a/Prelude/List/unzip b/Prelude/List/unzip deleted file mode 100644 --- a/Prelude/List/unzip +++ /dev/null @@ -1,55 +0,0 @@ -{- -Unzip a `List` into two separate `List`s - -Examples: - -``` -./unzip -Text -Bool -( [ { _1 = "ABC", _2 = True } - , { _1 = "DEF", _2 = False } - , { _1 = "GHI", _2 = True } - ] -) -= { _1 = [ "ABC", "DEF", "GHI" ] - , _2 = [ True, False, True ] - } - -./unzip Text Bool ([] : List { _1 : Text, _2 : Bool }) -= { _1 = [] : List Text, _2 = [] : List Bool } -``` --} - let unzip - : ∀(a : Type) - → ∀(b : Type) - → List { _1 : a, _2 : b } - → { _1 : List a, _2 : List b } - = λ(a : Type) - → λ(b : Type) - → λ(xs : List { _1 : a, _2 : b }) - → { _1 = - List/build - a - ( λ(list : Type) - → λ(cons : a → list → list) - → List/fold - { _1 : a, _2 : b } - xs - list - (λ(x : { _1 : a, _2 : b }) → cons x._1) - ) - , _2 = - List/build - b - ( λ(list : Type) - → λ(cons : b → list → list) - → List/fold - { _1 : a, _2 : b } - xs - list - (λ(x : { _1 : a, _2 : b }) → cons x._2) - ) - } - -in unzip diff --git a/Prelude/Monoid b/Prelude/Monoid --- a/Prelude/Monoid +++ b/Prelude/Monoid @@ -1,39 +1,1 @@ -{- -Any function `f` that is a `Monoid` must satisfy the following law: - -``` -t : Type -f : ./Monoid t -xs : List (List t) - -f (./List/concat t xs) = f (./map (List t) t f xs) -``` - -Examples: - -``` -./Bool/and - : ./Monoid Bool -./Bool/or - : ./Monoid Bool -./Bool/even - : ./Monoid Bool -./Bool/odd - : ./Monoid Bool -./List/concat - : ∀(a : Type) → ./Monoid (List a) -./List/shifted - : ∀(a : Type) → ./Monoid (List { index : Natural, value : a }) -./Natural/sum - : ./Monoid Natural -./Natural/product - : ./Monoid Natural -./Optional/head - : ∀(a : Type) → ./Monoid (Optional a) -./Optional/last - : ∀(a : Type) → ./Monoid (Optional a) -./Text/concat - : ./Monoid Text -``` --} -let Monoid : ∀(m : Type) → Type = λ(m : Type) → List m → m in Monoid +https://raw.githubusercontent.com/dhall-lang/Prelude/a22da69657b9316a3c51ba0bf80c9d4024db3fce/Monoid sha256:7c753f458fb433ef50e2fc517c0eaffbf21afd07186cefa92ea77173fe83304e diff --git a/Prelude/Natural/build b/Prelude/Natural/build deleted file mode 100644 --- a/Prelude/Natural/build +++ /dev/null @@ -1,33 +0,0 @@ -{- -`build` is the inverse of `fold` - -Examples: - -``` -./build -( λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ succ (succ (succ zero)) -) -= 3 - -./build -( λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ zero -) -= 0 -``` --} - let build - : ( ∀(natural : Type) - → ∀(succ : natural → natural) - → ∀(zero : natural) - → natural - ) - → Natural - = Natural/build - -in build diff --git a/Prelude/Natural/enumerate b/Prelude/Natural/enumerate deleted file mode 100644 --- a/Prelude/Natural/enumerate +++ /dev/null @@ -1,36 +0,0 @@ -{- -Generate a list of numbers from `0` up to but not including the specified -number - -Examples: - -``` -./enumerate 10 = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ] - -./enumerate 0 = [] : List Natural -``` --} - let enumerate - : Natural → List Natural - = λ(n : Natural) - → List/build - Natural - ( λ(list : Type) - → λ(cons : Natural → list → list) - → List/fold - { index : Natural, value : {} } - ( List/indexed - {} - ( List/build - {} - ( λ(list : Type) - → λ(cons : {} → list → list) - → Natural/fold n list (cons {=}) - ) - ) - ) - list - (λ(x : { index : Natural, value : {} }) → cons x.index) - ) - -in enumerate diff --git a/Prelude/Natural/even b/Prelude/Natural/even deleted file mode 100644 --- a/Prelude/Natural/even +++ /dev/null @@ -1,12 +0,0 @@ -{- -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 diff --git a/Prelude/Natural/fold b/Prelude/Natural/fold deleted file mode 100644 --- a/Prelude/Natural/fold +++ /dev/null @@ -1,33 +0,0 @@ -{- -`fold` is the primitive function for consuming `Natural` numbers - -If you treat the number `3` as `succ (succ (succ zero))` then a `fold` just -replaces each `succ` and `zero` with something else - -Examples: - -``` -./fold 3 Natural (λ(x : Natural) → 5 * x) 1 = 125 - -λ(zero : Natural) → ./fold 3 Natural (λ(x : Natural) → 5 * x) zero -= λ(zero : Natural) → 5 * 5 * 5 * zero - - λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ ./fold 3 natural succ zero -= λ(natural : Type) -→ λ(succ : natural → natural) -→ λ(zero : natural) -→ succ (succ (succ zero)) -``` --} - let fold - : Natural - → ∀(natural : Type) - → ∀(succ : natural → natural) - → ∀(zero : natural) - → natural - = Natural/fold - -in fold diff --git a/Prelude/Natural/isZero b/Prelude/Natural/isZero deleted file mode 100644 --- a/Prelude/Natural/isZero +++ /dev/null @@ -1,12 +0,0 @@ -{- -Returns `True` if a number is `0` and returns `False` otherwise - -Examples: - -``` -./isZero 2 = False - -./isZero 0 = True -``` --} -let isZero : Natural → Bool = Natural/isZero in isZero diff --git a/Prelude/Natural/odd b/Prelude/Natural/odd deleted file mode 100644 --- a/Prelude/Natural/odd +++ /dev/null @@ -1,12 +0,0 @@ -{- -Returns `True` if a number is odd and returns `False` otherwise - -Examples: - -``` -./odd 3 = True - -./odd 0 = False -``` --} -let odd : Natural → Bool = Natural/odd in odd diff --git a/Prelude/Natural/product b/Prelude/Natural/product deleted file mode 100644 --- a/Prelude/Natural/product +++ /dev/null @@ -1,22 +0,0 @@ -{- -Multiply all the numbers in a `List` - -Examples: - -``` -./product [ 2, 3, 5 ] = 30 - -./product ([] : List Natural) = 1 -``` --} - let product - : List Natural → Natural - = λ(xs : List Natural) - → List/fold - Natural - xs - Natural - (λ(l : Natural) → λ(r : Natural) → l * r) - 1 - -in product diff --git a/Prelude/Natural/show b/Prelude/Natural/show deleted file mode 100644 --- a/Prelude/Natural/show +++ /dev/null @@ -1,13 +0,0 @@ -{- -Render a `Natural` number as `Text` using the same representation as Dhall -source code (i.e. a decimal number) - -Examples: - -``` -./show 3 = "3" - -./show 0 = "0" -``` --} -let show : Natural → Text = Natural/show in show diff --git a/Prelude/Natural/sum b/Prelude/Natural/sum deleted file mode 100644 --- a/Prelude/Natural/sum +++ /dev/null @@ -1,22 +0,0 @@ -{- -Add all the numbers in a `List` - -Examples: - -``` -./sum [ 2, 3, 5 ] = 10 - -./sum ([] : List Natural) = 0 -``` --} - let sum - : List Natural → Natural - = λ(xs : List Natural) - → List/fold - Natural - xs - Natural - (λ(l : Natural) → λ(r : Natural) → l + r) - 0 - -in sum diff --git a/Prelude/Natural/toDouble b/Prelude/Natural/toDouble deleted file mode 100644 --- a/Prelude/Natural/toDouble +++ /dev/null @@ -1,16 +0,0 @@ -{- -Convert a `Natural` number to the corresponding `Double` - -Examples: - -``` -./toDouble 3 = 3.0 - -./toDouble 0 = 0.0 -``` --} - let toDouble - : Natural → Double - = λ(n : Natural) → Integer/toDouble (Natural/toInteger n) - -in toDouble diff --git a/Prelude/Natural/toInteger b/Prelude/Natural/toInteger deleted file mode 100644 --- a/Prelude/Natural/toInteger +++ /dev/null @@ -1,12 +0,0 @@ -{- -Convert a `Natural` number to the corresponding `Integer` - -Examples: - -``` -./toInteger 3 = +3 - -./toInteger 0 = +0 -``` --} -let toInteger : Natural → Integer = Natural/toInteger in toInteger diff --git a/Prelude/Optional/all b/Prelude/Optional/all deleted file mode 100644 --- a/Prelude/Optional/all +++ /dev/null @@ -1,20 +0,0 @@ -{- -Returns `False` if the supplied function returns `False` for a present element -and `True` otherwise: - -Examples: - -``` -./all Natural Natural/even ([ 3 ] : Optional Natural) = False - -./all Natural Natural/even ([] : Optional Natural) = True -``` --} - let all - : ∀(a : Type) → (a → Bool) → Optional a → Bool - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : Optional a) - → Optional/fold a xs Bool f True - -in all diff --git a/Prelude/Optional/any b/Prelude/Optional/any deleted file mode 100644 --- a/Prelude/Optional/any +++ /dev/null @@ -1,20 +0,0 @@ -{- -Returns `True` if the supplied function returns `True` for a present element and -`False` otherwise - -Examples: - -``` -./any Natural Natural/even ([ 2 ] : Optional Natural) = True - -./any Natural Natural/even ([] : Optional Natural) = False -``` --} - let any - : ∀(a : Type) → (a → Bool) → Optional a → Bool - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : Optional a) - → Optional/fold a xs Bool f False - -in any diff --git a/Prelude/Optional/build b/Prelude/Optional/build deleted file mode 100644 --- a/Prelude/Optional/build +++ /dev/null @@ -1,36 +0,0 @@ -{- -`build` is the inverse of `fold` - -Examples: - -``` -./build -Natural -( λ(optional : Type) -→ λ(just : Natural → optional) -→ λ(nothing : optional) -→ just 1 -) -= [ 1 ] : Optional Natural - -./build -Natural -( λ(optional : Type) -→ λ(just : Natural → optional) -→ λ(nothing : optional) -→ nothing -) -= [] : Optional Natural -``` --} - let build - : ∀(a : Type) - → ( ∀(optional : Type) - → ∀(just : a → optional) - → ∀(nothing : optional) - → optional - ) - → Optional a - = Optional/build - -in build diff --git a/Prelude/Optional/concat b/Prelude/Optional/concat deleted file mode 100644 --- a/Prelude/Optional/concat +++ /dev/null @@ -1,28 +0,0 @@ -{- -Flatten two `Optional` layers into a single `Optional` layer - -Examples: - -``` -./concat Natural ([ [ 1 ] : Optional Natural ] : Optional (Optional Natural)) -= [ 1 ] : Optional Natural - -./concat Natural ([ [] : Optional Natural ] : Optional (Optional Natural)) -= [] : Optional Natural - -./concat Natural ([] : Optional (Optional Natural)) -= [] : Optional Natural -``` --} - let concat - : ∀(a : Type) → Optional (Optional a) → Optional a - = λ(a : Type) - → λ(x : Optional (Optional a)) - → Optional/fold - (Optional a) - x - (Optional a) - (λ(y : Optional a) → y) - ([] : Optional a) - -in concat diff --git a/Prelude/Optional/filter b/Prelude/Optional/filter deleted file mode 100644 --- a/Prelude/Optional/filter +++ /dev/null @@ -1,32 +0,0 @@ -{- -Only keep an `Optional` element if the supplied function returns `True` - -Examples: - -``` -./filter Natural Natural/even ([ 2 ] : Optional Natural) -= [ 2 ] : Optional Natural - -./filter Natural Natural/odd ([ 2 ] : Optional Natural) -= [] : Optional Natural -``` --} - let filter - : ∀(a : Type) → (a → Bool) → Optional a → Optional a - = λ(a : Type) - → λ(f : a → Bool) - → λ(xs : Optional a) - → Optional/build - a - ( λ(optional : Type) - → λ(just : a → optional) - → λ(nil : optional) - → Optional/fold - a - xs - optional - (λ(x : a) → if f x then just x else nil) - nil - ) - -in filter diff --git a/Prelude/Optional/fold b/Prelude/Optional/fold deleted file mode 100644 --- a/Prelude/Optional/fold +++ /dev/null @@ -1,21 +0,0 @@ -{- -`fold` is the primitive function for consuming `Optional` values - -Examples: - -``` -./fold Natural ([ 2 ] : Optional Natural) Natural (λ(x : Natural) → x) 0 = 2 - -./fold Natural ([] : Optional Natural) Natural (λ(x : Natural) → x) 0 = 0 -``` --} - let fold - : ∀(a : Type) - → Optional a - → ∀(optional : Type) - → ∀(just : a → optional) - → ∀(nothing : optional) - → optional - = Optional/fold - -in fold diff --git a/Prelude/Optional/head b/Prelude/Optional/head deleted file mode 100644 --- a/Prelude/Optional/head +++ /dev/null @@ -1,38 +0,0 @@ -{- -Returns the first non-empty `Optional` value in a `List` - -Examples: - -``` -./head -Natural -[ [ ] : Optional Natural -, [ 1 ] : Optional Natural -, [ 2 ] : Optional Natural -] -= [ 1 ] : Optional Natural - -./head -Natural -[ [] : Optional Natural, [] : Optional Natural ] -= [] : Optional Natural - -./head Natural ([] : List (Optional Natural)) -= [] : Optional Natural -``` --} - let head - : ∀(a : Type) → List (Optional a) → Optional a - = λ(a : Type) - → λ(xs : List (Optional a)) - → List/fold - (Optional a) - xs - (Optional a) - ( λ(l : Optional a) - → λ(r : Optional a) - → Optional/fold a l (Optional a) (λ(x : a) → [ x ] : Optional a) r - ) - ([] : Optional a) - -in head diff --git a/Prelude/Optional/last b/Prelude/Optional/last deleted file mode 100644 --- a/Prelude/Optional/last +++ /dev/null @@ -1,38 +0,0 @@ -{- -Returns the last non-empty `Optional` value in a `List` - -Examples: - -``` -./last -Natural -[ [ ] : Optional Natural -, [ 1 ] : Optional Natural -, [ 2 ] : Optional Natural -] -= [ 2 ] : Optional Natural - -./last -Natural -[ [] : Optional Natural, [] : Optional Natural ] -= [] : Optional Natural - -./last Natural ([] : List (Optional Natural)) -= [] : Optional Natural -``` --} - let last - : ∀(a : Type) → List (Optional a) → Optional a - = λ(a : Type) - → λ(xs : List (Optional a)) - → List/fold - (Optional a) - xs - (Optional a) - ( λ(l : Optional a) - → λ(r : Optional a) - → Optional/fold a r (Optional a) (λ(x : a) → [ x ] : Optional a) l - ) - ([] : Optional a) - -in last diff --git a/Prelude/Optional/length b/Prelude/Optional/length deleted file mode 100644 --- a/Prelude/Optional/length +++ /dev/null @@ -1,18 +0,0 @@ -{- -Returns `1` if the `Optional` value is present and `0` if the value is absent - -Examples: - -``` -./length Natural ([ 2 ] : Optional Natural) = 1 - -./length Natural ([] : Optional Natural) = 0 -``` --} - let length - : ∀(a : Type) → Optional a → Natural - = λ(a : Type) - → λ(xs : Optional a) - → Optional/fold a xs Natural (λ(_ : a) → 1) 0 - -in length diff --git a/Prelude/Optional/map b/Prelude/Optional/map deleted file mode 100644 --- a/Prelude/Optional/map +++ /dev/null @@ -1,27 +0,0 @@ -{- -Transform an `Optional` value with a function - -Examples: - -``` -./map Natural Bool Natural/even ([ 3 ] : Optional Natural) -= [ False ] : Optional Bool - -./map Natural Bool Natural/even ([] : Optional Natural) -= [] : Optional Bool -``` --} - let map - : ∀(a : Type) → ∀(b : Type) → (a → b) → Optional a → Optional b - = λ(a : Type) - → λ(b : Type) - → λ(f : a → b) - → λ(o : Optional a) - → Optional/fold - a - o - (Optional b) - (λ(x : a) → [ f x ] : Optional b) - ([] : Optional b) - -in map diff --git a/Prelude/Optional/null b/Prelude/Optional/null deleted file mode 100644 --- a/Prelude/Optional/null +++ /dev/null @@ -1,18 +0,0 @@ -{- -Returns `True` if the `Optional` value is absent and `False` if present - -Examples: - -``` -./null Natural ([ 2 ] : Optional Natural) = False - -./null Natural ([] : Optional Natural) = True -``` --} - let null - : ∀(a : Type) → Optional a → Bool - = λ(a : Type) - → λ(xs : Optional a) - → Optional/fold a xs Bool (λ(_ : a) → False) True - -in null diff --git a/Prelude/Optional/toList b/Prelude/Optional/toList deleted file mode 100644 --- a/Prelude/Optional/toList +++ /dev/null @@ -1,23 +0,0 @@ -{- -Convert an `Optional` value into the equivalent `List` - -Examples: - -``` -./toList Natural ([ 1 ] : Optional Natural) = [ 1 ] - -./toList Natural ([] : Optional Natural) = [] : List Natural -``` --} - let toList - : ∀(a : Type) → Optional a → List a - = λ(a : Type) - → λ(o : Optional a) - → Optional/fold - a - o - (List a) - (λ(x : a) → ([ x ] : List a)) - ([] : List a) - -in toList diff --git a/Prelude/Optional/unzip b/Prelude/Optional/unzip deleted file mode 100644 --- a/Prelude/Optional/unzip +++ /dev/null @@ -1,41 +0,0 @@ -{- -Unzip an `Optional` value into two separate `Optional` values - -Examples: - -``` -./unzip -Text -Bool -([ { _1 = "ABC", _2 = True } ] : Optional { _1 : Text, _2 : Bool }) -= { _1 = [ "ABC" ] : Optional Text, _2 = [ True ] : Optional Bool } - -./unzip Text Bool ([] : Optional { _1 : Text, _2 : Bool }) -= { _1 = [] : Optional Text, _2 = [] : Optional Bool } -``` --} - let unzip - : ∀(a : Type) - → ∀(b : Type) - → Optional { _1 : a, _2 : b } - → { _1 : Optional a, _2 : Optional b } - = λ(a : Type) - → λ(b : Type) - → λ(xs : Optional { _1 : a, _2 : b }) - → { _1 = - Optional/fold - { _1 : a, _2 : b } - xs - (Optional a) - (λ(x : { _1 : a, _2 : b }) → [ x._1 ] : Optional a) - ([] : Optional a) - , _2 = - Optional/fold - { _1 : a, _2 : b } - xs - (Optional b) - (λ(x : { _1 : a, _2 : b }) → [ x._2 ] : Optional b) - ([] : Optional b) - } - -in unzip diff --git a/Prelude/Text/concat b/Prelude/Text/concat deleted file mode 100644 --- a/Prelude/Text/concat +++ /dev/null @@ -1,17 +0,0 @@ -{- -Concatenate all the `Text` values in a `List` - -Examples: - -``` -./concat [ "ABC", "DEF", "GHI" ] = "ABCDEFGHI" - -./concat ([] : List Text) = "" -``` --} - let concat - : List Text → Text - = λ(xs : List Text) - → List/fold Text xs Text (λ(x : Text) → λ(y : Text) → x ++ y) "" - -in concat diff --git a/Prelude/Text/concatMap b/Prelude/Text/concatMap deleted file mode 100644 --- a/Prelude/Text/concatMap +++ /dev/null @@ -1,21 +0,0 @@ -{- -Transform each value in a `List` into `Text` and concatenate the result - -Examples: - -``` -./concatMap Natural (λ(n : Natural) → "${Natural/show n} ") [ 0, 1, 2 ] -= "0 1 2 " - -./concatMap Natural (λ(n : Natural) → "${Natural/show n} ") ([] : List Natural) -= "" -``` --} - let concatMap - : ∀(a : Type) → (a → Text) → List a → Text - = λ(a : Type) - → λ(f : a → Text) - → λ(xs : List a) - → List/fold a xs Text (λ(x : a) → λ(y : Text) → f x ++ y) "" - -in concatMap diff --git a/Prelude/Text/concatMapSep b/Prelude/Text/concatMapSep deleted file mode 100644 --- a/Prelude/Text/concatMapSep +++ /dev/null @@ -1,45 +0,0 @@ -{- -Transform each value in a `List` to `Text` and then concatenate them with a -separator in between each value - -Examples: - -``` -./concatMapSep ", " Natural Natural/show [ 0, 1, 2 ] = "0, 1, 2" - -./concatMapSep ", " Natural Natural/show ([] : List Natural) = "" -``` --} - let concatMapSep - : ∀(separator : Text) → ∀(a : Type) → (a → Text) → List a → Text - = λ(separator : Text) - → λ(a : Type) - → λ(f : a → Text) - → λ(elements : List a) - → let status = - List/fold - a - elements - < Empty : {} | NonEmpty : Text > - ( λ(element : a) - → λ(status : < Empty : {} | NonEmpty : Text >) - → merge - { Empty = - λ(_ : {}) → < NonEmpty = f element | Empty : {} > - , NonEmpty = - λ(result : Text) - → < NonEmpty = f element ++ separator ++ result - | Empty : {} - > - } - status - : < Empty : {} | NonEmpty : Text > - ) - < Empty = {=} | NonEmpty : Text > - - in merge - { Empty = λ(_ : {}) → "", NonEmpty = λ(result : Text) → result } - status - : Text - -in concatMapSep diff --git a/Prelude/Text/concatSep b/Prelude/Text/concatSep deleted file mode 100644 --- a/Prelude/Text/concatSep +++ /dev/null @@ -1,42 +0,0 @@ -{- -Concatenate a `List` of `Text` values with a separator in between each value - -Examples: - -``` -./concatSep ", " [ "ABC", "DEF", "GHI" ] = "ABC, DEF, GHI" - -./concatSep ", " ([] : List Text) = "" -``` --} - let concatSep - : ∀(separator : Text) → ∀(elements : List Text) → Text - = λ(separator : Text) - → λ(elements : List Text) - → let status = - List/fold - Text - elements - < Empty : {} | NonEmpty : Text > - ( λ(element : Text) - → λ(status : < Empty : {} | NonEmpty : Text >) - → merge - { Empty = - λ(_ : {}) → < NonEmpty = element | Empty : {} > - , NonEmpty = - λ(result : Text) - → < NonEmpty = element ++ separator ++ result - | Empty : {} - > - } - status - : < Empty : {} | NonEmpty : Text > - ) - < Empty = {=} | NonEmpty : Text > - - in merge - { Empty = λ(_ : {}) → "", NonEmpty = λ(result : Text) → result } - status - : Text - -in concatSep diff --git a/Prelude/package.dhall b/Prelude/package.dhall new file mode 100644 --- /dev/null +++ b/Prelude/package.dhall @@ -0,0 +1,1 @@ +https://raw.githubusercontent.com/dhall-lang/Prelude/e9c90396c02f9eb0fe66c00c544615cbfa068f34/package.dhall sha256:9fbb8a6db3360fa30086ea8462dc36087f0e4f87af2a1f802a8befdc5a08f809 diff --git a/benchmark/deep-nested-large-record/Main.hs b/benchmark/deep-nested-large-record/Main.hs --- a/benchmark/deep-nested-large-record/Main.hs +++ b/benchmark/deep-nested-large-record/Main.hs @@ -30,9 +30,20 @@ $ Seq.replicate 5 $ Core.Var (Core.V "prelude" 0) `Core.Field` "types" `Core.Field` "Little" `Core.Field` "Foo" +unionPerformance :: Core.Expr s TypeCheck.X -> Criterion.Benchmarkable +unionPerformance prelude = Criterion.whnf TypeCheck.typeOf expr + where + expr = + Core.Let "x" Nothing + (Core.Let "big" Nothing (prelude `Core.Field` "types" `Core.Field` "Big") + (Core.Prefer "big" "big") + ) + "x" + main :: IO () main = do prelude <- Import.load (Core.Embed dhallPreludeImport) defaultMain [ Criterion.bench "issue 412" (issue412 prelude) + , Criterion.bench "union performance" (unionPerformance prelude) ] diff --git a/benchmark/dhall-command/Main.hs b/benchmark/dhall-command/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/dhall-command/Main.hs @@ -0,0 +1,20 @@ + +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Dhall.Main as Main +import Dhall.Binary (defaultStandardVersion) + +options :: Main.Options +options = Main.Options + { Main.mode = Main.Default False + , Main.explain = False + , Main.plain = False + , Main.ascii = False + , Main.standardVersion = defaultStandardVersion + } + +main :: IO () +main = do + Main.command options diff --git a/benchmark/parser/Main.hs b/benchmark/parser/Main.hs --- a/benchmark/parser/Main.hs +++ b/benchmark/parser/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -5,6 +6,7 @@ import Control.Monad (forM) import Criterion.Main (defaultMain, bgroup, bench, whnf, nfIO) import Data.Map (Map, foldrWithKey, singleton, unions) +import Data.Monoid ((<>)) import System.Directory @@ -16,6 +18,23 @@ import qualified Dhall.Binary import qualified Dhall.Parser as Dhall +#if MIN_VERSION_directory(1,2,3) +#else +import Control.Exception (bracket) + +withCurrentDirectory :: FilePath -- ^ Directory to execute in + -> IO a -- ^ Action to be executed + -> IO a +withCurrentDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do + setCurrentDirectory dir + action + +listDirectory :: FilePath -> IO [FilePath] +listDirectory path = filter f <$> getDirectoryContents path + where f filename = filename /= "." && filename /= ".." +#endif + type PreludeFiles = Map FilePath T.Text loadPreludeFiles :: IO PreludeFiles @@ -53,7 +72,7 @@ term <- case Codec.Serialise.deserialiseOrFail bytes of Left _ -> Nothing Right term -> return term - case Dhall.Binary.decode term of + case Dhall.Binary.decodeWithVersion term of Left _ -> Nothing Right expression -> return expression @@ -69,5 +88,11 @@ ] , benchExprFromText "Long variable names" (T.replicate 1000000 "x") , benchExprFromText "Large number of function arguments" (T.replicate 10000 "x ") + , benchExprFromText "Long double-quoted strings" ("\"" <> T.replicate 1000000 "x" <> "\"") + , benchExprFromText "Long single-quoted strings" ("''" <> T.replicate 1000000 "x" <> "''") + , benchExprFromText "Whitespace" (T.replicate 1000000 " " <> "x") + , benchExprFromText "Line comment" ("x -- " <> T.replicate 1000000 " ") + , benchExprFromText "Block comment" ("x {- " <> T.replicate 1000000 " " <> "-}") + , benchExprFromText "Deeply nested parentheses" "((((((((((((((((x))))))))))))))))" , benchParser prelude ] diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.17.0 +Version: 1.18.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.0.1 @@ -24,65 +24,8 @@ Category: Compiler Extra-Source-Files: CHANGELOG.md - Prelude/Bool/and - Prelude/Bool/build - Prelude/Bool/even - Prelude/Bool/fold - Prelude/Bool/not - Prelude/Bool/odd - Prelude/Bool/or - Prelude/Bool/show - Prelude/Double/show - Prelude/Integer/show - Prelude/Integer/toDouble - Prelude/List/all - Prelude/List/any - Prelude/List/build - Prelude/List/concat - Prelude/List/concatMap - Prelude/List/filter - Prelude/List/fold - Prelude/List/generate - Prelude/List/head - Prelude/List/indexed - Prelude/List/iterate - Prelude/List/last - Prelude/List/length - Prelude/List/map - Prelude/List/null - Prelude/List/replicate - Prelude/List/reverse - Prelude/List/shifted - Prelude/List/unzip + Prelude/package.dhall Prelude/Monoid - Prelude/Natural/build - Prelude/Natural/enumerate - Prelude/Natural/even - Prelude/Natural/fold - Prelude/Natural/isZero - Prelude/Natural/odd - Prelude/Natural/product - Prelude/Natural/show - Prelude/Natural/sum - Prelude/Natural/toDouble - Prelude/Natural/toInteger - Prelude/Optional/all - Prelude/Optional/any - Prelude/Optional/build - Prelude/Optional/concat - Prelude/Optional/filter - Prelude/Optional/fold - Prelude/Optional/head - Prelude/Optional/last - Prelude/Optional/length - Prelude/Optional/map - Prelude/Optional/null - Prelude/Optional/toList - Prelude/Optional/unzip - Prelude/Text/concat - Prelude/Text/concatMap - Prelude/Text/concatMapSep - Prelude/Text/concatSep tests/format/*.dhall tests/normalization/tutorial/combineTypes/*.dhall tests/normalization/tutorial/projection/*.dhall @@ -151,6 +94,7 @@ tests/regression/*.dhall tests/tutorial/*.dhall tests/typecheck/*.dhall + tests/typecheck/failure/*.dhall tests/typecheck/examples/Monoid/*.dhall tests/import/*.dhall tests/import/data/foo/bar/a.dhall @@ -174,28 +118,26 @@ bytestring < 0.11, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , - containers >= 0.5.0.0 && < 0.6 , + containers >= 0.5.0.0 && < 0.7 , contravariant < 1.6 , cryptonite >= 0.23 && < 1.0 , Diff >= 0.2 && < 0.4 , - directory >= 1.2.7.1 && < 1.4 , + directory >= 1.2.2.0 && < 1.4 , exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , - hashable < 1.3 , - haskeline >= 0.7.3.0 && < 0.8 , - insert-ordered-containers >= 0.2.1.0 && < 0.3 , + haskeline >= 0.7.2.1 && < 0.8 , lens-family-core >= 1.0.0 && < 1.3 , - megaparsec >= 6.1.1 && < 6.6 , + megaparsec >= 7.0.0 && < 7.1 , memory >= 0.14 && < 0.15, mtl >= 2.2.1 && < 2.3 , optparse-applicative < 0.15, parsers >= 0.12.4 && < 0.13, prettyprinter >= 1.2.0.1 && < 1.3 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - repline >= 0.1.6.0 && < 0.2 , + repline >= 0.2.0.0 && < 0.3 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell < 2.14, + template-haskell < 2.15, text >= 0.11.1.0 && < 1.3 , transformers >= 0.2.0.0 && < 0.6 , unordered-containers >= 0.1.3.0 && < 0.3 , @@ -207,6 +149,7 @@ if !impl(ghc >= 8.0) Build-Depends: semigroups == 0.18.* Build-Depends: transformers == 0.4.2.* + Build-Depends: fail == 4.9.* Exposed-Modules: Dhall, @@ -219,10 +162,11 @@ Dhall.Hash, Dhall.Import, Dhall.Lint, - Dhall.Main + Dhall.Main, + Dhall.Map, Dhall.Parser, Dhall.Pretty, - Dhall.Repl + Dhall.Repl, Dhall.TH, Dhall.Tutorial, Dhall.TypeCheck @@ -232,6 +176,7 @@ Dhall.Parser.Combinators, Dhall.Parser.Token, Dhall.Import.Types, + Dhall.Util, Paths_dhall if flag(with-http) Other-Modules: @@ -244,7 +189,7 @@ Hs-Source-Dirs: dhall Main-Is: Main.hs Build-Depends: base, dhall - GHC-Options: -Wall + GHC-Options: -Wall -rtsopts Default-Language: Haskell2010 Test-Suite tasty @@ -267,10 +212,10 @@ containers , deepseq >= 1.2.0.1 && < 1.5 , dhall , - hashable , - insert-ordered-containers == 0.2.1.0 , + directory , + filepath , prettyprinter , - QuickCheck >= 2.10 && < 2.12, + QuickCheck >= 2.10 && < 2.13, quickcheck-instances >= 0.3.12 && < 0.4 , serialise , tasty >= 0.11.2 && < 1.2 , @@ -288,32 +233,51 @@ GHC-Options: -Wall Build-Depends: base , - directory >= 1.2.2.0 && < 1.4 , + directory , filepath < 1.5 , mockery < 0.4 , doctest >= 0.7.0 && < 0.17 Default-Language: Haskell2010 + -- `doctest` doesn't work with `MIN_VERSION` macros before GHC 8 + -- + -- See: https://ghc.haskell.org/trac/ghc/ticket/10970 + if impl(ghc < 8.0) + Buildable: False Benchmark dhall-parser Type: exitcode-stdio-1.0 - Main-Is: benchmark/parser/Main.hs + Hs-Source-Dirs: benchmark/parser + Main-Is: Main.hs Build-Depends: base >= 4 && < 5 , bytestring , - containers >= 0.5.0.0 && < 0.6, + containers >= 0.5.0.0 && < 0.7, criterion >= 1.1 && < 1.6, dhall , - directory >= 1.2.7.1 && < 1.4, + directory , serialise , text >= 0.11.1.0 && < 1.3 Default-Language: Haskell2010 + ghc-options: -rtsopts Benchmark deep-nested-large-record Type: exitcode-stdio-1.0 - Main-Is: benchmark/deep-nested-large-record/Main.hs + Hs-Source-Dirs: benchmark/deep-nested-large-record + Main-Is: Main.hs Build-Depends: base >= 4 && < 5 , - containers >= 0.5.0.0 && < 0.6, + containers >= 0.5.0.0 && < 0.7, criterion >= 1.1 && < 1.6, dhall Default-Language: Haskell2010 + + +Benchmark dhall-command + Type: exitcode-stdio-1.0 + Main-Is: Main.hs + Hs-Source-Dirs: benchmark/dhall-command + Build-Depends: + base >= 4 && < 5 , + dhall + Default-Language: Haskell2010 + ghc-options: -rtsopts -O2 diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -28,7 +28,7 @@ , sourceName , startingContext , normalizer - , protocolVersion + , standardVersion , defaultInputSettings , InputSettings , defaultEvaluateSettings @@ -97,7 +97,7 @@ import Data.Typeable (Typeable) import Data.Vector (Vector) import Data.Word (Word8, Word16, Word32, Word64) -import Dhall.Binary (ProtocolVersion(..)) +import Dhall.Binary (StandardVersion(..)) import Dhall.Core (Expr(..), Chunks(..)) import Dhall.Import (Imported(..)) import Dhall.Parser (Src(..)) @@ -114,7 +114,6 @@ import qualified Data.Foldable import qualified Data.Functor.Compose import qualified Data.Functor.Product -import qualified Data.HashMap.Strict.InsOrd import qualified Data.Scientific import qualified Data.Sequence import qualified Data.Set @@ -126,6 +125,7 @@ import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Import +import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck @@ -201,7 +201,7 @@ data EvaluateSettings = EvaluateSettings { _startingContext :: Dhall.Context.Context (Expr Src X) , _normalizer :: Dhall.Core.ReifiedNormalizer X - , _protocolVersion :: ProtocolVersion + , _standardVersion :: StandardVersion } -- | Default evaluation settings: no extra entries in the initial @@ -212,7 +212,7 @@ defaultEvaluateSettings = EvaluateSettings { _startingContext = Dhall.Context.empty , _normalizer = Dhall.Core.ReifiedNormalizer (const Nothing) - , _protocolVersion = Dhall.Binary.defaultProtocolVersion + , _standardVersion = Dhall.Binary.defaultStandardVersion } -- | Access the starting context used for evaluation and type-checking. @@ -239,16 +239,16 @@ => LensLike' f EvaluateSettings (Dhall.Core.ReifiedNormalizer X) l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s)) --- | Access the protocol version used when encoding or decoding Dhall --- expressions to and from a binary representation +-- | Access the standard version (used primarily when encoding or decoding +-- Dhall expressions to and from a binary representation) -- -- @since 1.17 -protocolVersion +standardVersion :: (Functor f, HasEvaluateSettings s) - => LensLike' f s ProtocolVersion -protocolVersion = evaluateSettings . l + => LensLike' f s StandardVersion +standardVersion = evaluateSettings . l where - l k s = fmap (\x -> s { _protocolVersion = x}) (k (_protocolVersion s)) + l k s = fmap (\x -> s { _standardVersion = x}) (k (_standardVersion s)) -- | @since 1.16 class HasEvaluateSettings s where @@ -312,7 +312,7 @@ let EvaluateSettings {..} = _evaluateSettings let transform = - set Dhall.Import.protocolVersion _protocolVersion + set Dhall.Import.standardVersion _standardVersion . set Dhall.Import.normalizer _normalizer . set Dhall.Import.startingContext _startingContext @@ -405,7 +405,7 @@ let EvaluateSettings {..} = _evaluateSettings let transform = - set Dhall.Import.protocolVersion _protocolVersion + set Dhall.Import.standardVersion _standardVersion . set Dhall.Import.normalizer _normalizer . set Dhall.Import.startingContext _startingContext @@ -658,14 +658,15 @@ {-| Decode a `Maybe` ->>> input (maybe natural) "[1] : Optional Natural" +>>> input (maybe natural) "Some 1" Just 1 -} maybe :: Type a -> Type (Maybe a) maybe (Type extractIn expectedIn) = Type extractOut expectedOut where - extractOut (OptionalLit _ es) = traverse extractIn es - extractOut _ = Nothing + extractOut (Some e ) = fmap Just (extractIn e) + extractOut (App None _) = return Nothing + extractOut _ = empty expectedOut = App Optional expectedIn @@ -707,10 +708,10 @@ unit = Type extractOut expectedOut where extractOut (RecordLit fields) - | Data.HashMap.Strict.InsOrd.null fields = return () + | Data.Foldable.null fields = return () extractOut _ = Nothing - expectedOut = Record Data.HashMap.Strict.InsOrd.empty + expectedOut = Record mempty {-| Decode a `String` @@ -730,13 +731,13 @@ pair l r = Type extractOut expectedOut where extractOut (RecordLit fields) = - (,) <$> ( Data.HashMap.Strict.InsOrd.lookup "_1" fields >>= extract l ) - <*> ( Data.HashMap.Strict.InsOrd.lookup "_2" fields >>= extract r ) + (,) <$> ( Dhall.Map.lookup "_1" fields >>= extract l ) + <*> ( Dhall.Map.lookup "_2" fields >>= extract r ) extractOut _ = Nothing expectedOut = Record - (Data.HashMap.Strict.InsOrd.fromList + (Dhall.Map.fromList [ ("_1", expected l) , ("_2", expected r) ] @@ -863,7 +864,7 @@ where extract _ = Nothing - expected = Union Data.HashMap.Strict.InsOrd.empty + expected = Union mempty instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where genericAutoWith options@(InterpretOptions {..}) = pure (Type {..}) @@ -884,7 +885,7 @@ extract _ = Nothing expected = - Union (Data.HashMap.Strict.InsOrd.fromList [(nameL, expectedL), (nameR, expectedR)]) + Union (Dhall.Map.fromList [(nameL, expectedL), (nameR, expectedR)]) Type extractL expectedL = evalState (genericAutoWith options) 1 Type extractR expectedR = evalState (genericAutoWith options) 1 @@ -903,7 +904,7 @@ extract _ = Nothing expected = - Union (Data.HashMap.Strict.InsOrd.insert name expectedR expectedL) + Union (Dhall.Map.insert name expectedR expectedL) Type extractL (Union expectedL) = evalState (genericAutoWith options) 1 Type extractR expectedR = evalState (genericAutoWith options) 1 @@ -922,7 +923,7 @@ extract _ = Nothing expected = - Union (Data.HashMap.Strict.InsOrd.insert name expectedL expectedR) + Union (Dhall.Map.insert name expectedL expectedR) Type extractL expectedL = evalState (genericAutoWith options) 1 Type extractR (Union expectedR) = evalState (genericAutoWith options) 1 @@ -932,7 +933,7 @@ where extract e = fmap L1 (extractL e) <|> fmap R1 (extractR e) - expected = Union (Data.HashMap.Strict.InsOrd.union expectedL expectedR) + expected = Union (Dhall.Map.union expectedL expectedR) Type extractL (Union expectedL) = evalState (genericAutoWith options) 1 Type extractR (Union expectedR) = evalState (genericAutoWith options) 1 @@ -947,7 +948,7 @@ where extract _ = Just U1 - expected = Record (Data.HashMap.Strict.InsOrd.fromList []) + expected = Record (Dhall.Map.fromList []) instance (GenericInterpret f, GenericInterpret g) => GenericInterpret (f :*: g) where genericAutoWith options = do @@ -958,7 +959,7 @@ pure (Type { extract = liftA2 (liftA2 (:*:)) extractL extractR - , expected = Record (Data.HashMap.Strict.InsOrd.union ktsL ktsR) + , expected = Record (Dhall.Map.union ktsL ktsR) } ) @@ -974,11 +975,11 @@ name <- getSelName n let extract (RecordLit m) = do let name' = fieldModifier (Data.Text.pack name) - e <- Data.HashMap.Strict.InsOrd.lookup name' m + e <- Dhall.Map.lookup name' m fmap (M1 . K1) (extract' e) extract _ = Nothing let expected = - Record (Data.HashMap.Strict.InsOrd.fromList [(key, expected')]) + Record (Dhall.Map.fromList [(key, expected')]) where key = fieldModifier (Data.Text.pack name) pure (Type {..}) @@ -1116,9 +1117,9 @@ instance Inject () where injectWith _ = InputType {..} where - embed = const (RecordLit Data.HashMap.Strict.InsOrd.empty) + embed = const (RecordLit mempty) - declared = Record Data.HashMap.Strict.InsOrd.empty + declared = Record mempty instance Inject a => Inject (Maybe a) where injectWith options = InputType embedOut declaredOut @@ -1172,13 +1173,13 @@ genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 (M1 l)) = - UnionLit keyL (embedL l) (Data.HashMap.Strict.InsOrd.singleton keyR declaredR) + UnionLit keyL (embedL l) (Dhall.Map.singleton keyR declaredR) embed (R1 (M1 r)) = - UnionLit keyR (embedR r) (Data.HashMap.Strict.InsOrd.singleton keyL declaredL) + UnionLit keyR (embedR r) (Dhall.Map.singleton keyL declaredL) declared = - Union (Data.HashMap.Strict.InsOrd.fromList [(keyL, declaredL), (keyR, declaredR)]) + Union (Dhall.Map.fromList [(keyL, declaredL), (keyR, declaredR)]) nL :: M1 i c1 f1 a nL = undefined @@ -1196,7 +1197,7 @@ genericInjectWith options@(InterpretOptions {..}) = pure (InputType {..}) where embed (L1 l) = - UnionLit keyL valL (Data.HashMap.Strict.InsOrd.insert keyR declaredR ktsL') + UnionLit keyL valL (Dhall.Map.insert keyR declaredR ktsL') where UnionLit keyL valL ktsL' = embedL l embed (R1 (M1 r)) = UnionLit keyR (embedR r) ktsL @@ -1206,7 +1207,7 @@ keyR = constructorModifier (Data.Text.pack (conName nR)) - declared = Union (Data.HashMap.Strict.InsOrd.insert keyR declaredR ktsL) + declared = Union (Dhall.Map.insert keyR declaredR ktsL) InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1 InputType embedR declaredR = evalState (genericInjectWith options) 1 @@ -1216,7 +1217,7 @@ where embed (L1 (M1 l)) = UnionLit keyL (embedL l) ktsR embed (R1 r) = - UnionLit keyR valR (Data.HashMap.Strict.InsOrd.insert keyL declaredL ktsR') + UnionLit keyR valR (Dhall.Map.insert keyL declaredL ktsR') where UnionLit keyR valR ktsR' = embedR r @@ -1225,7 +1226,7 @@ keyL = constructorModifier (Data.Text.pack (conName nL)) - declared = Union (Data.HashMap.Strict.InsOrd.insert keyL declaredL ktsR) + declared = Union (Dhall.Map.insert keyL declaredL ktsR) InputType embedL declaredL = evalState (genericInjectWith options) 1 InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1 @@ -1234,15 +1235,15 @@ genericInjectWith options = pure (InputType {..}) where embed (L1 l) = - UnionLit keyL valR (Data.HashMap.Strict.InsOrd.union ktsL' ktsR) + UnionLit keyL valR (Dhall.Map.union ktsL' ktsR) where UnionLit keyL valR ktsL' = embedL l embed (R1 r) = - UnionLit keyR valR (Data.HashMap.Strict.InsOrd.union ktsL ktsR') + UnionLit keyR valR (Dhall.Map.union ktsL ktsR') where UnionLit keyR valR ktsR' = embedR r - declared = Union (Data.HashMap.Strict.InsOrd.union ktsL ktsR) + declared = Union (Dhall.Map.union ktsL ktsR) InputType embedL (Union ktsL) = evalState (genericInjectWith options) 1 InputType embedR (Union ktsR) = evalState (genericInjectWith options) 1 @@ -1253,12 +1254,12 @@ InputType embedInR declaredInR <- genericInjectWith options let embed (l :*: r) = - RecordLit (Data.HashMap.Strict.InsOrd.union mapL mapR) + RecordLit (Dhall.Map.union mapL mapR) where RecordLit mapL = embedInL l RecordLit mapR = embedInR r - let declared = Record (Data.HashMap.Strict.InsOrd.union mapL mapR) + let declared = Record (Dhall.Map.union mapL mapR) where Record mapL = declaredInL Record mapR = declaredInR @@ -1268,17 +1269,17 @@ instance GenericInject U1 where genericInjectWith _ = pure (InputType {..}) where - embed _ = RecordLit Data.HashMap.Strict.InsOrd.empty + embed _ = RecordLit mempty - declared = Record Data.HashMap.Strict.InsOrd.empty + declared = Record mempty instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where genericInjectWith opts@(InterpretOptions {..}) = do name <- fieldModifier . Data.Text.pack <$> getSelName n let embed (M1 (K1 x)) = - RecordLit (Data.HashMap.Strict.InsOrd.singleton name (embedIn x)) + RecordLit (Dhall.Map.singleton name (embedIn x)) let declared = - Record (Data.HashMap.Strict.InsOrd.singleton name declaredIn) + Record (Dhall.Map.singleton name declaredIn) pure (InputType {..}) where n :: M1 i s f a @@ -1326,7 +1327,7 @@ RecordType ( Data.Functor.Product.Product ( Control.Applicative.Const - ( Data.HashMap.Strict.InsOrd.InsOrdHashMap + ( Dhall.Map.Map Text ( Expr Src X ) ) @@ -1359,14 +1360,14 @@ RecordLit fields <- return expr - Data.HashMap.Strict.InsOrd.lookup key fields + Dhall.Map.lookup key fields >>= extract valueType in RecordType ( Data.Functor.Product.Pair ( Control.Applicative.Const - ( Data.HashMap.Strict.InsOrd.singleton + ( Dhall.Map.singleton key ( Dhall.expected valueType ) ) @@ -1374,7 +1375,7 @@ ( Data.Functor.Compose.Compose extractBody ) ) -{-| The 'RecordInputType' divisible (contravariant) functor allows you to build +{-| The 'RecordInputType' divisible (contravariant) functor allows you to build an 'InputType' injector for a Dhall record. For example, let's take the following Haskell data type: @@ -1431,7 +1432,7 @@ infixr 5 >*< newtype RecordInputType a - = RecordInputType (Data.HashMap.Strict.InsOrd.InsOrdHashMap Text (InputType a)) + = RecordInputType (Dhall.Map.Map Text (InputType a)) instance Contravariant RecordInputType where contramap f (RecordInputType inputTypeRecord) = RecordInputType $ contramap f <$> inputTypeRecord @@ -1439,13 +1440,13 @@ instance Divisible RecordInputType where divide f (RecordInputType bInputTypeRecord) (RecordInputType cInputTypeRecord) = RecordInputType - $ Data.HashMap.Strict.InsOrd.union + $ Dhall.Map.union ((contramap $ fst . f) <$> bInputTypeRecord) ((contramap $ snd . f) <$> cInputTypeRecord) - conquer = RecordInputType Data.HashMap.Strict.InsOrd.empty + conquer = RecordInputType mempty inputFieldWith :: Text -> InputType a -> RecordInputType a -inputFieldWith name inputType = RecordInputType $ Data.HashMap.Strict.InsOrd.singleton name inputType +inputFieldWith name inputType = RecordInputType $ Dhall.Map.singleton name inputType inputField :: Inject a => Text -> RecordInputType a inputField name = inputFieldWith name inject diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -7,14 +7,14 @@ -} module Dhall.Binary - ( -- * Protocol versions - ProtocolVersion(..) - , defaultProtocolVersion - , parseProtocolVersion + ( -- * Standard versions + StandardVersion(..) + , defaultStandardVersion + , parseStandardVersion -- * Encoding and decoding - , encode - , decode + , encodeWithVersion + , decodeWithVersion -- * Exceptions , DecodingFailure(..) @@ -44,34 +44,35 @@ import Prelude hiding (exponent) import qualified Data.Foldable -import qualified Data.HashMap.Strict.InsOrd import qualified Data.Scientific import qualified Data.Sequence import qualified Data.Set import qualified Data.Text +import qualified Dhall.Map import qualified Options.Applicative --- | Supported protocol version strings -data ProtocolVersion - = V_1_0 - -- ^ Protocol version string "1.0" +-- | Supported version strings +data StandardVersion + = V_3_0_0 + -- ^ Version "3.0.0" -defaultProtocolVersion :: ProtocolVersion -defaultProtocolVersion = V_1_0 +defaultStandardVersion :: StandardVersion +defaultStandardVersion = V_3_0_0 -parseProtocolVersion :: Parser ProtocolVersion -parseProtocolVersion = - Options.Applicative.option readProtocolVersion - ( Options.Applicative.long "protocol-version" - <> Options.Applicative.metavar "X.Y" - <> Options.Applicative.value defaultProtocolVersion +parseStandardVersion :: Parser StandardVersion +parseStandardVersion = + Options.Applicative.option readVersion + ( Options.Applicative.long "standard-version" + <> Options.Applicative.metavar "X.Y.Z" + <> Options.Applicative.help "The standard version to use" + <> Options.Applicative.value defaultStandardVersion ) where - readProtocolVersion = do + readVersion = do string <- Options.Applicative.str case string :: Text of - "1.0" -> return V_1_0 - _ -> fail "Unsupported protocol version" + "3.0.0" -> return V_3_0_0 + _ -> fail "Unsupported version" {-| Convert a function applied to multiple arguments to the base function and the list of arguments @@ -86,244 +87,252 @@ ~(baseFunction, diffArguments) = go f go baseFunction = (baseFunction, id) -encode_1_0 :: Expr s Import -> Term -encode_1_0 (Var (V "_" n)) = +encode :: Expr s Import -> Term +encode (Var (V "_" n)) = TInteger n -encode_1_0 (Var (V x 0)) = +encode (Var (V x 0)) = TString x -encode_1_0 (Var (V x n)) = +encode (Var (V x n)) = TList [ TString x, TInteger n ] -encode_1_0 NaturalBuild = +encode NaturalBuild = TString "Natural/build" -encode_1_0 NaturalFold = +encode NaturalFold = TString "Natural/fold" -encode_1_0 NaturalIsZero = +encode NaturalIsZero = TString "Natural/isZero" -encode_1_0 NaturalEven = +encode NaturalEven = TString "Natural/even" -encode_1_0 NaturalOdd = +encode NaturalOdd = TString "Natural/odd" -encode_1_0 NaturalToInteger = +encode NaturalToInteger = TString "Natural/toInteger" -encode_1_0 NaturalShow = +encode NaturalShow = TString "Natural/show" -encode_1_0 IntegerToDouble = +encode IntegerToDouble = TString "Integer/toDouble" -encode_1_0 IntegerShow = +encode IntegerShow = TString "Integer/show" -encode_1_0 DoubleShow = +encode DoubleShow = TString "Double/show" -encode_1_0 ListBuild = +encode ListBuild = TString "List/build" -encode_1_0 ListFold = +encode ListFold = TString "List/fold" -encode_1_0 ListLength = +encode ListLength = TString "List/length" -encode_1_0 ListHead = +encode ListHead = TString "List/head" -encode_1_0 ListLast = +encode ListLast = TString "List/last" -encode_1_0 ListIndexed = +encode ListIndexed = TString "List/indexed" -encode_1_0 ListReverse = +encode ListReverse = TString "List/reverse" -encode_1_0 OptionalFold = +encode OptionalFold = TString "Optional/fold" -encode_1_0 OptionalBuild = +encode OptionalBuild = TString "Optional/build" -encode_1_0 Bool = +encode Bool = TString "Bool" -encode_1_0 Optional = +encode Optional = TString "Optional" -encode_1_0 Natural = +encode None = + TString "None" +encode Natural = TString "Natural" -encode_1_0 Integer = +encode Integer = TString "Integer" -encode_1_0 Double = +encode Double = TString "Double" -encode_1_0 Text = +encode Text = TString "Text" -encode_1_0 List = +encode List = TString "List" -encode_1_0 (Const Type) = +encode (Const Type) = TString "Type" -encode_1_0 (Const Kind) = +encode (Const Kind) = TString "Kind" -encode_1_0 e@(App _ _) = - TList ([ TInt 0, f₁ ] ++ map encode_1_0 arguments) +encode (Const Sort) = + TString "Sort" +encode e@(App _ _) = + TList ([ TInt 0, f₁ ] ++ map encode arguments) where (f₀, arguments) = unApply e - f₁ = encode_1_0 f₀ -encode_1_0 (Lam "_" _A₀ b₀) = + f₁ = encode f₀ +encode (Lam "_" _A₀ b₀) = TList [ TInt 1, _A₁, b₁ ] where - _A₁ = encode_1_0 _A₀ - b₁ = encode_1_0 b₀ -encode_1_0 (Lam x _A₀ b₀) = + _A₁ = encode _A₀ + b₁ = encode b₀ +encode (Lam x _A₀ b₀) = TList [ TInt 1, TString x, _A₁, b₁ ] where - _A₁ = encode_1_0 _A₀ - b₁ = encode_1_0 b₀ -encode_1_0 (Pi "_" _A₀ _B₀) = + _A₁ = encode _A₀ + b₁ = encode b₀ +encode (Pi "_" _A₀ _B₀) = TList [ TInt 2, _A₁, _B₁ ] where - _A₁ = encode_1_0 _A₀ - _B₁ = encode_1_0 _B₀ -encode_1_0 (Pi x _A₀ _B₀) = + _A₁ = encode _A₀ + _B₁ = encode _B₀ +encode (Pi x _A₀ _B₀) = TList [ TInt 2, TString x, _A₁, _B₁ ] where - _A₁ = encode_1_0 _A₀ - _B₁ = encode_1_0 _B₀ -encode_1_0 (BoolOr l₀ r₀) = + _A₁ = encode _A₀ + _B₁ = encode _B₀ +encode (BoolOr l₀ r₀) = TList [ TInt 3, TInt 0, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (BoolAnd l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (BoolAnd l₀ r₀) = TList [ TInt 3, TInt 1, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (BoolEQ l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (BoolEQ l₀ r₀) = TList [ TInt 3, TInt 2, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (BoolNE l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (BoolNE l₀ r₀) = TList [ TInt 3, TInt 3, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (NaturalPlus l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (NaturalPlus l₀ r₀) = TList [ TInt 3, TInt 4, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (NaturalTimes l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (NaturalTimes l₀ r₀) = TList [ TInt 3, TInt 5, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (TextAppend l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (TextAppend l₀ r₀) = TList [ TInt 3, TInt 6, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (ListAppend l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (ListAppend l₀ r₀) = TList [ TInt 3, TInt 7, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (Combine l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (Combine l₀ r₀) = TList [ TInt 3, TInt 8, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (Prefer l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (Prefer l₀ r₀) = TList [ TInt 3, TInt 9, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (CombineTypes l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (CombineTypes l₀ r₀) = TList [ TInt 3, TInt 10, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (ImportAlt l₀ r₀) = + l₁ = encode l₀ + r₁ = encode r₀ +encode (ImportAlt l₀ r₀) = TList [ TInt 3, TInt 11, l₁, r₁ ] where - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (ListLit _T₀ xs₀) + l₁ = encode l₀ + r₁ = encode r₀ +encode (ListLit _T₀ xs₀) | null xs₀ = TList [ TInt 4, _T₁ ] | otherwise = TList ([ TInt 4, TNull ] ++ xs₁) where _T₁ = case _T₀ of Nothing -> TNull - Just t -> encode_1_0 t + Just t -> encode t - xs₁ = map encode_1_0 (Data.Foldable.toList xs₀) -encode_1_0 (OptionalLit _T₀ Nothing) = + xs₁ = map encode (Data.Foldable.toList xs₀) +encode (OptionalLit _T₀ Nothing) = TList [ TInt 5, _T₁ ] where - _T₁ = encode_1_0 _T₀ -encode_1_0 (OptionalLit _T₀ (Just t₀)) = + _T₁ = encode _T₀ +encode (OptionalLit _T₀ (Just t₀)) = TList [ TInt 5, _T₁, t₁ ] where - _T₁ = encode_1_0 _T₀ - t₁ = encode_1_0 t₀ -encode_1_0 (Merge t₀ u₀ Nothing) = + _T₁ = encode _T₀ + t₁ = encode t₀ +encode (Some t₀) = + TList [ TInt 5, TNull, t₁ ] + where + t₁ = encode t₀ +encode (Merge t₀ u₀ Nothing) = TList [ TInt 6, t₁, u₁ ] where - t₁ = encode_1_0 t₀ - u₁ = encode_1_0 u₀ -encode_1_0 (Merge t₀ u₀ (Just _T₀)) = + t₁ = encode t₀ + u₁ = encode u₀ +encode (Merge t₀ u₀ (Just _T₀)) = TList [ TInt 6, t₁, u₁, _T₁ ] where - t₁ = encode_1_0 t₀ - u₁ = encode_1_0 u₀ - _T₁ = encode_1_0 _T₀ -encode_1_0 (Record xTs₀) = + t₁ = encode t₀ + u₁ = encode u₀ + _T₁ = encode _T₀ +encode (Record xTs₀) = TList [ TInt 7, TMap xTs₁ ] where xTs₁ = do - (x₀, _T₀) <- Data.HashMap.Strict.InsOrd.toList xTs₀ + (x₀, _T₀) <- Dhall.Map.toList xTs₀ let x₁ = TString x₀ - let _T₁ = encode_1_0 _T₀ + let _T₁ = encode _T₀ return (x₁, _T₁) -encode_1_0 (RecordLit xts₀) = +encode (RecordLit xts₀) = TList [ TInt 8, TMap xts₁ ] where xts₁ = do - (x₀, t₀) <- Data.HashMap.Strict.InsOrd.toList xts₀ + (x₀, t₀) <- Dhall.Map.toList xts₀ let x₁ = TString x₀ - let t₁ = encode_1_0 t₀ + let t₁ = encode t₀ return (x₁, t₁) -encode_1_0 (Field t₀ x) = +encode (Field t₀ x) = TList [ TInt 9, t₁, TString x ] where - t₁ = encode_1_0 t₀ -encode_1_0 (Project t₀ xs₀) = + t₁ = encode t₀ +encode (Project t₀ xs₀) = TList ([ TInt 10, t₁ ] ++ xs₁) where - t₁ = encode_1_0 t₀ + t₁ = encode t₀ xs₁ = map TString (Data.Foldable.toList xs₀) -encode_1_0 (Union xTs₀) = +encode (Union xTs₀) = TList [ TInt 11, TMap xTs₁ ] where xTs₁ = do - (x₀, _T₀) <- Data.HashMap.Strict.InsOrd.toList xTs₀ + (x₀, _T₀) <- Dhall.Map.toList xTs₀ let x₁ = TString x₀ - let _T₁ = encode_1_0 _T₀ + let _T₁ = encode _T₀ return (x₁, _T₁) -encode_1_0 (UnionLit x t₀ yTs₀) = +encode (UnionLit x t₀ yTs₀) = TList [ TInt 12, TString x, t₁, TMap yTs₁ ] where - t₁ = encode_1_0 t₀ + t₁ = encode t₀ yTs₁ = do - (y₀, _T₀) <- Data.HashMap.Strict.InsOrd.toList yTs₀ + (y₀, _T₀) <- Dhall.Map.toList yTs₀ let y₁ = TString y₀ - let _T₁ = encode_1_0 _T₀ + let _T₁ = encode _T₀ return (y₁, _T₁) -encode_1_0 (Constructors u₀) = +encode (Constructors u₀) = TList [ TInt 13, u₁ ] where - u₁ = encode_1_0 u₀ -encode_1_0 (BoolLit b) = + u₁ = encode u₀ +encode (BoolLit b) = TBool b -encode_1_0 (BoolIf t₀ l₀ r₀) = +encode (BoolIf t₀ l₀ r₀) = TList [ TInt 14, t₁, l₁, r₁ ] where - t₁ = encode_1_0 t₀ - l₁ = encode_1_0 l₀ - r₁ = encode_1_0 r₀ -encode_1_0 (NaturalLit n) = + t₁ = encode t₀ + l₁ = encode l₀ + r₁ = encode r₀ +encode (NaturalLit n) = TList [ TInt 15, TInteger (fromIntegral n) ] -encode_1_0 (IntegerLit n) = +encode (IntegerLit n) = TList [ TInt 16, TInteger n ] -encode_1_0 (DoubleLit n) = +encode (DoubleLit n) = TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ] where normalized = Data.Scientific.normalize n @@ -331,36 +340,36 @@ exponent = Data.Scientific.base10Exponent normalized mantissa = Data.Scientific.coefficient normalized -encode_1_0 (TextLit (Chunks xys₀ z₀)) = +encode (TextLit (Chunks xys₀ z₀)) = TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ]) where xys₁ = do (x₀, y₀) <- xys₀ let x₁ = TString x₀ - let y₁ = encode_1_0 y₀ + let y₁ = encode y₀ [ x₁, y₁ ] z₁ = TString z₀ -encode_1_0 (Embed x) = +encode (Embed x) = importToTerm x -encode_1_0 (Let x Nothing a₀ b₀) = +encode (Let x Nothing a₀ b₀) = TList [ TInt 25, TString x, a₁, b₁ ] where - a₁ = encode_1_0 a₀ - b₁ = encode_1_0 b₀ -encode_1_0 (Let x (Just _A₀) a₀ b₀) = + a₁ = encode a₀ + b₁ = encode b₀ +encode (Let x (Just _A₀) a₀ b₀) = TList [ TInt 25, TString x, _A₁, a₁, b₁ ] where - a₁ = encode_1_0 a₀ - _A₁ = encode_1_0 _A₀ - b₁ = encode_1_0 b₀ -encode_1_0 (Annot t₀ _T₀) = + a₁ = encode a₀ + _A₁ = encode _A₀ + b₁ = encode b₀ +encode (Annot t₀ _T₀) = TList [ TInt 26, t₁, _T₁ ] where - t₁ = encode_1_0 t₀ - _T₁ = encode_1_0 _T₀ -encode_1_0 (Note _ e) = - encode_1_0 e + t₁ = encode t₀ + _T₁ = encode _T₀ +encode (Note _ e) = + encode e importToTerm :: Import -> Term importToTerm import_ = @@ -408,96 +417,100 @@ ImportHashed {..} = importHashed -decode_1_0 :: Term -> Maybe (Expr s Import) -decode_1_0 (TInt n) = +decode :: Term -> Maybe (Expr s Import) +decode (TInt n) = return (Var (V "_" (fromIntegral n))) -decode_1_0 (TInteger n) = +decode (TInteger n) = return (Var (V "_" n)) -decode_1_0 (TString "Natural/build") = +decode (TString "Natural/build") = return NaturalBuild -decode_1_0 (TString "Natural/fold") = +decode (TString "Natural/fold") = return NaturalFold -decode_1_0 (TString "Natural/isZero") = +decode (TString "Natural/isZero") = return NaturalIsZero -decode_1_0 (TString "Natural/even") = +decode (TString "Natural/even") = return NaturalEven -decode_1_0 (TString "Natural/odd") = +decode (TString "Natural/odd") = return NaturalOdd -decode_1_0 (TString "Natural/toInteger") = +decode (TString "Natural/toInteger") = return NaturalToInteger -decode_1_0 (TString "Natural/show") = +decode (TString "Natural/show") = return NaturalShow -decode_1_0 (TString "Integer/toDouble") = +decode (TString "Integer/toDouble") = return IntegerToDouble -decode_1_0 (TString "Integer/show") = +decode (TString "Integer/show") = return IntegerShow -decode_1_0 (TString "Double/show") = +decode (TString "Double/show") = return DoubleShow -decode_1_0 (TString "List/build") = +decode (TString "List/build") = return ListBuild -decode_1_0 (TString "List/fold") = +decode (TString "List/fold") = return ListFold -decode_1_0 (TString "List/length") = +decode (TString "List/length") = return ListLength -decode_1_0 (TString "List/head") = +decode (TString "List/head") = return ListHead -decode_1_0 (TString "List/last") = +decode (TString "List/last") = return ListLast -decode_1_0 (TString "List/indexed") = +decode (TString "List/indexed") = return ListIndexed -decode_1_0 (TString "List/reverse") = +decode (TString "List/reverse") = return ListReverse -decode_1_0 (TString "Optional/fold") = +decode (TString "Optional/fold") = return OptionalFold -decode_1_0 (TString "Optional/build") = +decode (TString "Optional/build") = return OptionalBuild -decode_1_0 (TString "Bool") = +decode (TString "Bool") = return Bool -decode_1_0 (TString "Optional") = +decode (TString "Optional") = return Optional -decode_1_0 (TString "Natural") = +decode (TString "None") = + return None +decode (TString "Natural") = return Natural -decode_1_0 (TString "Integer") = +decode (TString "Integer") = return Integer -decode_1_0 (TString "Double") = +decode (TString "Double") = return Double -decode_1_0 (TString "Text") = +decode (TString "Text") = return Text -decode_1_0 (TString "List") = +decode (TString "List") = return List -decode_1_0 (TString "Type") = +decode (TString "Type") = return (Const Type) -decode_1_0 (TString "Kind") = +decode (TString "Kind") = return (Const Kind) -decode_1_0 (TString x) = +decode (TString "Sort") = + return (Const Sort) +decode (TString x) = return (Var (V x 0)) -decode_1_0 (TList [ TString x, TInt n ]) = +decode (TList [ TString x, TInt n ]) = return (Var (V x (fromIntegral n))) -decode_1_0 (TList [ TString x, TInteger n ]) = +decode (TList [ TString x, TInteger n ]) = return (Var (V x n)) -decode_1_0 (TList (TInt 0 : f₁ : xs₁)) = do - f₀ <- decode_1_0 f₁ - xs₀ <- traverse decode_1_0 xs₁ +decode (TList (TInt 0 : f₁ : xs₁)) = do + f₀ <- decode f₁ + xs₀ <- traverse decode xs₁ return (foldl App f₀ xs₀) -decode_1_0 (TList [ TInt 1, _A₁, b₁ ]) = do - _A₀ <- decode_1_0 _A₁ - b₀ <- decode_1_0 b₁ +decode (TList [ TInt 1, _A₁, b₁ ]) = do + _A₀ <- decode _A₁ + b₀ <- decode b₁ return (Lam "_" _A₀ b₀) -decode_1_0 (TList [ TInt 1, TString x, _A₁, b₁ ]) = do - _A₀ <- decode_1_0 _A₁ - b₀ <- decode_1_0 b₁ +decode (TList [ TInt 1, TString x, _A₁, b₁ ]) = do + _A₀ <- decode _A₁ + b₀ <- decode b₁ return (Lam x _A₀ b₀) -decode_1_0 (TList [ TInt 2, _A₁, _B₁ ]) = do - _A₀ <- decode_1_0 _A₁ - _B₀ <- decode_1_0 _B₁ +decode (TList [ TInt 2, _A₁, _B₁ ]) = do + _A₀ <- decode _A₁ + _B₀ <- decode _B₁ return (Pi "_" _A₀ _B₀) -decode_1_0 (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do - _A₀ <- decode_1_0 _A₁ - _B₀ <- decode_1_0 _B₁ +decode (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do + _A₀ <- decode _A₁ + _B₀ <- decode _B₁ return (Pi x _A₀ _B₀) -decode_1_0 (TList [ TInt 3, TInt n, l₁, r₁ ]) = do - l₀ <- decode_1_0 l₁ - r₀ <- decode_1_0 r₁ +decode (TList [ TInt 3, TInt n, l₁, r₁ ]) = do + l₀ <- decode l₁ + r₀ <- decode r₁ op <- case n of 0 -> return BoolOr 1 -> return BoolAnd @@ -513,31 +526,34 @@ 11 -> return ImportAlt _ -> empty return (op l₀ r₀) -decode_1_0 (TList [ TInt 4, _T₁ ]) = do - _T₀ <- decode_1_0 _T₁ +decode (TList [ TInt 4, _T₁ ]) = do + _T₀ <- decode _T₁ return (ListLit (Just _T₀) empty) -decode_1_0 (TList (TInt 4 : TNull : xs₁ )) = do - xs₀ <- traverse decode_1_0 xs₁ +decode (TList (TInt 4 : TNull : xs₁ )) = do + xs₀ <- traverse decode xs₁ return (ListLit Nothing (Data.Sequence.fromList xs₀)) -decode_1_0 (TList [ TInt 5, _T₁ ]) = do - _T₀ <- decode_1_0 _T₁ +decode (TList [ TInt 5, _T₁ ]) = do + _T₀ <- decode _T₁ return (OptionalLit _T₀ Nothing) -decode_1_0 (TList [ TInt 5, _T₁, t₁ ]) = do - _T₀ <- decode_1_0 _T₁ - t₀ <- decode_1_0 t₁ +decode (TList [ TInt 5, TNull, t₁ ]) = do + t₀ <- decode t₁ + return (Some t₀) +decode (TList [ TInt 5, _T₁, t₁ ]) = do + _T₀ <- decode _T₁ + t₀ <- decode t₁ return (OptionalLit _T₀ (Just t₀)) -decode_1_0 (TList [ TInt 6, t₁, u₁ ]) = do - t₀ <- decode_1_0 t₁ - u₀ <- decode_1_0 u₁ +decode (TList [ TInt 6, t₁, u₁ ]) = do + t₀ <- decode t₁ + u₀ <- decode u₁ return (Merge t₀ u₀ Nothing) -decode_1_0 (TList [ TInt 6, t₁, u₁, _T₁ ]) = do - t₀ <- decode_1_0 t₁ - u₀ <- decode_1_0 u₁ - _T₀ <- decode_1_0 _T₁ +decode (TList [ TInt 6, t₁, u₁, _T₁ ]) = do + t₀ <- decode t₁ + u₀ <- decode u₁ + _T₀ <- decode _T₁ return (Merge t₀ u₀ (Just _T₀)) -decode_1_0 (TList [ TInt 7, TMap xTs₁ ]) = do +decode (TList [ TInt 7, TMap xTs₁ ]) = do let process (TString x, _T₁) = do - _T₀ <- decode_1_0 _T₁ + _T₀ <- decode _T₁ return (x, _T₀) process _ = @@ -545,10 +561,10 @@ xTs₀ <- traverse process xTs₁ - return (Record (Data.HashMap.Strict.InsOrd.fromList xTs₀)) -decode_1_0 (TList [ TInt 8, TMap xts₁ ]) = do + return (Record (Dhall.Map.fromList xTs₀)) +decode (TList [ TInt 8, TMap xts₁ ]) = do let process (TString x, t₁) = do - t₀ <- decode_1_0 t₁ + t₀ <- decode t₁ return (x, t₀) process _ = @@ -556,13 +572,13 @@ xts₀ <- traverse process xts₁ - return (RecordLit (Data.HashMap.Strict.InsOrd.fromList xts₀)) -decode_1_0 (TList [ TInt 9, t₁, TString x ]) = do - t₀ <- decode_1_0 t₁ + return (RecordLit (Dhall.Map.fromList xts₀)) +decode (TList [ TInt 9, t₁, TString x ]) = do + t₀ <- decode t₁ return (Field t₀ x) -decode_1_0 (TList (TInt 10 : t₁ : xs₁)) = do - t₀ <- decode_1_0 t₁ +decode (TList (TInt 10 : t₁ : xs₁)) = do + t₀ <- decode t₁ let process (TString x) = return x process _ = empty @@ -570,9 +586,9 @@ xs₀ <- traverse process xs₁ return (Project t₀ (Data.Set.fromList xs₀)) -decode_1_0 (TList [ TInt 11, TMap xTs₁ ]) = do +decode (TList [ TInt 11, TMap xTs₁ ]) = do let process (TString x, _T₁) = do - _T₀ <- decode_1_0 _T₁ + _T₀ <- decode _T₁ return (x, _T₀) process _ = @@ -580,12 +596,12 @@ xTs₀ <- traverse process xTs₁ - return (Union (Data.HashMap.Strict.InsOrd.fromList xTs₀)) -decode_1_0 (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do - t₀ <- decode_1_0 t₁ + return (Union (Dhall.Map.fromList xTs₀)) +decode (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do + t₀ <- decode t₁ let process (TString y, _T₁) = do - _T₀ <- decode_1_0 _T₁ + _T₀ <- decode _T₁ return (y, _T₀) process _ = @@ -593,34 +609,34 @@ yTs₀ <- traverse process yTs₁ - return (UnionLit x t₀ (Data.HashMap.Strict.InsOrd.fromList yTs₀)) -decode_1_0 (TList [ TInt 13, u₁ ]) = do - u₀ <- decode_1_0 u₁ + return (UnionLit x t₀ (Dhall.Map.fromList yTs₀)) +decode (TList [ TInt 13, u₁ ]) = do + u₀ <- decode u₁ return (Constructors u₀) -decode_1_0 (TBool b) = do +decode (TBool b) = do return (BoolLit b) -decode_1_0 (TList [ TInt 14, t₁, l₁, r₁ ]) = do - t₀ <- decode_1_0 t₁ - l₀ <- decode_1_0 l₁ - r₀ <- decode_1_0 r₁ +decode (TList [ TInt 14, t₁, l₁, r₁ ]) = do + t₀ <- decode t₁ + l₀ <- decode l₁ + r₀ <- decode r₁ return (BoolIf t₀ l₀ r₀) -decode_1_0 (TList [ TInt 15, TInt n ]) = do +decode (TList [ TInt 15, TInt n ]) = do return (NaturalLit (fromIntegral n)) -decode_1_0 (TList [ TInt 15, TInteger n ]) = do +decode (TList [ TInt 15, TInteger n ]) = do return (NaturalLit (fromInteger n)) -decode_1_0 (TList [ TInt 16, TInt n ]) = do +decode (TList [ TInt 16, TInt n ]) = do return (IntegerLit (fromIntegral n)) -decode_1_0 (TList [ TInt 16, TInteger n ]) = do +decode (TList [ TInt 16, TInteger n ]) = do return (IntegerLit n) -decode_1_0 (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]) = do +decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInteger mantissa ]) ]) = do return (DoubleLit (Data.Scientific.scientific mantissa exponent)) -decode_1_0 (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInt mantissa ]) ]) = do +decode (TList [ TInt 17, TTagged 4 (TList [ TInt exponent, TInt mantissa ]) ]) = do return (DoubleLit (Data.Scientific.scientific (fromIntegral mantissa) exponent)) -decode_1_0 (TList (TInt 18 : xs)) = do +decode (TList (TInt 18 : xs)) = do let process (TString x : y₁ : zs) = do - y₀ <- decode_1_0 y₁ + y₀ <- decode y₁ ~(xys, z) <- process zs @@ -633,7 +649,7 @@ (xys, z) <- process xs return (TextLit (Chunks xys z)) -decode_1_0 (TList (TInt 24 : TInt n : xs)) = do +decode (TList (TInt 24 : TInt n : xs)) = do let remote scheme = do let process [ TString file, q, f ] = do query <- case q of @@ -706,59 +722,55 @@ let importHashed = ImportHashed {..} let importMode = Code return (Embed (Import {..})) -decode_1_0 (TList [ TInt 25, TString x, a₁, b₁ ]) = do - a₀ <- decode_1_0 a₁ - b₀ <- decode_1_0 b₁ +decode (TList [ TInt 25, TString x, a₁, b₁ ]) = do + a₀ <- decode a₁ + b₀ <- decode b₁ return (Let x Nothing a₀ b₀) -decode_1_0 (TList [ TInt 25, TString x, _A₁, a₁, b₁ ]) = do - _A₀ <- decode_1_0 _A₁ - a₀ <- decode_1_0 a₁ - b₀ <- decode_1_0 b₁ +decode (TList [ TInt 25, TString x, _A₁, a₁, b₁ ]) = do + _A₀ <- decode _A₁ + a₀ <- decode a₁ + b₀ <- decode b₁ return (Let x (Just _A₀) a₀ b₀) -decode_1_0 (TList [ TInt 26, t₁, _T₁ ]) = do - t₀ <- decode_1_0 t₁ - _T₀ <- decode_1_0 _T₁ +decode (TList [ TInt 26, t₁, _T₁ ]) = do + t₀ <- decode t₁ + _T₀ <- decode _T₁ return (Annot t₀ _T₀) -decode_1_0 _ = +decode _ = empty --- | Encode a Dhall expression using protocol version @1.0@ -encodeWithVersion_1_0 :: Expr s Import -> Term -encodeWithVersion_1_0 expression = - TList [ TString "1.0", encode_1_0 expression ] - {-| Decode a Dhall expression - This auto-detects whiich protocol version to decode based on the included - protocol version string in the decoded expression + This auto-detects which standard version to decode based on the included + standard version string in the decoded expression -} -decode :: Term -> Either DecodingFailure (Expr s Import) -decode term = do +decodeWithVersion :: Term -> Either DecodingFailure (Expr s Import) +decodeWithVersion term = do (version, subTerm) <- case term of TList [ TString version, subTerm ] -> return (version, subTerm) _ -> fail ("Cannot decode the version from this decoded CBOR expression: " <> show term) - maybeExpression <- case version of - "1.0" -> do - return (decode_1_0 subTerm) + case version of + "3.0.0" -> do + return () _ -> do fail ("This decoded version is not supported: " <> Data.Text.unpack version) - case maybeExpression of + case decode subTerm of Nothing -> fail ("This decoded CBOR expression does not represent a valid Dhall expression: " <> show subTerm) Just expression -> return expression --- | Encode a Dhall expression using the specified `ProtocolVersion` -encode :: ProtocolVersion -> Expr s Import -> Term -encode V_1_0 = encodeWithVersion_1_0 +-- | Encode a Dhall expression using the specified `Version` +encodeWithVersion :: StandardVersion -> Expr s Import -> Term +encodeWithVersion V_3_0_0 expression = + TList [ TString "3.0.0", encode expression ] data DecodingFailure - = CannotDecodeProtocolVersionString Term - | UnsupportedProtocolVersionString Text + = CannotDecodeVersionString Term + | UnsupportedVersionString Text | CBORIsNotDhall Term deriving (Eq) @@ -768,21 +780,21 @@ _ERROR = "\ESC[1;31mError\ESC[0m" instance Show DecodingFailure where - show (CannotDecodeProtocolVersionString term) = + show (CannotDecodeVersionString term) = _ERROR <> ": Cannot decode version string\n" <> "\n" - <> "This CBOR expression does not contain a protocol version string in any\n" + <> "This CBOR expression does not contain a version string in any\n" <> "recognizable format\n" <> "\n" <> "↳ " <> show term <> "\n" - show (UnsupportedProtocolVersionString version) = + show (UnsupportedVersionString version) = _ERROR <> ": Unsupported version string\n" <> "\n" - <> "The encoded Dhall expression was tagged with a protocol version string of:\n" + <> "The encoded Dhall expression was tagged with a version string of:\n" <> "\n" <> "↳ " <> show version <> "\n" <> "\n" - <> "... but this implementation cannot decode that protocol version\n" + <> "... but this implementation cannot decode that version\n" <> "\n" <> "Some common reasons why you might get this error:\n" <> "\n" diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -64,8 +64,6 @@ import Data.Bifunctor (Bifunctor(..)) import Data.Data (Data) import Data.Foldable -import Data.Hashable (Hashable) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.HashSet (HashSet) import Data.String (IsString(..)) import Data.Scientific (Scientific) @@ -75,6 +73,7 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty) import Data.Traversable +import Dhall.Map (Map) import {-# SOURCE #-} Dhall.Pretty.Internal import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -82,33 +81,35 @@ import qualified Control.Monad import qualified Crypto.Hash -import qualified Data.List -import qualified Data.HashMap.Strict.InsOrd import qualified Data.HashSet -import qualified Data.Ord import qualified Data.Sequence import qualified Data.Set import qualified Data.Text import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Dhall.Map {-| Constants for a pure type system - The only axiom is: + 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 (polymorphic functions) > ⊦ Kind ↝ Kind : Kind -- Functions from types to types (type constructors) +> ⊦ Sort ↝ Type : Type -- Functions from kinds to terms (kind-polymorphic functions) +> ⊦ Sort ↝ Kind : Kind -- Functions from kinds to types (polymorphic type constructors) +> ⊦ Sort ↝ Sort : Sort -- Functions from kinds to kinds (kind constructors) These are the same rule pairs as System Fω Note that Dhall does not support functions from terms to types and therefore Dhall is not a dependently typed language -} -data Const = Type | Kind deriving (Show, Eq, Data, Bounded, Enum, Generic) +data Const = Type | Kind | Sort deriving (Show, Eq, Data, Bounded, Enum, Generic) instance Pretty Const where pretty = Pretty.unAnnotate . prettyConst @@ -190,6 +191,13 @@ Remote (URL { path = path₀, ..}) <> Local Here path₁ = Remote (URL { path = path₀ <> path₁, ..}) + import₀ <> Remote (URL { headers = headers₀, .. }) = + Remote (URL { headers = headers₁, .. }) + where + importHashed₀ = ImportHashed Nothing import₀ + + headers₁ = fmap (importHashed₀ <>) headers₀ + _ <> import₁ = import₁ @@ -408,18 +416,22 @@ -- | > OptionalLit t (Just e) ~ [e] : Optional t -- > OptionalLit t Nothing ~ [] : Optional t | OptionalLit (Expr s a) (Maybe (Expr s a)) + -- | > 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 (InsOrdHashMap Text (Expr s a)) + | Record (Map Text (Expr s a)) -- | > RecordLit [(k1, v1), (k2, v2)] ~ { k1 = v1, k2 = v2 } - | RecordLit (InsOrdHashMap Text (Expr s a)) + | RecordLit (Map Text (Expr s a)) -- | > Union [(k1, t1), (k2, t2)] ~ < k1 : t1 | k2 : t2 > - | Union (InsOrdHashMap Text (Expr s a)) + | Union (Map Text (Expr s a)) -- | > UnionLit k v [(k1, t1), (k2, t2)] ~ < k = v | k1 : t1 | k2 : t2 > - | UnionLit Text (Expr s a) (InsOrdHashMap Text (Expr s a)) + | UnionLit Text (Expr s a) (Map Text (Expr s a)) -- | > Combine x y ~ x ∧ y | Combine (Expr s a) (Expr s a) -- | > CombineTypes x y ~ x ⩓ y @@ -441,8 +453,80 @@ | ImportAlt (Expr s a) (Expr s a) -- | > Embed import ~ import | Embed a - deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Data) + deriving (Eq, Foldable, Generic, Traversable, Show, Data) +-- 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 v maybeE e1 e2) = Let v (fmap (fmap f) maybeE) (fmap f e1) (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 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 _ 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 (OptionalLit e maybeE) = OptionalLit (fmap f e) (fmap (fmap f) maybeE) + 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 f) u) + fmap f (UnionLit v e u) = UnionLit v (fmap f e) (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 (Constructors e1) = Constructors (fmap f e1) + fmap f (Field e1 v) = Field (fmap f e1) v + fmap f (Project e1 vs) = Project (fmap f e1) vs + 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 @@ -498,6 +582,8 @@ ListReverse >>= _ = ListReverse Optional >>= _ = Optional OptionalLit a b >>= k = OptionalLit (a >>= k) (fmap (>>= k) b) + Some a >>= k = Some (a >>= k) + None >>= _ = None OptionalFold >>= _ = OptionalFold OptionalBuild >>= _ = OptionalBuild Record a >>= k = Record (fmap (>>= k) a) @@ -563,6 +649,8 @@ first _ ListReverse = ListReverse first _ Optional = Optional first k (OptionalLit a b ) = OptionalLit (first k a) (fmap (first k) b) + 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) @@ -790,6 +878,10 @@ where a' = shift d v a b' = fmap (shift d v) b +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' @@ -951,6 +1043,10 @@ where a' = subst x e a b' = fmap (subst x e) b +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 (fmap (subst x e) kts) @@ -1202,6 +1298,10 @@ _T₁ = alphaNormalize _T₀ ts₁ = fmap alphaNormalize ts₀ +alphaNormalize (Some a₀) = Some a₁ + where + a₁ = alphaNormalize a₀ +alphaNormalize None = None alphaNormalize OptionalFold = OptionalFold alphaNormalize OptionalBuild = @@ -1358,6 +1458,8 @@ denote ListReverse = ListReverse denote Optional = Optional denote (OptionalLit a b ) = OptionalLit (denote a) (fmap denote b) +denote (Some a ) = Some (denote a) +denote None = None denote OptionalFold = OptionalFold denote OptionalBuild = OptionalBuild denote (Record a ) = Record (fmap denote a) @@ -1374,12 +1476,6 @@ denote (ImportAlt a b ) = ImportAlt (denote a) (denote b) denote (Embed a ) = Embed a -sortMap :: (Ord k, Hashable k) => InsOrdHashMap k v -> InsOrdHashMap k v -sortMap = - Data.HashMap.Strict.InsOrd.fromList - . Data.List.sortBy (Data.Ord.comparing fst) - . Data.HashMap.Strict.InsOrd.toList - {-| Reduce an expression to its normal form, performing beta reduction and applying any custom definitions. @@ -1456,13 +1552,11 @@ App (App OptionalBuild _A₀) g -> loop (App (App (App g optional) just) nothing) where - _A₁ = shift 1 "a" _A₀ - optional = App Optional _A₀ - just = Lam "a" _A₀ (OptionalLit _A₁ (pure "a")) + just = Lam "a" _A₀ (Some "a") - nothing = OptionalLit _A₀ empty + nothing = App None _A₀ App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil) where _A₁ = shift 1 "a" _A₀ @@ -1490,21 +1584,21 @@ lazyCons y ys = App (App cons y) ys App (App ListLength _) (ListLit _ ys) -> NaturalLit (fromIntegral (Data.Sequence.length ys)) - App (App ListHead t) (ListLit _ ys) -> loop (OptionalLit t m) + App (App ListHead t) (ListLit _ ys) -> loop o where - m = case Data.Sequence.viewl ys of - y :< _ -> Just y - _ -> Nothing - App (App ListLast t) (ListLit _ ys) -> loop (OptionalLit t m) + o = case Data.Sequence.viewl ys of + y :< _ -> Some y + _ -> App None t + App (App ListLast t) (ListLit _ ys) -> loop o where - m = case Data.Sequence.viewr ys of - _ :> y -> Just y - _ -> Nothing + o = case Data.Sequence.viewr ys of + _ :> y -> Some y + _ -> App None t App (App ListIndexed _A₀) (ListLit _A₁ as₀) -> loop (ListLit t as₁) where as₁ = Data.Sequence.mapWithIndex adapt as₀ - _A₂ = Record (Data.HashMap.Strict.InsOrd.fromList kts) + _A₂ = Record (Dhall.Map.fromList kts) where kts = [ ("index", Natural) , ("value", _A₀) @@ -1514,7 +1608,7 @@ | otherwise = Nothing adapt n a_ = - RecordLit (Data.HashMap.Strict.InsOrd.fromList kvs) + RecordLit (Dhall.Map.fromList kvs) where kvs = [ ("index", NaturalLit (fromIntegral n)) , ("value", a_) @@ -1523,10 +1617,10 @@ loop (ListLit m (Data.Sequence.reverse xs)) where m = if Data.Sequence.null xs then Just t else Nothing - App (App (App (App (App OptionalFold _) (OptionalLit _ xs)) _) just) nothing -> - loop (maybe nothing just' xs) - where - just' = App just + App (App (App (App (App OptionalFold _) (App None _)) _) _) nothing -> + loop nothing + App (App (App (App (App OptionalFold _) (Some x)) _) just) _ -> + loop (App just x) _ -> case ctx (App f' a') of Nothing -> App f' a' Just app' -> loop app' @@ -1631,7 +1725,9 @@ decide (TextLit m) (TextLit n) = TextLit (m <> n) decide l r = TextAppend l r List -> List - ListLit t es -> ListLit t' es' + ListLit t es + | Data.Sequence.null es -> ListLit t' es' + | otherwise -> ListLit Nothing es' where t' = fmap loop t es' = fmap loop es @@ -1649,54 +1745,56 @@ ListIndexed -> ListIndexed ListReverse -> ListReverse Optional -> Optional - OptionalLit t es -> OptionalLit t' es' + OptionalLit _A Nothing -> loop (App None _A) + OptionalLit _ (Just a) -> loop (Some a) + Some a -> Some a' where - t' = loop t - es' = fmap loop es + a' = loop a + None -> None OptionalFold -> OptionalFold OptionalBuild -> OptionalBuild - Record kts -> Record (sortMap kts') + Record kts -> Record (Dhall.Map.sort kts') where kts' = fmap loop kts - RecordLit kvs -> RecordLit (sortMap kvs') + RecordLit kvs -> RecordLit (Dhall.Map.sort kvs') where kvs' = fmap loop kvs - Union kts -> Union (sortMap kts') + Union kts -> Union (Dhall.Map.sort kts') where kts' = fmap loop kts - UnionLit k v kvs -> UnionLit k v' (sortMap kvs') + UnionLit k v kvs -> UnionLit k v' (Dhall.Map.sort kvs') where v' = loop v kvs' = fmap loop kvs Combine x y -> decide (loop x) (loop y) where - decide (RecordLit m) r | Data.HashMap.Strict.InsOrd.null m = + decide (RecordLit m) r | Data.Foldable.null m = r - decide l (RecordLit n) | Data.HashMap.Strict.InsOrd.null n = + decide l (RecordLit n) | Data.Foldable.null n = l decide (RecordLit m) (RecordLit n) = - RecordLit (Data.HashMap.Strict.InsOrd.unionWith decide m n) + RecordLit (Dhall.Map.sort (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.HashMap.Strict.InsOrd.null m = + decide (Record m) r | Data.Foldable.null m = r - decide l (Record n) | Data.HashMap.Strict.InsOrd.null n = + decide l (Record n) | Data.Foldable.null n = l decide (Record m) (Record n) = - Record (Data.HashMap.Strict.InsOrd.unionWith decide m n) + Record (Dhall.Map.sort (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.HashMap.Strict.InsOrd.null m = + decide (RecordLit m) r | Data.Foldable.null m = r - decide l (RecordLit n) | Data.HashMap.Strict.InsOrd.null n = + decide l (RecordLit n) | Data.Foldable.null n = l decide (RecordLit m) (RecordLit n) = - RecordLit (Data.HashMap.Strict.InsOrd.union n m) + RecordLit (Dhall.Map.sort (Dhall.Map.union n m)) decide l r = Prefer l r Merge x y t -> @@ -1704,7 +1802,7 @@ RecordLit kvsX -> case y' of UnionLit kY vY _ -> - case Data.HashMap.Strict.InsOrd.lookup kY kvsX of + case Dhall.Map.lookup kY kvsX of Just vX -> loop (App vX vY) Nothing -> Merge x' y' t' _ -> Merge x' y' t' @@ -1717,18 +1815,18 @@ case t' of Union kts -> RecordLit kvs where - kvs = Data.HashMap.Strict.InsOrd.mapWithKey adapt kts + kvs = Dhall.Map.mapWithKey adapt kts adapt k t_ = Lam k t_ (UnionLit k (Var (V k 0)) rest) where - rest = Data.HashMap.Strict.InsOrd.delete k kts + rest = Dhall.Map.delete k kts _ -> Constructors t' where t' = loop t Field r x -> case loop r of RecordLit kvs -> - case Data.HashMap.Strict.InsOrd.lookup x kvs of + case Dhall.Map.lookup x kvs of Just v -> loop v Nothing -> Field (RecordLit (fmap loop kvs)) x r' -> Field r' x @@ -1739,12 +1837,12 @@ Just s -> loop (RecordLit kvs') where - kvs' = Data.HashMap.Strict.InsOrd.fromList s + kvs' = Dhall.Map.fromList s Nothing -> Project (RecordLit (fmap loop kvs)) xs where adapt x = do - v <- Data.HashMap.Strict.InsOrd.lookup x kvs + v <- Dhall.Map.lookup x kvs return (x, v) r' -> Project r' xs Note _ e' -> loop e' @@ -1779,194 +1877,200 @@ -- | Quickly check if an expression is in normal form isNormalized :: Eq a => Expr s a -> Bool -isNormalized e = case denote e of - Const _ -> True - Var _ -> True - Lam _ a b -> isNormalized a && isNormalized b - Pi _ a b -> isNormalized a && isNormalized b - App f a -> isNormalized f && isNormalized a && case App f a of - App (Lam _ _ _) _ -> False +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 `List` + App (App ListBuild _) (App (App ListFold _) _) -> False - -- build/fold fusion for `Natural` - App NaturalBuild (App NaturalFold _) -> False + -- build/fold fusion for `Natural` + App NaturalBuild (App NaturalFold _) -> False - -- build/fold fusion for `Optional` - App (App OptionalBuild _) (App (App OptionalFold _) _) -> False + -- build/fold fusion for `Optional` + App (App OptionalBuild _) (App (App OptionalFold _) _) -> False - App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False - App NaturalBuild _ -> False - App NaturalIsZero (NaturalLit _) -> False - App NaturalEven (NaturalLit _) -> False - App NaturalOdd (NaturalLit _) -> False - App NaturalShow (NaturalLit _) -> False - 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 (App (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 (App (App (App OptionalFold _) (OptionalLit _ _)) _) _) _ -> - False - _ -> True - Let _ _ _ _ -> False - Annot _ _ -> False - Bool -> True - BoolLit _ -> True - BoolAnd x y -> isNormalized x && isNormalized y && decide x y - where - decide (BoolLit _) _ = False - decide _ (BoolLit _) = False - decide l r = not (judgmentallyEqual l r) - BoolOr x y -> isNormalized x && isNormalized y && decide x y - where - decide (BoolLit _) _ = False - decide _ (BoolLit _) = False - decide l r = not (judgmentallyEqual l r) - BoolEQ x y -> isNormalized x && isNormalized y && decide x y - where - decide (BoolLit True) _ = False - decide _ (BoolLit True) = False - decide l r = not (judgmentallyEqual l r) - BoolNE x y -> isNormalized x && isNormalized y && decide x y - where - decide (BoolLit False) _ = False - decide _ (BoolLit False ) = False - decide l r = not (judgmentallyEqual l r) - BoolIf x y z -> - isNormalized x && isNormalized y && isNormalized z && decide x y z - where - decide (BoolLit _) _ _ = False - decide _ (BoolLit True) (BoolLit False) = False - decide _ l r = not (judgmentallyEqual l r) - Natural -> True - NaturalLit _ -> True - NaturalFold -> True - NaturalBuild -> True - NaturalIsZero -> True - NaturalEven -> True - NaturalOdd -> True - NaturalShow -> True - NaturalToInteger -> True - NaturalPlus x y -> isNormalized x && isNormalized y && decide x y - where - decide (NaturalLit 0) _ = False - decide _ (NaturalLit 0) = False - decide (NaturalLit _) (NaturalLit _) = False - decide _ _ = True - NaturalTimes x y -> isNormalized x && isNormalized 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 = isNormalized y && case y of - TextLit _ -> False - _ -> True - TextAppend x y -> isNormalized x && isNormalized y && decide x y - where - isEmpty (Chunks [] "") = True - isEmpty _ = False + App (App (App (App NaturalFold (NaturalLit _)) _) _) _ -> False + App NaturalBuild _ -> False + App NaturalIsZero (NaturalLit _) -> False + App NaturalEven (NaturalLit _) -> False + App NaturalOdd (NaturalLit _) -> False + App NaturalShow (NaturalLit _) -> False + 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 (App (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 (App (App (App OptionalFold _) (Some _)) _) _) _ -> + False + App (App (App (App (App OptionalFold _) (App None _)) _) _) _ -> + 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 (judgmentallyEqual l r) + BoolOr x y -> loop x && loop y && decide x y + where + decide (BoolLit _) _ = False + decide _ (BoolLit _) = False + decide l r = not (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 (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 (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 (judgmentallyEqual l r) + Natural -> True + NaturalLit _ -> True + NaturalFold -> True + NaturalBuild -> True + NaturalIsZero -> True + NaturalEven -> True + NaturalOdd -> True + NaturalShow -> 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 x y -> loop x && loop y && decide x y + where + isEmpty (Chunks [] "") = True + isEmpty _ = False - decide (TextLit m) _ | isEmpty m = False - decide _ (TextLit n) | isEmpty n = False - decide (TextLit _) (TextLit _) = False - decide _ _ = True - List -> True - ListLit t es -> all isNormalized t && all isNormalized es - ListAppend x y -> isNormalized x && isNormalized 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 - OptionalLit t es -> isNormalized t && all isNormalized es - OptionalFold -> True - OptionalBuild -> True - Record kts -> all isNormalized kts - RecordLit kvs -> all isNormalized kvs - Union kts -> all isNormalized kts - UnionLit _ v kvs -> isNormalized v && all isNormalized kvs - Combine x y -> isNormalized x && isNormalized y && decide x y - where - decide (RecordLit m) _ | Data.HashMap.Strict.InsOrd.null m = False - decide _ (RecordLit n) | Data.HashMap.Strict.InsOrd.null n = False - decide (RecordLit _) (RecordLit _) = False - decide _ _ = True - CombineTypes x y -> isNormalized x && isNormalized y && decide x y - where - decide (Record m) _ | Data.HashMap.Strict.InsOrd.null m = False - decide _ (Record n) | Data.HashMap.Strict.InsOrd.null n = False - decide (Record _) (Record _) = False - decide _ _ = True - Prefer x y -> isNormalized x && isNormalized y && decide x y - where - decide (RecordLit m) _ | Data.HashMap.Strict.InsOrd.null m = False - decide _ (RecordLit n) | Data.HashMap.Strict.InsOrd.null n = False - decide (RecordLit _) (RecordLit _) = False - decide _ _ = True - Merge x y t -> isNormalized x && isNormalized y && all isNormalized t && - case x of - RecordLit kvsX -> - case y of - UnionLit kY _ _ -> - case Data.HashMap.Strict.InsOrd.lookup kY kvsX of - Just _ -> False - Nothing -> True - _ -> True - _ -> True - Constructors t -> isNormalized t && - case t of - Union _ -> False - _ -> True + decide (TextLit m) _ | isEmpty m = False + decide _ (TextLit n) | isEmpty n = False + decide (TextLit _) (TextLit _) = False + decide _ _ = 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 + OptionalLit _ _ -> False + 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 loop kts + UnionLit _ v kvs -> loop v && Dhall.Map.isSorted kvs && all loop kvs + 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 _ _ = True + Merge x y t -> loop x && loop y && all loop t && + case x of + RecordLit kvsX -> + case y of + UnionLit kY _ _ -> + case Dhall.Map.lookup kY kvsX of + Just _ -> False + Nothing -> True + _ -> True + _ -> True + Constructors t -> loop t && + case t of + Union _ -> False + _ -> True - Field r x -> isNormalized r && - case r of - RecordLit kvs -> - case Data.HashMap.Strict.InsOrd.lookup x kvs of - Just _ -> False - Nothing -> True - _ -> True - Project r xs -> isNormalized r && - case r of - RecordLit kvs -> - if all (flip Data.HashMap.Strict.InsOrd.member kvs) xs - then False - else True - _ -> True - Note _ e' -> isNormalized e' - ImportAlt l _r -> isNormalized l - Embed _ -> True + Field r x -> loop r && + case r of + RecordLit kvs -> + case Dhall.Map.lookup x kvs of + Just _ -> False + Nothing -> True + _ -> True + Project r xs -> loop r && + case r of + RecordLit kvs -> + if all (flip Dhall.Map.member kvs) xs + then False + else True + _ -> True + Note _ e' -> loop e' + ImportAlt l _r -> loop l + Embed _ -> True {-| Detect if the given variable is free within the given expression @@ -2017,6 +2121,7 @@ , "in" , "Type" , "Kind" + , "Sort" , "forall" , "Bool" , "True" @@ -2051,6 +2156,8 @@ , "List/indexed" , "List/reverse" , "Optional" + , "Some" + , "None" , "Optional/build" , "Optional/fold" ] diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -17,7 +17,6 @@ import Data.Foldable (fold, toList) import Data.Function (on) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Any(..)) import Data.Scientific (Scientific) @@ -28,16 +27,17 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Dhall.Core (Chunks (..), Const(..), Expr(..), Var(..)) +import Dhall.Map (Map) import Dhall.Pretty.Internal (Ann) import Numeric.Natural (Natural) import qualified Data.Algorithm.Diff as Algo.Diff -import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.List.NonEmpty import qualified Data.Set import qualified Data.Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Dhall.Core +import qualified Dhall.Map import qualified Dhall.Pretty.Internal as Internal data Diff = @@ -115,10 +115,10 @@ equals = token Internal.equals forall :: Diff -forall = token Internal.forall +forall = token (Internal.forall Internal.Unicode) lambda :: Diff -lambda = token Internal.lambda +lambda = token (Internal.lambda Internal.Unicode) langle :: Diff langle = token Internal.langle @@ -139,7 +139,7 @@ rangle = token Internal.rangle rarrow :: Diff -rarrow = token Internal.rarrow +rarrow = token (Internal.rarrow Internal.Unicode) rbrace :: Diff rbrace = token Internal.rbrace @@ -161,7 +161,7 @@ diff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann diff l0 r0 = doc where - Diff {..} = diffExpression l0 r0 <> hardline + Diff {..} = diffExpression l0 r0 diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff diffPrimitive f l r @@ -248,14 +248,14 @@ diffKeyVals :: (Eq a, Pretty a) => Diff - -> InsOrdHashMap Text (Expr s a) - -> InsOrdHashMap Text (Expr s a) + -> Map Text (Expr s a) + -> Map Text (Expr s a) -> [Diff] diffKeyVals assign kvsL kvsR = diffFieldNames <> diffFieldValues <> (if anyEqual then [ ignore ] else []) where - ksL = Data.Set.fromList (HashMap.keys kvsL) - ksR = Data.Set.fromList (HashMap.keys kvsR) + ksL = Data.Set.fromList (Dhall.Map.keys kvsL) + ksR = Data.Set.fromList (Dhall.Map.keys kvsR) extraL = Data.Set.difference ksL ksR extraR = Data.Set.difference ksR ksL @@ -270,10 +270,10 @@ <> ignore ] - shared = HashMap.intersectionWith diffExpression kvsL kvsR + shared = Dhall.Map.intersectionWith diffExpression kvsL kvsR diffFieldValues = - filter (not . same) (HashMap.foldMapWithKey adapt shared) + filter (not . same) (Dhall.Map.foldMapWithKey adapt shared) where adapt key doc = [ (if ksL == ksR then mempty else " ") @@ -391,17 +391,17 @@ diffRecord :: (Eq a, Pretty a) - => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff + => Map Text (Expr s a) -> Map Text (Expr s a) -> Diff diffRecord kvsL kvsR = braced (diffKeyVals colon kvsL kvsR) diffRecordLit :: (Eq a, Pretty a) - => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff + => Map Text (Expr s a) -> Map Text (Expr s a) -> Diff diffRecordLit kvsL kvsR = braced (diffKeyVals equals kvsL kvsR) diffUnion :: (Eq a, Pretty a) - => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff + => Map Text (Expr s a) -> Map Text (Expr s a) -> Diff diffUnion kvsL kvsR = angled (diffKeyVals colon kvsL kvsR) diffUnionLit @@ -410,8 +410,8 @@ -> Text -> Expr s a -> Expr s a - -> InsOrdHashMap Text (Expr s a) - -> InsOrdHashMap Text (Expr s a) + -> Map Text (Expr s a) + -> Map Text (Expr s a) -> Diff diffUnionLit kL kR vL vR kvsL kvsR = langle @@ -461,6 +461,12 @@ skeleton (App Optional _) = "Optional " <> ignore +skeleton (App None _) = + "None " + <> ignore +skeleton (Some _) = + "Some " + <> ignore skeleton (App List _) = "List " <> ignore @@ -965,22 +971,34 @@ Data.List.NonEmpty.cons (diffImportExpression bL bR) (docs aL aR) docs (Constructors aL) (Constructors aR) = diffImportExpression aL aR :| [ keyword "constructors" ] - docs aL@(App {}) aR@(Constructors {}) = + docs aL aR@(Constructors {}) = pure (mismatch aL aR) - docs aL@(Constructors {}) aR@(App {}) = + docs aL@(Constructors {}) aR = pure (mismatch aL aR) + docs (Some aL) (Some aR) = + diffImportExpression aL aR :| [ builtin "Some" ] + docs aL aR@(Some {}) = + pure (mismatch aL aR) + docs aL@(Some {}) aR = + pure (mismatch aL aR) docs aL aR = pure (diffImportExpression aL aR) diffApplicationExpression l@(App {}) r = mismatch l r diffApplicationExpression l r@(App {}) = mismatch l r -diffApplicationExpression l@(Constructors {}) r@(Constructors {}) = +diffApplicationExpression (Constructors l) (Constructors r) = enclosed' mempty mempty (keyword "constructors" :| [ diffImportExpression l r ]) diffApplicationExpression l@(Constructors {}) r = mismatch l r diffApplicationExpression l r@(Constructors {}) = mismatch l r +diffApplicationExpression (Some l) (Some r) = + enclosed' mempty mempty (builtin "Some" :| [ diffImportExpression l r ]) +diffApplicationExpression l@(Some {}) r = + mismatch l r +diffApplicationExpression l r@(Some {}) = + mismatch l r diffApplicationExpression l r = diffImportExpression l r @@ -1187,6 +1205,12 @@ diffPrimitiveExpression l@Optional r = mismatch l r diffPrimitiveExpression l r@Optional = + mismatch l r +diffPrimitiveExpression None None = + "…" +diffPrimitiveExpression l@None r = + mismatch l r +diffPrimitiveExpression l r@None = mismatch l r diffPrimitiveExpression OptionalFold OptionalFold = "…" diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -8,7 +8,7 @@ ) where import Dhall.Parser (exprAndHeaderFromText) -import Dhall.Pretty (annToAnsiStyle, prettyExpr, layoutOpts) +import Dhall.Pretty (CharacterSet(..), annToAnsiStyle, layoutOpts) import Data.Monoid ((<>)) @@ -16,16 +16,18 @@ import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import qualified Control.Exception import qualified Data.Text.IO +import qualified Dhall.Pretty import qualified System.Console.ANSI import qualified System.IO -- | Implementation of the @dhall format@ subcommand format - :: Maybe FilePath + :: CharacterSet + -> Maybe FilePath -- ^ Modify file in-place if present, otherwise read from @stdin@ and write -- to @stdout@ -> IO () -format inplace = do +format characterSet inplace = do case inplace of Just file -> do text <- Data.Text.IO.readFile file @@ -33,7 +35,8 @@ Left err -> Control.Exception.throwIO err Right x -> return x - let doc = Pretty.pretty header <> Pretty.pretty expr + let doc = Pretty.pretty header + <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) System.IO.withFile file System.IO.WriteMode (\handle -> do Pretty.renderIO handle (Pretty.layoutSmart layoutOpts doc) Data.Text.IO.hPutStrLn handle "" ) @@ -44,7 +47,8 @@ Left err -> Control.Exception.throwIO err Right x -> return x - let doc = Pretty.pretty header <> prettyExpr expr + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet expr supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -8,14 +8,16 @@ , hashImport ) where +import Control.Exception (SomeException) import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import Data.Text -import Dhall.Binary (ProtocolVersion(..)) +import Dhall.Binary (StandardVersion(..)) import Dhall.Core (Expr(..), Import(..), ImportHashed(..)) -import Dhall.Import (hashExpression, protocolVersion) +import Dhall.Import (standardVersion) import Dhall.Parser (exprAndHeaderFromText, Src) import Dhall.Pretty (annToAnsiStyle, layoutOpts) +import Dhall.TypeCheck (X) import Lens.Family (set) import System.Console.ANSI (hSupportsANSI) @@ -27,19 +29,36 @@ import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.TypeCheck +import qualified System.FilePath import qualified System.IO -readInput :: Maybe FilePath -> IO Text -readInput = maybe Data.Text.IO.getContents Data.Text.IO.readFile - -- | Retrieve an `Import` and update the hash to match the latest contents -hashImport :: ProtocolVersion -> Import -> IO Import -hashImport _protocolVersion import_ = do - let status = - set protocolVersion _protocolVersion (Dhall.Import.emptyStatus ".") +hashImport + :: FilePath + -- ^ Current working directory + -> StandardVersion + -> Import + -> IO Import +hashImport directory _standardVersion import_ = do + let unprotectedImport = + import_ + { importHashed = + (importHashed import_) + { hash = Nothing + } + } + let status = set standardVersion _standardVersion (Dhall.Import.emptyStatus directory) - expression <- State.evalStateT (Dhall.Import.loadWith (Embed import_)) status + let download = + State.evalStateT (Dhall.Import.loadWith (Embed import_)) status + -- Try again without the semantic integrity check if decoding fails + let handler :: SomeException -> IO (Expr Src X) + handler _ = do + State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status + + expression <- Control.Exception.handle handler download + case Dhall.TypeCheck.typeOf expression of Left exception -> Control.Exception.throwIO exception Right _ -> return () @@ -48,12 +67,16 @@ Dhall.Core.alphaNormalize (Dhall.Core.normalize expression) let expressionHash = - Just (Dhall.Import.hashExpression _protocolVersion normalizedExpression) + Just (Dhall.Import.hashExpression _standardVersion normalizedExpression) let newImportHashed = (importHashed import_) { hash = expressionHash } - return $ import_ { importHashed = newImportHashed } + let newImport = import_ { importHashed = newImportHashed } + State.evalStateT (Dhall.Import.exprToImport newImport normalizedExpression) status + + return newImport + parseExpr :: String -> Text -> IO (Text, Expr Src Import) parseExpr src txt = case exprAndHeaderFromText src txt of @@ -67,28 +90,39 @@ case inplace of Just f -> - System.IO.withFile f System.IO.WriteMode (\h -> - Pretty.renderIO h (annToAnsiStyle <$> stream)) + System.IO.withFile f System.IO.WriteMode (\handle -> do + Pretty.renderIO handle (annToAnsiStyle <$> stream) + Data.Text.IO.hPutStrLn handle "" ) Nothing -> do supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout - if supportsANSI - then + if supportsANSI + then Pretty.renderIO System.IO.stdout (annToAnsiStyle <$> Pretty.layoutSmart layoutOpts doc) else - Pretty.renderIO System.IO.stdout (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) + Pretty.renderIO System.IO.stdout (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) -- | Implementation of the @dhall freeze@ subcommand freeze :: Maybe FilePath -- ^ Modify file in-place if present, otherwise read from @stdin@ and write -- to @stdout@ - -> ProtocolVersion + -> StandardVersion -> IO () -freeze inplace _protocolVersion = do - text <- readInput inplace +freeze inplace _standardVersion = do + (text, directory) <- case inplace of + Nothing -> do + text <- Data.Text.IO.getContents + + return (text, ".") + + Just file -> do + text <- Data.Text.IO.readFile file + + return (text, System.FilePath.takeDirectory file) + (header, parsedExpression) <- parseExpr srcInfo text - frozenExpression <- traverse (hashImport _protocolVersion) parsedExpression + frozenExpression <- traverse (hashImport directory _standardVersion) parsedExpression writeExpr inplace (header, frozenExpression) where srcInfo = fromMaybe "(stdin)" inplace diff --git a/src/Dhall/Hash.hs b/src/Dhall/Hash.hs --- a/src/Dhall/Hash.hs +++ b/src/Dhall/Hash.hs @@ -7,9 +7,9 @@ hash ) where -import Dhall.Binary (ProtocolVersion) +import Dhall.Binary (StandardVersion) import Dhall.Parser (exprFromText) -import Dhall.Import (hashExpressionToCode, protocolVersion) +import Dhall.Import (hashExpressionToCode, standardVersion) import Lens.Family (set) import qualified Control.Monad.Trans.State.Strict as State @@ -20,8 +20,8 @@ import qualified Data.Text.IO -- | Implementation of the @dhall hash@ subcommand -hash :: ProtocolVersion -> IO () -hash _protocolVersion = do +hash :: StandardVersion -> IO () +hash _standardVersion = do inText <- Data.Text.IO.getContents parsedExpression <- case exprFromText "(stdin)" inText of @@ -29,7 +29,7 @@ Right parsedExpression -> return parsedExpression let status = - set protocolVersion _protocolVersion (Dhall.Import.emptyStatus ".") + set standardVersion _standardVersion (Dhall.Import.emptyStatus ".") resolvedExpression <- State.evalStateT (Dhall.Import.loadWith parsedExpression) status @@ -41,4 +41,4 @@ Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression) Data.Text.IO.putStrLn - (hashExpressionToCode _protocolVersion normalizedExpression) + (hashExpressionToCode _standardVersion normalizedExpression) diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -100,22 +101,26 @@ module Dhall.Import ( -- * Import exprFromImport + , exprToImport , load , loadWith , hashExpression , hashExpressionToCode + , assertNoImports , Status , emptyStatus , stack , cache , manager - , protocolVersion + , standardVersion , normalizer , startingContext , resolver + , cacher , Cycle(..) , ReferentiallyOpaque(..) , Imported(..) + , ImportResolutionDisabled(..) , PrettyHttpException(..) , MissingFile(..) , MissingEnvironmentVariable(..) @@ -124,7 +129,6 @@ import Control.Applicative (Alternative(..)) import Codec.CBOR.Term (Term) -import Control.Applicative (empty) import Control.Exception (Exception, SomeException, throwIO, toException) import Control.Monad (guard) import Control.Monad.Catch (throwM, MonadCatch(catch), catches, Handler(..)) @@ -141,7 +145,7 @@ #endif import Data.Typeable (Typeable) import System.FilePath (()) -import Dhall.Binary (ProtocolVersion(..)) +import Dhall.Binary (StandardVersion(..)) import Dhall.Core ( Expr(..) , Chunks(..) @@ -173,7 +177,6 @@ import qualified Data.ByteString.Lazy import qualified Data.CaseInsensitive import qualified Data.Foldable -import qualified Data.HashMap.Strict.InsOrd import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map import qualified Data.Text.Encoding @@ -181,6 +184,7 @@ import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core +import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck @@ -250,6 +254,7 @@ instance Show e => Show (Imported e) where show (Imported imports e) = concat (zipWith indent [0..] toDisplay) + ++ "\n" ++ show e where indent n import_ = @@ -371,7 +376,7 @@ Local prefix (canonicalize file) canonicalize (Remote (URL {..})) = - Remote (URL { path = canonicalize path, ..}) + Remote (URL { path = canonicalize path, headers = fmap canonicalize headers, ..}) canonicalize (Env name) = Env name @@ -404,8 +409,8 @@ :: Expr s a -> Maybe (CI Data.ByteString.ByteString, Data.ByteString.ByteString) toHeader (RecordLit m) = do - TextLit (Chunks [] keyText ) <- Data.HashMap.Strict.InsOrd.lookup "header" m - TextLit (Chunks [] valueText) <- Data.HashMap.Strict.InsOrd.lookup "value" m + TextLit (Chunks [] keyText ) <- Dhall.Map.lookup "header" m + TextLit (Chunks [] valueText) <- Dhall.Map.lookup "value" m let keyBytes = Data.Text.Encoding.encodeUtf8 keyText let valueBytes = Data.Text.Encoding.encodeUtf8 valueText return (Data.CaseInsensitive.mk keyBytes, valueBytes) @@ -434,87 +439,101 @@ <> "\n" <> "↳ " <> show actualHash <> "\n" +localToPath :: MonadIO io => FilePrefix -> File -> io FilePath +localToPath prefix file_ = liftIO $ do + let File {..} = file_ + + let Directory {..} = directory + + prefixPath <- case prefix of + Home -> do + Directory.getHomeDirectory + + Absolute -> do + return "/" + + Here -> do + Directory.getCurrentDirectory + + let cs = map Text.unpack (file : components) + + let cons component dir = dir component + + return (foldr cons prefixPath cs) + -- | Parse an expression from a `Import` containing a Dhall program exprFromImport :: Import -> StateT (Status IO) IO (Expr Src Import) -exprFromImport import_@(Import {..}) = do +exprFromImport here@(Import {..}) = do let ImportHashed {..} = importHashed - case hash of - Nothing -> do - exprFromUncachedImport import_ - - Just expectedHash -> do - Status {..} <- State.get + result <- Maybe.runMaybeT $ do + Just expectedHash <- return hash + cacheFile <- getCacheFile expectedHash + True <- liftIO (Directory.doesFileExist cacheFile) - result <- Maybe.runMaybeT (getCacheFile expectedHash) + bytesStrict <- liftIO (Data.ByteString.readFile cacheFile) - case result of - Just (Read, cacheFile) -> do - bytesStrict <- liftIO (Data.ByteString.readFile cacheFile) + let actualHash = Crypto.Hash.hash bytesStrict - let actualHash = Crypto.Hash.hash bytesStrict + if expectedHash == actualHash + then return () + else liftIO (Control.Exception.throwIO (HashMismatch {..})) - if expectedHash == actualHash - then return () - else liftIO (Control.Exception.throwIO (HashMismatch {..})) + let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict - let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict + term <- throws (Codec.Serialise.deserialiseOrFail bytesLazy) - term <- case Codec.Serialise.deserialiseOrFail bytesLazy of - Left exception -> - liftIO (Control.Exception.throwIO exception) + throws (Dhall.Binary.decodeWithVersion term) - Right term -> - return term + case result of + Just expression -> return expression + Nothing -> exprFromUncachedImport here - case Dhall.Binary.decode term of - Left exception -> - liftIO (Control.Exception.throwIO exception) +{-| Save an expression to the specified `Import` - Right expression -> - return expression + Currently this only works for cached imports and ignores other types of + imports, but could conceivably work for uncached imports in the future - Just (Write, cacheFile) -> do - expression <- exprFromUncachedImport import_ + The main reason for this more general type is for symmetry with + `exprFromImport` and to support doing more clever things in the future, + like doing \"the right thing\" for uncached imports (i.e. exporting + environment variables or creating files) +-} +exprToImport :: Import -> Expr Src X -> StateT (Status IO) IO () +exprToImport here expression = do + Status {..} <- State.get - let _stack' = NonEmpty.cons import_ _stack - zoom stack (State.put _stack') - resolvedExpression <- loadWith expression - zoom stack (State.put _stack) + let Import {..} = here - case Dhall.TypeCheck.typeWith _startingContext resolvedExpression of - Left _ -> do - return () + let ImportHashed {..} = importHashed - Right _ -> do - let normalizedExpression = - Dhall.Core.alphaNormalize - (Dhall.Core.normalizeWith - (getReifiedNormalizer _normalizer) - resolvedExpression - ) + _ <- Maybe.runMaybeT $ do + Just expectedHash <- return hash + cacheFile <- getCacheFile expectedHash - let bytes = - encodeExpression _protocolVersion normalizedExpression + _ <- throws (Dhall.TypeCheck.typeWith _startingContext expression) - let actualHash = Crypto.Hash.hash bytes + let normalizedExpression = + Dhall.Core.alphaNormalize + (Dhall.Core.normalizeWith + (getReifiedNormalizer _normalizer) + expression + ) - if expectedHash == actualHash - then return () - else liftIO (Control.Exception.throwIO (HashMismatch {..})) + let bytes = encodeExpression _standardVersion normalizedExpression - liftIO (Data.ByteString.writeFile cacheFile bytes) + let actualHash = Crypto.Hash.hash bytes - return expression + if expectedHash == actualHash + then return () + else liftIO (Control.Exception.throwIO (HashMismatch {..})) - Nothing -> do - exprFromUncachedImport import_ + liftIO (Data.ByteString.writeFile cacheFile bytes) -data CacheMode = Read | Write + return () getCacheFile - :: (Alternative m, MonadIO m) - => Crypto.Hash.Digest SHA256 -> m (CacheMode, FilePath) + :: (Alternative m, MonadIO m) => Crypto.Hash.Digest SHA256 -> m FilePath getCacheFile hash = do let assertDirectory directory = do let private = transform Directory.emptyPermissions @@ -544,7 +563,7 @@ liftIO (Directory.setPermissions directory private) - cacheDirectory <- liftIO $ Directory.getXdgDirectory Directory.XdgCache "" + cacheDirectory <- getCacheDirectory assertDirectory cacheDirectory @@ -554,41 +573,32 @@ let cacheFile = dhallDirectory show hash - cacheFileExists <- liftIO (Directory.doesPathExist cacheFile) + return cacheFile - if cacheFileExists - then do - True <- liftIO (Directory.doesFileExist cacheFile) +getCacheDirectory :: MonadIO io => io FilePath +#if MIN_VERSION_directory(1,2,3) +getCacheDirectory = liftIO (Directory.getXdgDirectory Directory.XdgCache "") +#else +getCacheDirectory = liftIO $ do + maybeXDGCacheHome <- System.Environment.lookupEnv "XDG_CACHE_HOME" - return (Read, cacheFile) + case maybeXDGCacheHome of + Nothing -> do + homeDirectory <- Directory.getHomeDirectory - else do - return (Write, cacheFile) + return (homeDirectory ".cache") + Just xdgCacheHome -> do + return xdgCacheHome +#endif + exprFromUncachedImport :: Import -> StateT (Status IO) IO (Expr Src Import) exprFromUncachedImport (Import {..}) = do let ImportHashed {..} = importHashed (path, text) <- case importType of - Local prefix (File {..}) -> liftIO $ do - let Directory {..} = directory - - prefixPath <- case prefix of - Home -> do - Directory.getHomeDirectory - - Absolute -> do - return "/" - - Here -> do - Directory.getCurrentDirectory - - let cs = map Text.unpack (file : components) - - let cons component dir = dir component - - let path = foldr cons prefixPath cs - + Local prefix file -> liftIO $ do + path <- localToPath prefix file exists <- Directory.doesFileExist path if exists @@ -621,7 +631,7 @@ expected = App List ( Record - ( Data.HashMap.Strict.InsOrd.fromList + ( Dhall.Map.fromList [("header", Text), ("value", Text)] ) ) @@ -680,7 +690,7 @@ -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status IO -emptyStatus = emptyStatusWith exprFromImport +emptyStatus = emptyStatusWith exprFromImport exprToImport {-| Generalized version of `load` @@ -749,6 +759,8 @@ expr'' <- loadWith expr' zoom stack (State.put imports) + _cacher here expr'' + -- Type-check expressions here for three separate reasons: -- -- * to verify that they are closed @@ -770,7 +782,7 @@ return () Just expectedHash -> do let actualHash = - hashExpression _protocolVersion (Dhall.Core.alphaNormalize expr) + hashExpression _standardVersion (Dhall.Core.alphaNormalize expr) if expectedHash == actualHash then return () @@ -830,6 +842,8 @@ ListIndexed -> pure ListIndexed ListReverse -> pure ListReverse Optional -> pure Optional + None -> pure None + Some a -> Some <$> loadWith a OptionalLit a b -> OptionalLit <$> loadWith a <*> mapM loadWith b OptionalFold -> pure OptionalFold OptionalBuild -> pure OptionalBuild @@ -851,23 +865,26 @@ load expression = State.evalStateT (loadWith expression) (emptyStatus ".") encodeExpression - :: forall s . ProtocolVersion -> Expr s X -> Data.ByteString.ByteString -encodeExpression _protocolVersion expression = bytesStrict + :: forall s . StandardVersion -> Expr s X -> Data.ByteString.ByteString +encodeExpression _standardVersion expression = bytesStrict where intermediateExpression :: Expr s Import intermediateExpression = fmap absurd expression term :: Term - term = Dhall.Binary.encode _protocolVersion intermediateExpression + term = + Dhall.Binary.encodeWithVersion + _standardVersion + intermediateExpression bytesLazy = Codec.Serialise.serialise term bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy -- | Hash a fully resolved expression -hashExpression :: ProtocolVersion -> Expr s X -> (Crypto.Hash.Digest SHA256) -hashExpression _protocolVersion expression = - Crypto.Hash.hash (encodeExpression _protocolVersion expression) +hashExpression :: StandardVersion -> Expr s X -> (Crypto.Hash.Digest SHA256) +hashExpression _standardVersion expression = + Crypto.Hash.hash (encodeExpression _standardVersion expression) {-| Convenience utility to hash a fully resolved expression and return the base-16 encoded hash with the @sha256:@ prefix @@ -875,6 +892,21 @@ In other words, the output of this function can be pasted into Dhall source code to add an integrity check to an import -} -hashExpressionToCode :: ProtocolVersion -> Expr s X -> Text -hashExpressionToCode _protocolVersion expr = - "sha256:" <> Text.pack (show (hashExpression _protocolVersion expr)) +hashExpressionToCode :: StandardVersion -> Expr s X -> Text +hashExpressionToCode _standardVersion expr = + "sha256:" <> Text.pack (show (hashExpression _standardVersion expr)) + +-- | A call to `assertNoImports` failed because there was at least one import +data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception) + +instance Show ImportResolutionDisabled where + show _ = "\nImport resolution is disabled" + +-- | Assert than an expression is import-free +assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src X) +assertNoImports expression = + throws (traverse (\_ -> Left ImportResolutionDisabled) expression) + +throws :: (Exception e, MonadIO io) => Either e a -> io a +throws (Left e) = liftIO (Control.Exception.throwIO e) +throws (Right a) = return a 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 @@ -10,7 +10,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Semigroup ((<>)) -import Dhall.Binary (ProtocolVersion(..)) +import Dhall.Binary (StandardVersion(..)) import Dhall.Context (Context) import Dhall.Core ( Directory (..) @@ -46,21 +46,24 @@ , _manager :: Maybe Dynamic -- ^ Cache for the HTTP `Manager` so that we only acquire it once - , _protocolVersion :: ProtocolVersion + , _standardVersion :: StandardVersion , _normalizer :: ReifiedNormalizer X , _startingContext :: Context (Expr Src X) , _resolver :: Import -> StateT (Status m) m (Expr Src Import) + + , _cacher :: Import -> Expr Src X -> StateT (Status m) m () } -- | Default starting `Status` that is polymorphic in the base `Monad` emptyStatusWith :: (Import -> StateT (Status m) m (Expr Src Import)) + -> (Import -> Expr Src X -> StateT (Status m) m ()) -> FilePath -> Status m -emptyStatusWith _resolver rootDirectory = Status {..} +emptyStatusWith _resolver _cacher rootDirectory = Status {..} where _stack = pure rootImport @@ -68,7 +71,7 @@ _manager = Nothing - _protocolVersion = Dhall.Binary.defaultProtocolVersion + _standardVersion = Dhall.Binary.defaultStandardVersion _normalizer = ReifiedNormalizer (const Nothing) @@ -100,9 +103,9 @@ manager :: Functor f => LensLike' f (Status m) (Maybe Dynamic) manager k s = fmap (\x -> s { _manager = x }) (k (_manager s)) -protocolVersion :: Functor f => LensLike' f (Status m) ProtocolVersion -protocolVersion k s = - fmap (\x -> s { _protocolVersion = x }) (k (_protocolVersion s)) +standardVersion :: Functor f => LensLike' f (Status m) StandardVersion +standardVersion k s = + fmap (\x -> s { _standardVersion = x }) (k (_standardVersion s)) normalizer :: Functor f => LensLike' f (Status m) (ReifiedNormalizer X) normalizer k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s)) @@ -115,6 +118,11 @@ :: Functor f => LensLike' f (Status m) (Import -> StateT (Status m) m (Expr Src Import)) resolver k s = fmap (\x -> s { _resolver = x }) (k (_resolver s)) + +cacher + :: Functor f + => LensLike' f (Status m) (Import -> Expr Src X -> StateT (Status m) m ()) +cacher k s = fmap (\x -> s { _cacher = x }) (k (_cacher s)) {-| This exception indicates that there was an internal error in Dhall's import-related logic diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -12,7 +12,10 @@ {-| Automatically improve a Dhall expression - Currently this only removes unused @let@ bindings + Currently this: + + * removes unused @let@ bindings + * switches legacy @List@-like @Optional@ literals to use @Some@ / @None@ instead -} lint :: Expr s Import -> Expr t Import lint expression = loop (Dhall.Core.denote expression) @@ -158,11 +161,16 @@ ListReverse loop Optional = Optional - loop (OptionalLit a b) = - OptionalLit a' b' + loop (Some a) = + Some a' where - a' = loop a - b' = fmap loop b + a' = loop a + loop None = + None + loop (OptionalLit _ (Just b)) = + loop (Some b) + loop (OptionalLit a Nothing) = + loop (App None a) loop OptionalFold = OptionalFold loop OptionalBuild = diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -22,23 +22,23 @@ import Control.Exception (Exception, SomeException) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) +import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Version (showVersion) -import Dhall.Binary (ProtocolVersion) +import Dhall.Binary (StandardVersion) import Dhall.Core (Expr(..), Import) import Dhall.Import (Imported(..)) import Dhall.Parser (Src) -import Dhall.Pretty (annToAnsiStyle, prettyExpr, layoutOpts) +import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts) import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) import Lens.Family (set) import Options.Applicative (Parser, ParserInfo) import System.Exit (exitFailure) import System.IO (Handle) -import qualified Paths_dhall as Meta - +import qualified Codec.Serialise import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.ByteString.Lazy import qualified Data.Text import qualified Data.Text.IO import qualified Data.Text.Prettyprint.Doc as Pretty @@ -53,10 +53,12 @@ import qualified Dhall.Import import qualified Dhall.Lint import qualified Dhall.Parser +import qualified Dhall.Pretty import qualified Dhall.Repl import qualified Dhall.TypeCheck import qualified GHC.IO.Encoding import qualified Options.Applicative +import qualified Paths_dhall as Meta import qualified System.Console.ANSI import qualified System.IO @@ -65,7 +67,8 @@ { mode :: Mode , explain :: Bool , plain :: Bool - , protocolVersion :: ProtocolVersion + , ascii :: Bool + , standardVersion :: StandardVersion } -- | The subcommands for the @dhall@ executable @@ -76,110 +79,110 @@ | Type | Normalize | Repl - | Format (Maybe FilePath) - | Freeze (Maybe FilePath) + | Format { inplace :: Maybe FilePath } + | Freeze { inplace :: Maybe FilePath } | Hash - | Diff Text Text - | Lint (Maybe FilePath) - -parseInplace :: Parser String -parseInplace = - Options.Applicative.strOption - ( Options.Applicative.long "inplace" - <> Options.Applicative.help "Modify the specified file in-place" - <> Options.Applicative.metavar "FILE" - ) + | Diff { expr1 :: Text, expr2 :: Text } + | Lint { inplace :: Maybe FilePath } + | Encode + | Decode -- | `Parser` for the `Options` type parseOptions :: Parser Options parseOptions = Options <$> parseMode - <*> parseExplain - <*> parsePlain - <*> Dhall.Binary.parseProtocolVersion + <*> switch "explain" "Explain error messages in more detail" + <*> switch "plain" "Disable syntax highlighting" + <*> switch "ascii" "Format code using only ASCII syntax" + <*> Dhall.Binary.parseStandardVersion where - parseExplain = + switch name description = Options.Applicative.switch - ( Options.Applicative.long "explain" - <> Options.Applicative.help "Explain error messages in more detail" + ( Options.Applicative.long name + <> Options.Applicative.help description ) - parsePlain = - Options.Applicative.switch - ( Options.Applicative.long "plain" - <> Options.Applicative.help "Disable syntax highlighting" +subcommand :: String -> String -> Parser a -> Parser a +subcommand name description parser = + Options.Applicative.hsubparser + ( Options.Applicative.command name parserInfo + <> Options.Applicative.metavar name + ) + where + parserInfo = + Options.Applicative.info parser + ( Options.Applicative.fullDesc + <> Options.Applicative.progDesc description ) - parseMode :: Parser Mode parseMode = - subcommand "version" "Display version" (pure Version) - <|> subcommand "resolve" "Resolve an expression's imports" (pure Resolve) - <|> subcommand "type" "Infer an expression's type" (pure Type) - <|> subcommand "normalize" "Normalize an expression" (pure Normalize) - <|> subcommand "repl" "Interpret expressions in a REPL" (pure Repl) - <|> subcommand "diff" "Render the difference between the normal form of two expressions" diffParser - <|> subcommand "hash" "Compute semantic hashes for Dhall expressions" (pure Hash) - <|> subcommand "lint" "Improve Dhall code" parseLint - <|> formatSubcommand - <|> freezeSubcommand - <|> parseDefault + subcommand + "version" + "Display version" + (pure Version) + <|> subcommand + "resolve" + "Resolve an expression's imports" + (pure Resolve) + <|> subcommand + "type" + "Infer an expression's type" + (pure Type) + <|> subcommand + "normalize" + "Normalize an expression" + (pure Normalize) + <|> subcommand + "repl" + "Interpret expressions in a REPL" + (pure Repl) + <|> subcommand + "diff" + "Render the difference between the normal form of two expressions" + (Diff <$> argument "expr1" <*> argument "expr2") + <|> subcommand + "hash" + "Compute semantic hashes for Dhall expressions" + (pure Hash) + <|> subcommand + "lint" + "Improve Dhall code" + (Lint <$> optional parseInplace) + <|> subcommand + "format" + "Formatter for the Dhall language" + (Format <$> optional parseInplace) + <|> subcommand + "freeze" + "Add hashes to all import statements of an expression" + (Freeze <$> optional parseInplace) + <|> subcommand + "encode" + "Encode a Dhall expression to binary" + (pure Encode) + <|> subcommand + "decode" + "Decode a Dhall expression from binary" + (pure Decode) + <|> (Default <$> parseAnnotate) where - subcommand name description modeParser = - Options.Applicative.subparser - ( Options.Applicative.command name parserInfo - <> Options.Applicative.metavar name - ) - where - parserInfo = - Options.Applicative.info parser - ( Options.Applicative.fullDesc - <> Options.Applicative.progDesc description - ) - - parser = - Options.Applicative.helper <*> modeParser - - diffParser = - Diff <$> argument "expr1" <*> argument "expr2" - where - argument = - fmap Data.Text.pack - . Options.Applicative.strArgument - . Options.Applicative.metavar - - parseLint = - Lint <$> optional parseInplace - - formatSubcommand = - Options.Applicative.hsubparser - ( Options.Applicative.command "format" parserInfo - <> Options.Applicative.metavar "format" - ) - where parserInfo = - Options.Applicative.info parserWithHelper - ( Options.Applicative.fullDesc - <> Options.Applicative.progDesc "Formatter for the Dhall language" - ) - parserWithHelper = Options.Applicative.helper <*> parser - parser = Format <$> optional parseInplace - - freezeSubcommand = subcommand "freeze" "Add hashes to all import statements of an expression" parseFreeze - where - parseFreeze = Freeze <$> optional parseInplace - - parseDefault = Default <$> parseAnnotate - where - parseAnnotate = - Options.Applicative.switch - ( Options.Applicative.long "annotate" - ) + argument = + fmap Data.Text.pack + . Options.Applicative.strArgument + . Options.Applicative.metavar -data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception) + parseAnnotate = + Options.Applicative.switch + (Options.Applicative.long "annotate") -instance Show ImportResolutionDisabled where - show _ = "\nImport resolution is disabled" + parseInplace = + Options.Applicative.strOption + ( Options.Applicative.long "inplace" + <> Options.Applicative.help "Modify the specified file in-place" + <> Options.Applicative.metavar "FILE" + ) throws :: Exception e => Either e a -> IO a throws (Left e) = Control.Exception.throwIO e @@ -191,10 +194,6 @@ throws (Dhall.Parser.exprFromText "(stdin)" inText) -assertNoImports :: Expr Src Import -> IO (Expr Src X) -assertNoImports expression = - throws (traverse (\_ -> Left ImportResolutionDisabled) expression) - -- | `ParserInfo` for the `Options` type parserInfoOptions :: ParserInfo Options parserInfoOptions = @@ -207,10 +206,14 @@ -- | Run the command specified by the `Options` type command :: Options -> IO () command (Options {..}) = do + let characterSet = case ascii of + True -> ASCII + False -> Unicode + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 let status = - set Dhall.Import.protocolVersion protocolVersion (Dhall.Import.emptyStatus ".") + set Dhall.Import.standardVersion standardVersion (Dhall.Import.emptyStatus ".") let handle = @@ -241,10 +244,8 @@ System.IO.hPrint System.IO.stderr e System.Exit.exitFailure - let render :: Pretty a => Handle -> Expr s a -> IO () - render h e = do - let doc = prettyExpr e - + let renderDoc :: Handle -> Doc Ann -> IO () + renderDoc h doc = do let stream = Pretty.layoutSmart layoutOpts doc supportsANSI <- System.Console.ANSI.hSupportsANSI h @@ -256,6 +257,12 @@ Pretty.renderIO h ansiStream Data.Text.IO.hPutStrLn h "" + let render :: Pretty a => Handle -> Expr s a -> IO () + render h expression = do + let doc = Dhall.Pretty.prettyCharacterSet characterSet expression + + renderDoc h doc + handle $ case mode of Version -> do putStrLn (showVersion Meta.version) @@ -286,7 +293,7 @@ Normalize -> do expression <- getExpression - resolvedExpression <- assertNoImports expression + resolvedExpression <- Dhall.Import.assertNoImports expression _ <- throws (Dhall.TypeCheck.typeOf resolvedExpression) @@ -295,35 +302,34 @@ Type -> do expression <- getExpression - resolvedExpression <- assertNoImports expression + resolvedExpression <- Dhall.Import.assertNoImports expression inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) render System.IO.stdout (Dhall.Core.normalize inferredType) Repl -> do - Dhall.Repl.repl explain protocolVersion + Dhall.Repl.repl characterSet explain standardVersion - Diff expr1 expr2 -> do + Diff {..} -> do expression1 <- Dhall.inputExpr expr1 expression2 <- Dhall.inputExpr expr2 let diff = Dhall.Diff.diffNormalized expression1 expression2 - prettyDiff = fmap annToAnsiStyle diff - Pretty.hPutDoc System.IO.stdout prettyDiff + renderDoc System.IO.stdout diff - Format inplace -> do - Dhall.Format.format inplace + Format {..} -> do + Dhall.Format.format characterSet inplace - Freeze inplace -> do - Dhall.Freeze.freeze inplace protocolVersion + Freeze {..} -> do + Dhall.Freeze.freeze inplace standardVersion Hash -> do - Dhall.Hash.hash protocolVersion + Dhall.Hash.hash standardVersion - Lint inplace -> do + Lint {..} -> do case inplace of Just file -> do text <- Data.Text.IO.readFile file @@ -332,11 +338,12 @@ let lintedExpression = Dhall.Lint.lint expression - let doc = Pretty.pretty header <> Pretty.pretty lintedExpression + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression System.IO.withFile file System.IO.WriteMode (\h -> do - Pretty.renderIO h (Pretty.layoutSmart layoutOpts doc) - Data.Text.IO.hPutStrLn h "" ) + renderDoc h doc ) + Nothing -> do text <- Data.Text.IO.getContents @@ -344,19 +351,31 @@ let lintedExpression = Dhall.Lint.lint expression - let doc = Pretty.pretty header <> prettyExpr lintedExpression + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression - supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout + renderDoc System.IO.stdout doc - if supportsANSI - then - Pretty.renderIO - System.IO.stdout - (fmap annToAnsiStyle (Pretty.layoutSmart layoutOpts doc)) - else - Pretty.renderIO - System.IO.stdout - (Pretty.layoutSmart layoutOpts (Pretty.unAnnotate doc)) + Encode -> do + expression <- getExpression + + let term = + Dhall.Binary.encodeWithVersion standardVersion expression + + let bytes = Codec.Serialise.serialise term + + Data.ByteString.Lazy.putStr bytes + + Decode -> do + bytes <- Data.ByteString.Lazy.getContents + + term <- throws (Codec.Serialise.deserialiseOrFail bytes) + + expression <- throws (Dhall.Binary.decodeWithVersion term) + + let doc = Dhall.Pretty.prettyCharacterSet characterSet expression + + renderDoc System.IO.stdout doc -- | Entry point for the @dhall@ executable main :: IO () diff --git a/src/Dhall/Map.hs b/src/Dhall/Map.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Map.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | `Map` type used to represent records and unions + +module Dhall.Map + ( -- * Type + Map + + -- * Construction + , singleton + , fromList + + -- * Sorting + , sort + , isSorted + + -- * Insertion + , insert + , insertWith + + -- * Deletion/Update + , delete + , filter + , mapMaybe + + -- * Query + , lookup + , member + , uncons + + -- * Combine + , union + , unionWith + , intersection + , intersectionWith + , difference + + -- * Traversals + , mapWithKey + , traverseWithKey + , traverseWithKey_ + , foldMapWithKey + + -- * Conversions + , toList + , toMap + , keys + ) where + +import Control.Applicative ((<|>)) +import Data.Data (Data) +import Data.Semigroup +import Prelude hiding (filter, lookup) + +import qualified Data.Functor +import qualified Data.Map +import qualified Data.Set +import qualified GHC.Exts +import qualified Prelude + +{-| A `Map` that remembers the original ordering of keys + + This is primarily used so that formatting preserves field order + + This is done primarily to avoid a dependency on @insert-ordered-containers@ + and also to improve performance +-} +data Map k v = Map (Data.Map.Map k v) [k] + deriving (Data) + +instance (Eq k, Eq v) => Eq (Map k v) where + (Map m1 ks) == (Map m2 ks') = m1 == m2 && ks == ks' + {-# INLINABLE (==) #-} + +instance Functor (Map k) where + fmap f (Map m ks) = Map (fmap f m) ks + {-# INLINABLE fmap #-} + +instance Foldable (Map k) where + foldr f z (Map m _) = foldr f z m + {-# INLINABLE foldr #-} + + foldMap f (Map m _) = foldMap f m + {-# INLINABLE foldMap #-} + +instance Traversable (Map k) where + traverse f (Map m ks) = (\m' -> Map m' ks) <$> traverse f m + {-# INLINABLE traverse #-} + +instance Ord k => Data.Semigroup.Semigroup (Map k v) where + (<>) = union + {-# INLINABLE (<>) #-} + +instance Ord k => Monoid (Map k v) where + mempty = Map Data.Map.empty [] + {-# INLINABLE mempty #-} + +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + {-# INLINABLE mappend #-} +#endif + +instance (Show k, Show v, Ord k) => Show (Map k v) where + showsPrec d m = + showParen (d > 10) (showString "fromList " . showsPrec 11 kvs) + where + kvs = toList m + +instance Ord k => GHC.Exts.IsList (Map k v) where + type Item (Map k v) = (k, v) + + fromList = Dhall.Map.fromList + + toList = Dhall.Map.toList + +{-| Create a `Map` from a single key-value pair + +>>> singleton "A" 1 +fromList [("A",1)] +-} +singleton :: k -> v -> Map k v +singleton k v = Map m ks + where + m = Data.Map.singleton k v + + ks = pure k +{-# INLINABLE singleton #-} + +{-| Create a `Map` from a list of key-value pairs + +> fromList empty = mempty +> +> fromList (x <|> y) = fromList x <> fromList y + +>>> fromList [("B",1),("A",2)] -- The map preserves order +fromList [("B",1),("A",2)] +>>> fromList [("A",1),("A",2)] -- For duplicates, later values take precedence +fromList [("A",2)] +-} +fromList :: Ord k => [(k, v)] -> Map k v +fromList kvs = Map m ks + where + m = Data.Map.fromList kvs + + ks = nubOrd (map fst kvs) +{-# INLINABLE fromList #-} + +{-| Remove duplicates from a list + +>>> nubOrd [1,2,3] +[1,2,3] +>>> nubOrd [1,1,3] +[1,3] +-} +nubOrd :: Ord k => [k] -> [k] +nubOrd = go Data.Set.empty + where + go _ [] = [] + go set (k:ks) + | Data.Set.member k set = go set ks + | otherwise = k : go (Data.Set.insert k set) ks +{-# INLINABLE nubOrd #-} + +{-| Sort the keys of a `Map`, forgetting the original ordering + +> sort (sort x) = sort x + +>>> sort (fromList [("B",1),("A",2)]) +fromList [("A",2),("B",1)] +-} +sort :: Ord k => Map k v -> Map k v +sort (Map m _) = Map m ks + where + ks = Data.Map.keys m +{-# INLINABLE sort #-} + +{-| Check if the keys of a `Map` are already sorted + +> isSorted (sort m) = True + +>>> isSorted (fromList [("B",1),("A",2)]) -- Sortedness is based only on keys +False +>>> isSorted (fromList [("A",2),("B",1)]) +True +-} +isSorted :: Eq k => Map k v -> Bool +isSorted (Map m k) = Data.Map.keys m == k +{-# INLINABLE isSorted #-} + +{-| Insert a key-value pair into a `Map`, overriding any previous value stored + underneath the same key, if present + +> insert = insertWith (\v _ -> v) + +>>> insert "C" 1 (fromList [("B",2),("A",3)]) -- Values are inserted on left +fromList [("C",1),("B",2),("A",3)] +>>> insert "C" 1 (fromList [("C",2),("A",3)]) -- New value takes precedence +fromList [("C",1),("A",3)] +-} +insert :: Ord k => k -> v -> Map k v -> Map k v +insert k v (Map m ks) = Map m' ks' + where + m' = Data.Map.insert k v m + + ks' | elem k ks = ks + | otherwise = k : ks +{-# INLINABLE insert #-} + +{-| Insert a key-value pair into a `Map`, using the supplied function to combine + the new value with any old value underneath the same key, if present + +>>> insertWith (+) "C" 1 (fromList [("B",2),("A",3)]) -- No collision +fromList [("C",1),("B",2),("A",3)] +>>> insertWith (+) "C" 1 (fromList [("C",2),("A",3)]) -- Collision +fromList [("C",3),("A",3)] +-} +insertWith :: Ord k => (v -> v -> v) -> k -> v -> Map k v -> Map k v +insertWith f k v (Map m ks) = Map m' ks' + where + m' = Data.Map.insertWith f k v m + + ks' | elem k ks = ks + | otherwise = k : ks +{-# INLINABLE insertWith #-} + +{-| Delete a key from a `Map` if present, otherwise return the original `Map` + +>>> delete "B" (fromList [("C",1),("B",2),("A",3)]) +fromList [("C",1),("A",3)] +>>> delete "D" (fromList [("C",1),("B",2),("A",3)]) +fromList [("C",1),("B",2),("A",3)] +-} +delete :: Ord k => k -> Map k v -> Map k v +delete k (Map m ks) = Map m' ks' + where + m' = Data.Map.delete k m + + ks' = Prelude.filter (k /=) ks +{-# INLINABLE delete #-} + +{-| Keep all values that satisfy the given predicate + +>>> filter even (fromList [("C",3),("B",2),("A",1)]) +fromList [("B",2)] +>>> filter odd (fromList [("C",3),("B",2),("A",1)]) +fromList [("C",3),("A",1)] +-} +filter :: Ord k => (a -> Bool) -> Map k a -> Map k a +filter predicate (Map m ks) = Map m' ks' + where + m' = Data.Map.filter predicate m + + set = Data.Map.keysSet m' + + ks' = Prelude.filter (\k -> Data.Set.member k set) ks +{-# INLINABLE filter #-} + +{-| Transform all values in a `Map` using the supplied function, deleting the + key if the function returns `Nothing` + +>>> mapMaybe Data.Maybe.listToMaybe (fromList [("C",[1]),("B",[]),("A",[3])]) +fromList [("C",1),("A",3)] +-} +mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b +mapMaybe f (Map m ks) = Map m' ks' + where + m' = Data.Map.mapMaybe f m + + set = Data.Map.keysSet m' + + ks' = Prelude.filter (\k -> Data.Set.member k set) ks +{-# INLINABLE mapMaybe #-} + +{-| Retrieve a key from a `Map` + +> lookup k mempty = empty +> +> lookup k (x <> y) = lookup k y <|> lookup k x + +>>> lookup "A" (fromList [("B",1),("A",2)]) +Just 2 +>>> lookup "C" (fromList [("B",1),("A",2)]) +Nothing +-} +lookup :: Ord k => k -> Map k v -> Maybe v +lookup k (Map m _) = Data.Map.lookup k m +{-# INLINABLE lookup #-} + +{-| Retrieve the first key, value of the 'Map', if present, + and also returning the rest of the 'Map'. + +> uncons mempty = empty +> +> uncons (singleton k v) = (k, v, mempty) + +>>> uncons (fromList [("C",1),("B",2),("A",3)]) +Just ("C",1,fromList [("B",2),("A",3)]) +>>> uncons (fromList []) +Nothing +-} +uncons :: Ord k => Map k v -> Maybe (k, v, Map k v) +uncons (Map _ []) = Nothing +uncons (Map m (k:ks)) = Just (k, m Data.Map.! k, Map (Data.Map.delete k m) ks) +{-# INLINABLE uncons #-} + +{-| Check if a key belongs to a `Map` + +> member k mempty = False +> +> member k (x <> y) = member k x || member k y + +>>> member "A" (fromList [("B",1),("A",2)]) +True +>>> member "C" (fromList [("B",1),("A",2)]) +False +-} +member :: Ord k => k -> Map k v -> Bool +member k (Map m _) = Data.Map.member k m +{-# INLINABLE member #-} + +{-| Combine two `Map`s, preferring keys from the first `Map` + +> union = unionWith (\v _ -> v) + +>>> union (fromList [("D",1),("C",2)]) (fromList [("B",3),("A",4)]) +fromList [("D",1),("C",2),("B",3),("A",4)] +>>> union (fromList [("D",1),("C",2)]) (fromList [("C",3),("A",4)]) +fromList [("D",1),("C",2),("A",4)] +-} +union :: Ord k => Map k v -> Map k v -> Map k v +union (Map mL ksL) (Map mR ksR) = Map m ks + where + m = Data.Map.union mL mR + + setL = Data.Map.keysSet mL + + ks = ksL <|> Prelude.filter (\k -> Data.Set.notMember k setL) ksR +{-# INLINABLE union #-} + +{-| Combine two `Map`s using a combining function for colliding keys + +>>> unionWith (+) (fromList [("D",1),("C",2)]) (fromList [("B",3),("A",4)]) +fromList [("D",1),("C",2),("B",3),("A",4)] +>>> unionWith (+) (fromList [("D",1),("C",2)]) (fromList [("C",3),("A",4)]) +fromList [("D",1),("C",5),("A",4)] +-} +unionWith :: Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v +unionWith combine (Map mL ksL) (Map mR ksR) = Map m ks + where + m = Data.Map.unionWith combine mL mR + + setL = Data.Map.keysSet mL + + ks = ksL <|> Prelude.filter (\k -> Data.Set.notMember k setL) ksR +{-# INLINABLE unionWith #-} + +{-| Combine two `Map` on their shared keys, keeping the value from the first + `Map` + +> intersection = intersectionWith (\v _ -> v) + +>>> intersection (fromList [("C",1),("B",2)]) (fromList [("B",3),("A",4)]) +fromList [("B",2)] +-} +intersection :: Ord k => Map k a -> Map k b -> Map k a +intersection (Map mL ksL) (Map mR _) = Map m ks + where + m = Data.Map.intersection mL mR + + setL = Data.Map.keysSet mL + setR = Data.Map.keysSet mR + set = Data.Set.intersection setL setR + ks = Prelude.filter (\k -> Data.Set.member k set) ksL +{-# INLINABLE intersection #-} + +{-| Combine two `Map`s on their shared keys, using the supplied function to + combine values from the first and second `Map` + +>>> intersectionWith (+) (fromList [("C",1),("B",2)]) (fromList [("B",3),("A",4)]) +fromList [("B",5)] +-} +intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c +intersectionWith combine (Map mL ksL) (Map mR _) = Map m ks + where + m = Data.Map.intersectionWith combine mL mR + + setL = Data.Map.keysSet mL + setR = Data.Map.keysSet mR + set = Data.Set.intersection setL setR + ks = Prelude.filter (\k -> Data.Set.member k set) ksL +{-# INLINABLE intersectionWith #-} + +{-| Compute the difference of two `Map`s by subtracting all keys from the + second `Map` from the first `Map` + +>>> difference (fromList [("C",1),("B",2)]) (fromList [("B",3),("A",4)]) +fromList [("C",1)] +-} +difference :: Ord k => Map k a -> Map k b -> Map k a +difference (Map mL ksL) (Map mR _) = Map m ks + where + m = Data.Map.difference mL mR + + setR = Data.Map.keysSet mR + + ks = Prelude.filter (\k -> Data.Set.notMember k setR) ksL +{-# INLINABLE difference #-} + +{-| Fold all of the key-value pairs in a `Map`, in their original order + +>>> foldMapWithKey (,) (fromList [("B",[1]),("A",[2])]) +("BA",[1,2]) +-} +foldMapWithKey :: (Monoid m, Ord k) => (k -> a -> m) -> Map k a -> m +foldMapWithKey f m = foldMap (uncurry f) (toList m) +{-# INLINABLE foldMapWithKey #-} + +{-| Transform the values of a `Map` using their corresponding key + +> mapWithKey (pure id) = id +> +> mapWithKey (liftA2 (.) f g) = mapWithKey f . mapWithKey g + +> mapWithKey f mempty = mempty +> +> mapWithKey f (x <> y) = mapWithKey f x <> mapWithKey f y + +>>> mapWithKey (,) (fromList [("B",1),("A",2)]) +fromList [("B",("B",1)),("A",("A",2))] +-} +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey f (Map m ks) = Map m' ks + where + m' = Data.Map.mapWithKey f m +{-# INLINABLE mapWithKey #-} + +{-| Traverse all of the key-value pairs in a `Map`, in their original order + +>>> traverseWithKey (,) (fromList [("B",1),("A",2)]) +("BA",fromList [("B",1),("A",2)]) +-} +traverseWithKey + :: Ord k => Applicative f => (k -> a -> f b) -> Map k a -> f (Map k b) +traverseWithKey f m = + fmap fromList (traverse f' (toList m)) + where + f' (k, a) = fmap ((,) k) (f k a) +{-# INLINABLE traverseWithKey #-} + +{-| Traverse all of the key-value pairs in a `Map`, in their original order + where the result of the computation can be forgotten. + +>>> traverseWithKey_ (\k v -> print (k, v)) (fromList [("B",1),("A",2)]) +("B",1) +("A",2) +-} +traverseWithKey_ + :: Ord k => Applicative f => (k -> a -> f ()) -> Map k a -> f () +traverseWithKey_ f m = Data.Functor.void (traverseWithKey f m) +{-# INLINABLE traverseWithKey_ #-} + +{-| Convert a `Map` to a list of key-value pairs in the original order of keys + +>>> toList (fromList [("B",1),("A",2)]) +[("B",1),("A",2)] +-} +toList :: Ord k => Map k v -> [(k, v)] +toList (Map m ks) = fmap (\k -> (k, m Data.Map.! k)) ks +{-# INLINABLE toList #-} + +{-| Convert a @"Dhall.Map".`Map`@ to a @"Data.Map".`Data.Map.Map`@ + +>>> toMap (fromList [("B",1),("A",2)]) -- Order is lost upon conversion +fromList [("A",2),("B",1)] +-} +toMap :: Map k v -> Data.Map.Map k v +toMap (Map m _) = m +{-# INLINABLE toMap #-} + +{-| Return the keys from a `Map` in their original order + +>>> keys (fromList [("B",1),("A",2)]) +["B","A"] +-} +keys :: Map k v -> [k] +keys (Map _ ks) = ks +{-# INLINABLE keys #-} diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -41,13 +41,13 @@ -- | A parsing error data ParseError = ParseError - { unwrap :: Text.Megaparsec.ParseError Char Void + { unwrap :: Text.Megaparsec.ParseErrorBundle Text Void , input :: Text } instance Show ParseError where show (ParseError {..}) = - "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.parseErrorPretty' input unwrap + "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.errorBundlePretty unwrap instance Exception ParseError 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 @@ -1,15 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Dhall.Parser.Combinators where import Control.Applicative (Alternative (..), liftA2) -import Control.Monad (MonadPlus) +import Control.Monad (MonadPlus (..)) import Data.Data (Data) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.Semigroup (Semigroup (..)) import Data.Sequence (ViewL (..)) import Data.Set (Set) @@ -17,16 +15,18 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty (..)) import Data.Void (Void) +import Dhall.Map (Map) import Prelude hiding (const, pi) import Text.Parser.Combinators (try, ()) import Text.Parser.Token (TokenParsing (..)) +import qualified Control.Monad.Fail import qualified Data.Char -import qualified Data.HashMap.Strict.InsOrd -import qualified Data.List import qualified Data.Sequence import qualified Data.Set import qualified Data.Text +import qualified Dhall.Map +import qualified Dhall.Util import qualified Text.Megaparsec import qualified Text.Megaparsec.Char import qualified Text.Parser.Char @@ -34,30 +34,129 @@ import qualified Text.Parser.Token.Style -- | Source code extract -data Src = Src Text.Megaparsec.SourcePos Text.Megaparsec.SourcePos Text +data Src = Src !Text.Megaparsec.SourcePos !Text.Megaparsec.SourcePos Text + -- Text field is intentionally lazy deriving (Data, Eq, Show) +-- | Doesn't force the 'Text' part +laxSrcEq :: Src -> Src -> Bool +laxSrcEq (Src p q _) (Src p' q' _) = eq p p' && eq q q' + where + -- Don't compare filename (which is FilePath = String) + eq :: Text.Megaparsec.SourcePos -> Text.Megaparsec.SourcePos -> Bool + eq (Text.Megaparsec.SourcePos _ a b) (Text.Megaparsec.SourcePos _ a' b') = + a == a' && b == b' +{-# INLINE laxSrcEq #-} + instance Pretty Src where pretty (Src begin _ text) = - pretty text <> "\n" + pretty (Dhall.Util.snip (prefix <> text)) <> "\n" <> pretty (Text.Megaparsec.sourcePosPretty begin) - <> "\n" + where + prefix = Data.Text.replicate (n - 1) " " + where + n = Text.Megaparsec.unPos (Text.Megaparsec.sourceColumn begin) {-| A `Parser` that is almost identical to @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style comments as whitespace -} newtype Parser a = Parser { unParser :: Text.Megaparsec.Parsec Void Text a } - deriving - ( Functor - , Applicative - , Monad - , Alternative - , MonadPlus - , Text.Megaparsec.MonadParsec Void Text - ) +instance Functor Parser where + fmap f (Parser x) = Parser (fmap f x) + {-# INLINE fmap #-} + + f <$ Parser x = Parser (f <$ x) + {-# INLINE (<$) #-} + +instance Applicative Parser where + pure = Parser . pure + {-# INLINE pure #-} + + Parser f <*> Parser x = Parser (f <*> x) + {-# INLINE (<*>) #-} + + Parser a <* Parser b = Parser (a <* b) + {-# INLINE (<*) #-} + + Parser a *> Parser b = Parser (a *> b) + {-# INLINE (*>) #-} + +instance Monad Parser where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Parser n >>= k = Parser (n >>= unParser . k) + {-# INLINE (>>=) #-} + + fail = Control.Monad.Fail.fail + {-# INLINE fail #-} + +instance Control.Monad.Fail.MonadFail Parser where + fail = Parser . Control.Monad.Fail.fail + {-# INLINE fail #-} + +instance Alternative Parser where + empty = Parser empty + -- {-# INLINE empty #-} + + Parser a <|> Parser b = Parser (a <|> b) + -- {-# INLINE (<|>) #-} + + some (Parser a) = Parser (some a) + -- {-# INLINE some #-} + + many (Parser a) = Parser (many a) + -- {-# INLINE many #-} + +instance MonadPlus Parser where + mzero = empty + -- {-# INLINE mzero #-} + + mplus = (<|>) + -- {-# INLINE mplus #-} + +instance Text.Megaparsec.MonadParsec Void Text Parser where + failure u e = Parser (Text.Megaparsec.failure u e) + + fancyFailure e = Parser (Text.Megaparsec.fancyFailure e) + + label l (Parser p) = Parser (Text.Megaparsec.label l p) + + hidden (Parser p) = Parser (Text.Megaparsec.hidden p) + + try (Parser p) = Parser (Text.Megaparsec.try p) + + lookAhead (Parser p) = Parser (Text.Megaparsec.lookAhead p) + + notFollowedBy (Parser p) = Parser (Text.Megaparsec.notFollowedBy p) + + withRecovery e (Parser p) = Parser (Text.Megaparsec.withRecovery (unParser . e) p) + + observing (Parser p) = Parser (Text.Megaparsec.observing p) + + eof = Parser Text.Megaparsec.eof + + token f e = Parser (Text.Megaparsec.token f e) + + tokens f ts = Parser (Text.Megaparsec.tokens f ts) + + takeWhileP s f = Parser (Text.Megaparsec.takeWhileP s f) + + takeWhile1P s f = Parser (Text.Megaparsec.takeWhile1P s f) + + takeP s n = Parser (Text.Megaparsec.takeP s n) + + getParserState = Parser Text.Megaparsec.getParserState + {-# INLINE getParserState #-} + + updateParserState f = Parser (Text.Megaparsec.updateParserState f) + instance Data.Semigroup.Semigroup a => Data.Semigroup.Semigroup (Parser a) where (<>) = liftA2 (<>) @@ -87,13 +186,13 @@ notFollowedBy = Text.Megaparsec.notFollowedBy instance Text.Parser.Char.CharParsing Parser where - satisfy = Parser . Text.Megaparsec.Char.satisfy + satisfy = Parser . Text.Megaparsec.satisfy char = Text.Megaparsec.Char.char notChar = Text.Megaparsec.Char.char - anyChar = Text.Megaparsec.Char.anyChar + anyChar = Text.Megaparsec.anySingle string = fmap Data.Text.unpack . Text.Megaparsec.Char.string . fromString @@ -102,7 +201,7 @@ instance TokenParsing Parser where someSpace = Text.Parser.Token.Style.buildSomeSpaceParser - (Parser (Text.Megaparsec.skipSome (Text.Megaparsec.Char.satisfy Data.Char.isSpace))) + (Parser (Text.Megaparsec.skipSome (Text.Megaparsec.satisfy Data.Char.isSpace))) Text.Parser.Token.Style.haskellCommentStyle highlight _ = id @@ -146,7 +245,7 @@ then fail "Duplicate key" else go (Data.Set.insert x found) xs -toMap :: [(Text, a)] -> Parser (InsOrdHashMap Text a) +toMap :: [(Text, a)] -> Parser (Map Text a) toMap kvs = do let adapt (k, v) = (k, pure v) let m = fromListWith (<|>) (fmap adapt kvs) @@ -158,10 +257,8 @@ else Text.Parser.Combinators.unexpected ("duplicate field: " ++ Data.Text.unpack k) - Data.HashMap.Strict.InsOrd.traverseWithKey action m + Dhall.Map.traverseWithKey action m where - fromListWith combine = Data.List.foldl' snoc nil + fromListWith combine = foldr cons mempty where - nil = Data.HashMap.Strict.InsOrd.empty - - snoc m (k, v) = Data.HashMap.Strict.InsOrd.insertWith combine k v m + cons (k, v) = Dhall.Map.insertWith combine k v 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 @@ -1,777 +1,662 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} --- | Parsing Dhall expressions. -module Dhall.Parser.Expression where - -import Control.Applicative (Alternative(..), optional) -import Data.ByteArray.Encoding (Base(..)) -import Data.Functor (void) -import Data.Semigroup (Semigroup(..)) -import Data.Text (Text) -import Dhall.Core -import Prelude hiding (const, pi) -import Text.Parser.Combinators (choice, try, ()) - -import qualified Crypto.Hash -import qualified Data.ByteArray.Encoding -import qualified Data.ByteString -import qualified Data.Char -import qualified Data.HashMap.Strict.InsOrd -import qualified Data.Sequence -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Text.Megaparsec -import qualified Text.Parser.Char - -import Dhall.Parser.Combinators -import Dhall.Parser.Token - -noted :: Parser (Expr Src a) -> Parser (Expr Src a) -noted parser = do - before <- Text.Megaparsec.getPosition - (tokens, e) <- Text.Megaparsec.match parser - after <- Text.Megaparsec.getPosition - let src₀ = Src before after tokens - case e of - Note src₁ _ | src₀ == src₁ -> return e - _ -> return (Note src₀ e) - -expression :: Parser a -> Parser (Expr Src a) -expression embedded = - ( noted - ( choice - [ alternative0 - , alternative1 - , alternative2 - , alternative3 - , alternative4 - ] - ) - <|> alternative5 - ) "expression" - where - alternative0 = do - _lambda - _openParens - a <- label - _colon - b <- expression embedded - _closeParens - _arrow - c <- expression embedded - return (Lam a b c) - - alternative1 = do - _if - a <- expression embedded - _then - b <- expression embedded - _else - c <- expression embedded - return (BoolIf a b c) - - alternative2 = do - _let - a <- label - b <- optional (do - _colon - expression embedded ) - _equal - c <- expression embedded - _in - d <- expression embedded - return (Let a b c d) - - alternative3 = do - _forall - _openParens - a <- label - _colon - b <- expression embedded - _closeParens - _arrow - c <- expression embedded - return (Pi a b c) - - alternative4 = do - a <- try (do a <- operatorExpression embedded; _arrow; return a) - b <- expression embedded - return (Pi "_" a b) - - alternative5 = annotatedExpression embedded - -annotatedExpression :: Parser a -> Parser (Expr Src a) -annotatedExpression embedded = - noted - ( choice - [ alternative0 - , try alternative1 - , alternative2 - ] - ) - where - alternative0 = do - _merge - a <- importExpression embedded - b <- importExpression embedded - c <- optional (do - _colon - applicationExpression embedded ) - return (Merge a b c) - - alternative1 = (do - _openBracket - (emptyCollection embedded <|> nonEmptyOptional embedded) ) - "list literal" - - alternative2 = do - a <- operatorExpression embedded - b <- optional (do _colon; expression embedded) - case b of - Nothing -> return a - Just c -> return (Annot a c) - -emptyCollection :: Parser a -> Parser (Expr Src a) -emptyCollection embedded = do - _closeBracket - _colon - a <- alternative0 <|> alternative1 - b <- importExpression embedded - return (a b) - where - alternative0 = do - _List - return (\a -> ListLit (Just a) empty) - - alternative1 = do - _Optional - return (\a -> OptionalLit a empty) - -nonEmptyOptional :: Parser a -> Parser (Expr Src a) -nonEmptyOptional embedded = do - a <- expression embedded - _closeBracket - _colon - _Optional - b <- importExpression embedded - return (OptionalLit b (pure a)) - -operatorExpression :: Parser a -> Parser (Expr Src a) -operatorExpression = importAltExpression - -makeOperatorExpression - :: (Parser a -> Parser (Expr Src a)) - -> Parser () - -> (Expr Src a -> Expr Src a -> Expr Src a) - -> Parser a - -> Parser (Expr Src a) -makeOperatorExpression subExpression operatorParser operator embedded = - noted (do - a <- subExpression embedded - b <- Text.Megaparsec.many (do operatorParser; subExpression embedded) - return (foldr1 operator (a:b)) ) - -importAltExpression :: Parser a -> Parser (Expr Src a) -importAltExpression = - makeOperatorExpression orExpression _importAlt ImportAlt - -orExpression :: Parser a -> Parser (Expr Src a) -orExpression = - makeOperatorExpression plusExpression _or BoolOr - -plusExpression :: Parser a -> Parser (Expr Src a) -plusExpression = - makeOperatorExpression textAppendExpression _plus NaturalPlus - -textAppendExpression :: Parser a -> Parser (Expr Src a) -textAppendExpression = - makeOperatorExpression listAppendExpression _textAppend TextAppend - -listAppendExpression :: Parser a -> Parser (Expr Src a) -listAppendExpression = - makeOperatorExpression andExpression _listAppend ListAppend - -andExpression :: Parser a -> Parser (Expr Src a) -andExpression = - makeOperatorExpression combineExpression _and BoolAnd - -combineExpression :: Parser a -> Parser (Expr Src a) -combineExpression = - makeOperatorExpression preferExpression _combine Combine - -preferExpression :: Parser a -> Parser (Expr Src a) -preferExpression = - makeOperatorExpression combineTypesExpression _prefer Prefer - -combineTypesExpression :: Parser a -> Parser (Expr Src a) -combineTypesExpression = - makeOperatorExpression timesExpression _combineTypes CombineTypes - -timesExpression :: Parser a -> Parser (Expr Src a) -timesExpression = - makeOperatorExpression equalExpression _times NaturalTimes - -equalExpression :: Parser a -> Parser (Expr Src a) -equalExpression = - makeOperatorExpression notEqualExpression _doubleEqual BoolEQ - -notEqualExpression :: Parser a -> Parser (Expr Src a) -notEqualExpression = - makeOperatorExpression applicationExpression _notEqual BoolNE - -applicationExpression :: Parser a -> Parser (Expr Src a) -applicationExpression embedded = do - f <- (do _constructors; return Constructors) <|> return id - a <- noted (importExpression embedded) - b <- Text.Megaparsec.many (noted (importExpression embedded)) - return (foldl app (f a) b) - where - app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = - Note (Src before after (bytesL <> bytesR)) (App nL nR) - app nL nR = - App nL nR - -importExpression :: Parser a -> Parser (Expr Src a) -importExpression embedded = noted (choice [ alternative0, alternative1 ]) - where - alternative0 = do - a <- embedded - return (Embed a) - - alternative1 = selectorExpression embedded - -selectorExpression :: Parser a -> Parser (Expr Src a) -selectorExpression embedded = noted (do - a <- primitiveExpression embedded - - let left x e = Field e x - let right xs e = Project e xs - b <- Text.Megaparsec.many (try (do _dot; fmap left label <|> fmap right labels)) - return (foldl (\e k -> k e) a b) ) - -primitiveExpression :: Parser a -> Parser (Expr Src a) -primitiveExpression embedded = - noted - ( choice - [ alternative00 - , alternative01 - , alternative02 - , alternative03 - , alternative04 - , alternative05 - , alternative06 - , alternative37 - - , choice - [ alternative08 - , alternative09 - , alternative10 - , alternative11 - , alternative12 - , alternative13 - , alternative14 - , alternative15 - , alternativeIntegerToDouble - , alternative16 - , alternative17 - , alternative18 - , alternative19 - , alternative20 - , alternative21 - , alternative22 - , alternative23 - , alternative24 - , alternative25 - , alternative26 - , alternative27 - , alternative28 - , alternative29 - , alternative30 - , alternative31 - , alternative32 - , alternative33 - , alternative34 - , alternative35 - , alternative36 - ] "built-in expression" - ] - ) - <|> alternative38 - where - alternative00 = do - a <- try doubleLiteral - return (DoubleLit a) - - alternative01 = do - a <- try naturalLiteral - return (NaturalLit a) - - alternative02 = do - a <- try integerLiteral - return (IntegerLit a) - - alternative03 = textLiteral embedded - - alternative04 = (do - _openBrace - a <- recordTypeOrLiteral embedded - _closeBrace - return a ) "record type or literal" - - alternative05 = (do - _openAngle - a <- unionTypeOrLiteral embedded - _closeAngle - return a ) "union type or literal" - - alternative06 = nonEmptyListLiteral embedded - - alternative08 = do - _NaturalFold - return NaturalFold - - alternative09 = do - _NaturalBuild - return NaturalBuild - - alternative10 = do - _NaturalIsZero - return NaturalIsZero - - alternative11 = do - _NaturalEven - return NaturalEven - - alternative12 = do - _NaturalOdd - return NaturalOdd - - alternative13 = do - _NaturalToInteger - return NaturalToInteger - - alternative14 = do - _NaturalShow - return NaturalShow - - alternative15 = do - _IntegerShow - return IntegerShow - - alternativeIntegerToDouble = do - _IntegerToDouble - return IntegerToDouble - - alternative16 = do - _DoubleShow - return DoubleShow - - alternative17 = do - _ListBuild - return ListBuild - - alternative18 = do - _ListFold - return ListFold - - alternative19 = do - _ListLength - return ListLength - - alternative20 = do - _ListHead - return ListHead - - alternative21 = do - _ListLast - return ListLast - - alternative22 = do - _ListIndexed - return ListIndexed - - alternative23 = do - _ListReverse - return ListReverse - - alternative24 = do - _OptionalFold - return OptionalFold - - alternative25 = do - _OptionalBuild - return OptionalBuild - - alternative26 = do - _Bool - return Bool - - alternative27 = do - _Optional - return Optional - - alternative28 = do - _Natural - return Natural - - alternative29 = do - _Integer - return Integer - - alternative30 = do - _Double - return Double - - alternative31 = do - _Text - return Text - - alternative32 = do - _List - return List - - alternative33 = do - _True - return (BoolLit True) - - alternative34 = do - _False - return (BoolLit False) - - alternative35 = do - _Type - return (Const Type) - - alternative36 = do - _Kind - return (Const Kind) - - alternative37 = do - a <- identifier - return (Var a) - - alternative38 = do - _openParens - a <- expression embedded - _closeParens - return a - - -doubleQuotedChunk :: Parser a -> Parser (Chunks Src a) -doubleQuotedChunk embedded = - choice - [ interpolation - , unescapedCharacter - , escapedCharacter - ] - where - interpolation = do - _ <- Text.Parser.Char.text "${" - e <- completeExpression embedded - _ <- Text.Parser.Char.char '}' - return (Chunks [(mempty, e)] mempty) - - unescapedCharacter = do - c <- Text.Parser.Char.satisfy predicate - return (Chunks [] (Data.Text.singleton c)) - where - predicate c = - ('\x20' <= c && c <= '\x21' ) - || ('\x23' <= c && c <= '\x5B' ) - || ('\x5D' <= c && c <= '\x10FFFF') - - escapedCharacter = do - _ <- Text.Parser.Char.char '\\' - c <- choice - [ quotationMark - , dollarSign - , backSlash - , forwardSlash - , backSpace - , formFeed - , lineFeed - , carriageReturn - , tab - , unicode - ] - return (Chunks [] (Data.Text.singleton c)) - where - quotationMark = Text.Parser.Char.char '"' - - dollarSign = Text.Parser.Char.char '$' - - backSlash = Text.Parser.Char.char '\\' - - forwardSlash = Text.Parser.Char.char '/' - - backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b' - - formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f' - - lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n' - - carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r' - - tab = do _ <- Text.Parser.Char.char 't'; return '\t' - - unicode = do - _ <- Text.Parser.Char.char 'u'; - n0 <- hexNumber - n1 <- hexNumber - n2 <- hexNumber - n3 <- hexNumber - let n = ((n0 * 16 + n1) * 16 + n2) * 16 + n3 - return (Data.Char.chr n) - -doubleQuotedLiteral :: Parser a -> Parser (Chunks Src a) -doubleQuotedLiteral embedded = do - _ <- Text.Parser.Char.char '"' - chunks <- Text.Megaparsec.many (doubleQuotedChunk embedded) - _ <- Text.Parser.Char.char '"' - return (mconcat chunks) - -singleQuoteContinue :: Parser a -> Parser (Chunks Src a) -singleQuoteContinue embedded = - choice - [ escapeSingleQuotes - , interpolation - , escapeInterpolation - , endLiteral - , unescapedCharacter - , tab - , endOfLine - ] - where - escapeSingleQuotes = do - _ <- "'''" :: Parser Text - b <- singleQuoteContinue embedded - return ("''" <> b) - - interpolation = do - _ <- Text.Parser.Char.text "${" - a <- completeExpression embedded - _ <- Text.Parser.Char.char '}' - b <- singleQuoteContinue embedded - return (Chunks [(mempty, a)] mempty <> b) - - escapeInterpolation = do - _ <- Text.Parser.Char.text "''${" - b <- singleQuoteContinue embedded - return ("${" <> b) - - endLiteral = do - _ <- Text.Parser.Char.text "''" - return mempty - - unescapedCharacter = do - a <- satisfy predicate - b <- singleQuoteContinue embedded - return (Chunks [] a <> b) - where - predicate c = '\x20' <= c && c <= '\x10FFFF' - - endOfLine = do - a <- "\n" <|> "\r\n" - b <- singleQuoteContinue embedded - return (Chunks [] a <> b) - - tab = do - _ <- Text.Parser.Char.char '\t' - b <- singleQuoteContinue embedded - return ("\t" <> b) - -singleQuoteLiteral :: Parser a -> Parser (Chunks Src a) -singleQuoteLiteral embedded = do - _ <- Text.Parser.Char.text "''" - - -- This is technically not in the grammar, but it's still equivalent to the - -- original grammar and an easy way to discard the first character if it's - -- a newline - _ <- optional endOfLine - - a <- singleQuoteContinue embedded - - return (dedent a) - where - endOfLine = - void (Text.Parser.Char.char '\n' ) - <|> void (Text.Parser.Char.text "\r\n") - -textLiteral :: Parser a -> Parser (Expr Src a) -textLiteral embedded = (do - literal <- doubleQuotedLiteral embedded <|> singleQuoteLiteral embedded - whitespace - return (TextLit literal) ) "text literal" - -recordTypeOrLiteral :: Parser a -> Parser (Expr Src a) -recordTypeOrLiteral embedded = - choice - [ alternative0 - , alternative1 - , alternative2 - ] - where - alternative0 = do - _equal - return (RecordLit Data.HashMap.Strict.InsOrd.empty) - - alternative1 = nonEmptyRecordTypeOrLiteral embedded - - alternative2 = return (Record Data.HashMap.Strict.InsOrd.empty) - -nonEmptyRecordTypeOrLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyRecordTypeOrLiteral embedded = do - a <- label - - let nonEmptyRecordType = do - _colon - b <- expression embedded - e <- Text.Megaparsec.many (do - _comma - c <- label - _colon - d <- expression embedded - return (c, d) ) - m <- toMap ((a, b) : e) - return (Record m) - - let nonEmptyRecordLiteral = do - _equal - b <- expression embedded - e <- Text.Megaparsec.many (do - _comma - c <- label - _equal - d <- expression embedded - return (c, d) ) - m <- toMap ((a, b) : e) - return (RecordLit m) - - nonEmptyRecordType <|> nonEmptyRecordLiteral - -unionTypeOrLiteral :: Parser a -> Parser (Expr Src a) -unionTypeOrLiteral embedded = - nonEmptyUnionTypeOrLiteral embedded - <|> return (Union Data.HashMap.Strict.InsOrd.empty) - -nonEmptyUnionTypeOrLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyUnionTypeOrLiteral embedded = do - (f, kvs) <- loop - m <- toMap kvs - return (f m) - where - loop = do - a <- label - - let alternative0 = do - _equal - b <- expression embedded - kvs <- Text.Megaparsec.many (do - _bar - c <- label - _colon - d <- expression embedded - return (c, d) ) - return (UnionLit a b, kvs) - - let alternative1 = do - _colon - b <- expression embedded - - let alternative2 = do - _bar - (f, kvs) <- loop - return (f, (a, b):kvs) - - let alternative3 = return (Union, [(a, b)]) - - alternative2 <|> alternative3 - - alternative0 <|> alternative1 - -nonEmptyListLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyListLiteral embedded = (do - _openBracket - a <- expression embedded - b <- Text.Megaparsec.many (do _comma; expression embedded) - _closeBracket - return (ListLit Nothing (Data.Sequence.fromList (a:b))) ) "list literal" - -completeExpression :: Parser a -> Parser (Expr Src a) -completeExpression embedded = do - whitespace - expression embedded - -env :: Parser ImportType -env = do - _ <- Text.Parser.Char.text "env:" - a <- (alternative0 <|> alternative1) - whitespace - return (Env a) - where - alternative0 = bashEnvironmentVariable - - alternative1 = do - _ <- Text.Parser.Char.char '"' - a <- posixEnvironmentVariable - _ <- Text.Parser.Char.char '"' - return a - -localRaw :: Parser ImportType -localRaw = - choice - [ parentPath - , herePath - , homePath - , try absolutePath - ] - where - parentPath = do - _ <- ".." :: Parser Text - File (Directory segments) final <- file_ - - return (Local Here (File (Directory (segments ++ [".."])) final)) - - herePath = do - _ <- "." :: Parser Text - file <- file_ - - return (Local Here file) - - homePath = do - _ <- "~" :: Parser Text - file <- file_ - - return (Local Home file) - - absolutePath = do - file <- file_ - - return (Local Absolute file) - -local :: Parser ImportType -local = do - a <- localRaw - whitespace - return a - -http :: Parser ImportType -http = do - url <- httpRaw - whitespace - headers <- optional (do - _using - (importHashed_ <|> (_openParens *> importHashed_ <* _closeParens)) ) - return (Remote (url { headers })) - -missing :: Parser ImportType -missing = do - _missing - return Missing - -importType_ :: Parser ImportType -importType_ = choice [ local, http, env, missing ] +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Parsing Dhall expressions. +module Dhall.Parser.Expression where + +import Control.Applicative (Alternative(..), optional) +import Data.ByteArray.Encoding (Base(..)) +import Data.Functor (void) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Dhall.Core +import Prelude hiding (const, pi) +import Text.Parser.Combinators (choice, try, ()) + +import qualified Crypto.Hash +import qualified Data.ByteArray.Encoding +import qualified Data.ByteString +import qualified Data.Char +import qualified Data.Sequence +import qualified Data.Text +import qualified Data.Text.Encoding +import qualified Text.Megaparsec +import qualified Text.Parser.Char + +import Dhall.Parser.Combinators +import Dhall.Parser.Token + +noted :: Parser (Expr Src a) -> Parser (Expr Src a) +noted parser = do + before <- Text.Megaparsec.getSourcePos + (tokens, e) <- Text.Megaparsec.match parser + after <- Text.Megaparsec.getSourcePos + let src₀ = Src before after tokens + case e of + Note src₁ _ | laxSrcEq src₀ src₁ -> return e + _ -> return (Note src₀ e) + +shallowDenote :: Expr s a -> Expr s a +shallowDenote (Note _ e) = shallowDenote e +shallowDenote e = e + +completeExpression :: Parser a -> Parser (Expr Src a) +completeExpression embedded = completeExpression_ + where + completeExpression_ = do + whitespace + expression + + expression = + noted + ( choice + [ alternative0 + , alternative1 + , alternative2 + , alternative3 + , alternative4 + ] + ) "expression" + where + alternative0 = do + _lambda + _openParens + a <- label + _colon + b <- expression + _closeParens + _arrow + c <- expression + return (Lam a b c) + + alternative1 = do + _if + a <- expression + _then + b <- expression + _else + c <- expression + return (BoolIf a b c) + + alternative2 = do + _let + a <- label + b <- optional (do + _colon + expression ) + _equal + c <- expression + _in + d <- expression + return (Let a b c d) + + alternative3 = do + _forall + _openParens + a <- label + _colon + b <- expression + _closeParens + _arrow + c <- expression + return (Pi a b c) + + alternative4 = do + a <- operatorExpression + + let alternative4A = do + _arrow + b <- expression + return (Pi "_" a b) + + let alternative4B = do + _colon + + b <- expression + + case (shallowDenote a, shallowDenote b) of + (ListLit _ xs, App f c) -> + case shallowDenote f of + List -> + return (ListLit (Just c) xs) + Optional -> case xs of + [x] -> return (OptionalLit c (Just x)) + [] -> return (OptionalLit c Nothing) + _ -> return (Annot a b) + _ -> + return (Annot a b) + (Merge c d _, e) -> + return (Merge c d (Just e)) + _ -> return (Annot a b) + + alternative4A <|> alternative4B <|> pure a + + operatorExpression = precedence0Expression + + makeOperatorExpression subExpression operatorParser = + noted (do + a <- subExpression + b <- Text.Megaparsec.many $ do + op <- operatorParser + r <- subExpression + + return (\l -> l `op` r) + return (foldl (\x f -> f x) a b) ) + + precedence0Operator = + ImportAlt <$ _importAlt + <|> BoolOr <$ _or + <|> TextAppend <$ _textAppend + <|> NaturalPlus <$ _plus + <|> ListAppend <$ _listAppend + + precedence1Operator = + BoolAnd <$ _and + <|> Combine <$ _combine + + precedence2Operator = + Prefer <$ _prefer + <|> CombineTypes <$ _combineTypes + <|> NaturalTimes <$ _times + <|> BoolNE <$ _notEqual + + precedence3Operator = BoolEQ <$ _doubleEqual + + precedence0Expression = + makeOperatorExpression precedence1Expression precedence0Operator + + precedence1Expression = + makeOperatorExpression precedence2Expression precedence1Operator + + precedence2Expression = + makeOperatorExpression precedence3Expression precedence2Operator + + precedence3Expression = + makeOperatorExpression applicationExpression precedence3Operator + + applicationExpression = do + f <- (do _constructors; return Constructors) + <|> (do _Some; return Some) + <|> return id + a <- noted importExpression + b <- Text.Megaparsec.many (noted importExpression) + return (foldl app (f a) b) + where + app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = + Note (Src before after (bytesL <> bytesR)) (App nL nR) + app nL nR = + App nL nR + + importExpression = noted (choice [ alternative0, alternative1 ]) + where + alternative0 = do + a <- embedded + return (Embed a) + + alternative1 = selectorExpression + + selectorExpression = noted (do + a <- primitiveExpression + + let left x e = Field e x + let right xs e = Project e xs + b <- Text.Megaparsec.many (try (do _dot; fmap left label <|> fmap right labels)) + return (foldl (\e k -> k e) a b) ) + + primitiveExpression = + noted + ( choice + [ alternative00 + , alternative01 + , alternative02 + , alternative03 + , alternative04 + , alternative05 + , alternative06 + , alternative07 + , alternative37 + + , builtin "built-in expression" + ] + ) + <|> alternative38 + where + alternative00 = do + a <- try doubleLiteral + return (DoubleLit a) + + alternative01 = do + a <- try naturalLiteral + return (NaturalLit a) + + alternative02 = do + a <- try integerLiteral + return (IntegerLit a) + + alternative03 = textLiteral + + alternative04 = (do + _openBrace + a <- recordTypeOrLiteral + _closeBrace + return a ) "record type or literal" + + alternative05 = (do + _openAngle + a <- unionTypeOrLiteral + _closeAngle + return a ) "union type or literal" + + alternative06 = listLiteral + + alternative07 = do + _merge + a <- importExpression + b <- importExpression + return (Merge a b Nothing) + + builtin = do + let predicate c = + c == 'N' + || c == 'I' + || c == 'D' + || c == 'L' + || c == 'O' + || c == 'B' + || c == 'S' + || c == 'T' + || c == 'F' + || c == 'K' + + c <- Text.Megaparsec.lookAhead (Text.Megaparsec.satisfy predicate) + + case c of + 'N' -> + choice + [ NaturalFold <$ _NaturalFold + , NaturalBuild <$ _NaturalBuild + , NaturalIsZero <$ _NaturalIsZero + , NaturalEven <$ _NaturalEven + , NaturalOdd <$ _NaturalOdd + , NaturalToInteger <$ _NaturalToInteger + , NaturalToInteger <$ _NaturalToInteger + , NaturalShow <$ _NaturalShow + , Natural <$ _Natural + , None <$ _None + ] + 'I' -> + choice + [ IntegerShow <$ _IntegerShow + , IntegerToDouble <$ _IntegerToDouble + , Integer <$ _Integer + ] + + 'D' -> + choice + [ DoubleShow <$ _DoubleShow + , Double <$ _Double + ] + 'L' -> + choice + [ ListBuild <$ _ListBuild + , ListFold <$ _ListFold + , ListLength <$ _ListLength + , ListHead <$ _ListHead + , ListLast <$ _ListLast + , ListIndexed <$ _ListIndexed + , ListReverse <$ _ListReverse + , List <$ _List + ] + 'O' -> + choice + [ OptionalFold <$ _OptionalFold + , OptionalBuild <$ _OptionalBuild + , Optional <$ _Optional + ] + 'B' -> Bool <$ _Bool + 'S' -> Const Sort <$ _Sort + 'T' -> + choice + [ Text <$ _Text + , BoolLit True <$ _True + , Const Type <$ _Type + ] + 'F' -> BoolLit False <$ _False + 'K' -> Const Kind <$ _Kind + _ -> empty + + alternative37 = do + a <- identifier + return (Var a) + + alternative38 = do + _openParens + a <- expression + _closeParens + return a + + doubleQuotedChunk = + choice + [ interpolation + , unescapedCharacterFast + , unescapedCharacterSlow + , escapedCharacter + ] + where + interpolation = do + _ <- Text.Parser.Char.text "${" + e <- completeExpression_ + _ <- Text.Parser.Char.char '}' + return (Chunks [(mempty, e)] mempty) + + unescapedCharacterFast = do + t <- Text.Megaparsec.takeWhile1P Nothing predicate + return (Chunks [] t) + where + predicate c = + ( ('\x20' <= c && c <= '\x21' ) + || ('\x23' <= c && c <= '\x5B' ) + || ('\x5D' <= c && c <= '\x10FFFF') + ) && c /= '$' + + unescapedCharacterSlow = do + _ <- Text.Megaparsec.single '$' + return (Chunks [] "$") + + escapedCharacter = do + _ <- Text.Parser.Char.char '\\' + c <- choice + [ quotationMark + , dollarSign + , backSlash + , forwardSlash + , backSpace + , formFeed + , lineFeed + , carriageReturn + , tab + , unicode + ] + return (Chunks [] (Data.Text.singleton c)) + where + quotationMark = Text.Parser.Char.char '"' + + dollarSign = Text.Parser.Char.char '$' + + backSlash = Text.Parser.Char.char '\\' + + forwardSlash = Text.Parser.Char.char '/' + + backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b' + + formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f' + + lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n' + + carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r' + + tab = do _ <- Text.Parser.Char.char 't'; return '\t' + + unicode = do + _ <- Text.Parser.Char.char 'u'; + n0 <- hexNumber + n1 <- hexNumber + n2 <- hexNumber + n3 <- hexNumber + let n = ((n0 * 16 + n1) * 16 + n2) * 16 + n3 + return (Data.Char.chr n) + + doubleQuotedLiteral = do + _ <- Text.Parser.Char.char '"' + chunks <- Text.Megaparsec.many doubleQuotedChunk + _ <- Text.Parser.Char.char '"' + return (mconcat chunks) + + singleQuoteContinue = + choice + [ escapeSingleQuotes + , interpolation + , escapeInterpolation + , endLiteral + , unescapedCharacterFast + , unescapedCharacterSlow + , tab + , endOfLine + ] + where + escapeSingleQuotes = do + _ <- "'''" :: Parser Text + b <- singleQuoteContinue + return ("''" <> b) + + interpolation = do + _ <- Text.Parser.Char.text "${" + a <- completeExpression_ + _ <- Text.Parser.Char.char '}' + b <- singleQuoteContinue + return (Chunks [(mempty, a)] mempty <> b) + + escapeInterpolation = do + _ <- Text.Parser.Char.text "''${" + b <- singleQuoteContinue + return ("${" <> b) + + endLiteral = do + _ <- Text.Parser.Char.text "''" + return mempty + + unescapedCharacterFast = do + a <- Text.Megaparsec.takeWhile1P Nothing predicate + b <- singleQuoteContinue + return (Chunks [] a <> b) + where + predicate c = + ('\x20' <= c && c <= '\x10FFFF') && c /= '$' && c /= '\'' + + unescapedCharacterSlow = do + a <- satisfy predicate + b <- singleQuoteContinue + return (Chunks [] a <> b) + where + predicate c = c == '$' || c == '\'' + + endOfLine = do + a <- "\n" <|> "\r\n" + b <- singleQuoteContinue + return (Chunks [] a <> b) + + tab = do + _ <- Text.Parser.Char.char '\t' + b <- singleQuoteContinue + return ("\t" <> b) + + singleQuoteLiteral = do + _ <- Text.Parser.Char.text "''" + + -- This is technically not in the grammar, but it's still equivalent to the + -- original grammar and an easy way to discard the first character if it's + -- a newline + _ <- optional endOfLine + + a <- singleQuoteContinue + + return (dedent a) + where + endOfLine = + void (Text.Parser.Char.char '\n' ) + <|> void (Text.Parser.Char.text "\r\n") + + textLiteral = (do + literal <- doubleQuotedLiteral <|> singleQuoteLiteral + whitespace + return (TextLit literal) ) "text literal" + + recordTypeOrLiteral = + choice + [ alternative0 + , alternative1 + , alternative2 + ] + where + alternative0 = do + _equal + return (RecordLit mempty) + + alternative1 = nonEmptyRecordTypeOrLiteral + + alternative2 = return (Record mempty) + + nonEmptyRecordTypeOrLiteral = do + a <- label + + let nonEmptyRecordType = do + _colon + b <- expression + e <- Text.Megaparsec.many (do + _comma + c <- label + _colon + d <- expression + return (c, d) ) + m <- toMap ((a, b) : e) + return (Record m) + + let nonEmptyRecordLiteral = do + _equal + b <- expression + e <- Text.Megaparsec.many (do + _comma + c <- label + _equal + d <- expression + return (c, d) ) + m <- toMap ((a, b) : e) + return (RecordLit m) + + nonEmptyRecordType <|> nonEmptyRecordLiteral + + unionTypeOrLiteral = + nonEmptyUnionTypeOrLiteral + <|> return (Union mempty) + + nonEmptyUnionTypeOrLiteral = do + (f, kvs) <- loop + m <- toMap kvs + return (f m) + where + loop = do + a <- label + + let alternative0 = do + _equal + b <- expression + kvs <- Text.Megaparsec.many (do + _bar + c <- label + _colon + d <- expression + return (c, d) ) + return (UnionLit a b, kvs) + + let alternative1 = do + _colon + b <- expression + + let alternative2 = do + _bar + (f, kvs) <- loop + return (f, (a, b):kvs) + + let alternative3 = return (Union, [(a, b)]) + + alternative2 <|> alternative3 + + alternative0 <|> alternative1 + + listLiteral = (do + _openBracket + a <- Text.Megaparsec.sepBy expression _comma + _closeBracket + return (ListLit Nothing (Data.Sequence.fromList a)) ) "list literal" + +env :: Parser ImportType +env = do + _ <- Text.Parser.Char.text "env:" + a <- (alternative0 <|> alternative1) + whitespace + return (Env a) + where + alternative0 = bashEnvironmentVariable + + alternative1 = do + _ <- Text.Parser.Char.char '"' + a <- posixEnvironmentVariable + _ <- Text.Parser.Char.char '"' + return a + +localRaw :: Parser ImportType +localRaw = + choice + [ parentPath + , herePath + , homePath + , try absolutePath + ] + where + parentPath = do + _ <- ".." :: Parser Text + File (Directory segments) final <- file_ + + return (Local Here (File (Directory (segments ++ [".."])) final)) + + herePath = do + _ <- "." :: Parser Text + file <- file_ + + return (Local Here file) + + homePath = do + _ <- "~" :: Parser Text + file <- file_ + + return (Local Home file) + + absolutePath = do + file <- file_ + + return (Local Absolute file) + +local :: Parser ImportType +local = do + a <- localRaw + whitespace + return a + +http :: Parser ImportType +http = do + url <- httpRaw + whitespace + headers <- optional (do + _using + (importHashed_ <|> (_openParens *> importHashed_ <* _closeParens)) ) + return (Remote (url { headers })) + +missing :: Parser ImportType +missing = do + _missing + return Missing + +importType_ :: Parser ImportType +importType_ = do + let predicate c = + c == '~' || c == '.' || c == '/' || c == 'h' || c == 'e' || c == 'm' + + _ <- Text.Megaparsec.lookAhead (Text.Megaparsec.satisfy predicate) + + choice [ local, http, env, missing ] importHashed_ :: Parser ImportHashed importHashed_ = do 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 @@ -2,7 +2,93 @@ {-# LANGUAGE OverloadedStrings #-} -- | Parse Dhall tokens. Even though we don't have a tokenizer per-se this --- module is useful for keeping some small parsing utilities. -module Dhall.Parser.Token where +module Dhall.Parser.Token ( + whitespace, + bashEnvironmentVariable, + posixEnvironmentVariable, + file_, + label, + labels, + httpRaw, + hexdig, + identifier, + hexNumber, + doubleLiteral, + naturalLiteral, + integerLiteral, + _Optional, + _if, + _then, + _else, + _let, + _in, + _as, + _using, + _merge, + _constructors, + _Some, + _None, + _NaturalFold, + _NaturalBuild, + _NaturalIsZero, + _NaturalEven, + _NaturalOdd, + _NaturalToInteger, + _NaturalShow, + _IntegerShow, + _IntegerToDouble, + _DoubleShow, + _ListBuild, + _ListFold, + _ListLength, + _ListHead, + _ListLast, + _ListIndexed, + _ListReverse, + _OptionalFold, + _OptionalBuild, + _Bool, + _Natural, + _Integer, + _Double, + _Text, + _List, + _True, + _False, + _Type, + _Kind, + _Sort, + _equal, + _or, + _plus, + _textAppend, + _listAppend, + _and, + _times, + _doubleEqual, + _notEqual, + _dot, + _openBrace, + _closeBrace, + _openBracket, + _closeBracket, + _openAngle, + _closeAngle, + _bar, + _comma, + _openParens, + _closeParens, + _colon, + _at, + _missing, + _importAlt, + _combine, + _combineTypes, + _prefer, + _lambda, + _forall, + _arrow, + ) where import Dhall.Parser.Combinators @@ -83,7 +169,7 @@ whitespaceChunk :: Parser () whitespaceChunk = choice - [ void (Text.Parser.Char.satisfy predicate) + [ void (Dhall.Parser.Combinators.takeWhile1 predicate) , void (Text.Parser.Char.text "\r\n") , lineComment , blockComment @@ -115,18 +201,19 @@ lineComment :: Parser () lineComment = do _ <- Text.Parser.Char.text "--" - Text.Parser.Combinators.skipMany notEndOfLine + + let predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' + + _ <- Dhall.Parser.Combinators.takeWhile predicate + endOfLine + return () where endOfLine = void (Text.Parser.Char.char '\n' ) <|> void (Text.Parser.Char.text "\r\n") - notEndOfLine = void (Text.Parser.Char.satisfy predicate) - where - predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' - blockComment :: Parser () blockComment = do _ <- Text.Parser.Char.text "{-" @@ -136,10 +223,18 @@ blockCommentChunk = choice [ blockComment -- Nested block comment + , characters , character , endOfLine ] where + characters = void (Dhall.Parser.Combinators.takeWhile1 predicate) + where + predicate c = + '\x20' <= c && c <= '\x10FFFF' && c /= '-' && c /= '{' + || c == '\n' + || c == '\t' + character = void (Text.Parser.Char.satisfy predicate) where predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' @@ -155,7 +250,6 @@ blockCommentChunk blockCommentContinue - simpleLabel :: Parser Text simpleLabel = try (do c <- Text.Parser.Char.satisfy headCharacter @@ -337,7 +431,7 @@ h16 = range 1 3 (satisfy hexdig) ls32 :: Parser Text -ls32 = (h16 <> ":" <> h16) <|> ipV4Address +ls32 = try (h16 <> ":" <> h16) <|> ipV4Address ipV4Address :: Parser Text ipV4Address = decOctet <> "." <> decOctet <> "." <> decOctet <> "." <> decOctet @@ -401,6 +495,9 @@ reserved :: Data.Text.Text -> Parser () reserved x = do _ <- Text.Parser.Char.text x; whitespace +reservedChar :: Char -> Parser () +reservedChar c = do _ <- Text.Parser.Char.char c; whitespace + keyword :: Data.Text.Text -> Parser () keyword x = try (do _ <- Text.Parser.Char.text x; nonemptyWhitespace) @@ -431,6 +528,12 @@ _constructors :: Parser () _constructors = keyword "constructors" +_Some :: Parser () +_Some = reserved "Some" + +_None :: Parser () +_None = reserved "None" + _NaturalFold :: Parser () _NaturalFold = reserved "Natural/fold" @@ -521,26 +624,29 @@ _Kind :: Parser () _Kind = reserved "Kind" +_Sort :: Parser () +_Sort = reserved "Sort" + _equal :: Parser () -_equal = reserved "=" +_equal = reservedChar '=' _or :: Parser () _or = reserved "||" _plus :: Parser () -_plus = reserved "+" +_plus = reservedChar '+' _textAppend :: Parser () _textAppend = reserved "++" _listAppend :: Parser () -_listAppend = reserved "#" +_listAppend = reservedChar '#' _and :: Parser () _and = reserved "&&" _times :: Parser () -_times = reserved "*" +_times = reservedChar '*' _doubleEqual :: Parser () _doubleEqual = reserved "==" @@ -549,49 +655,49 @@ _notEqual = reserved "!=" _dot :: Parser () -_dot = reserved "." +_dot = reservedChar '.' _openBrace :: Parser () -_openBrace = reserved "{" +_openBrace = reservedChar '{' _closeBrace :: Parser () -_closeBrace = reserved "}" +_closeBrace = reservedChar '}' _openBracket :: Parser () -_openBracket = reserved "[" +_openBracket = reservedChar '[' _closeBracket :: Parser () -_closeBracket = reserved "]" +_closeBracket = reservedChar ']' _openAngle :: Parser () -_openAngle = reserved "<" +_openAngle = reservedChar '<' _closeAngle :: Parser () -_closeAngle = reserved ">" +_closeAngle = reservedChar '>' _bar :: Parser () -_bar = reserved "|" +_bar = reservedChar '|' _comma :: Parser () -_comma = reserved "," +_comma = reservedChar ',' _openParens :: Parser () -_openParens = reserved "(" +_openParens = reservedChar '(' _closeParens :: Parser () -_closeParens = reserved ")" +_closeParens = reservedChar ')' _colon :: Parser () -_colon = reserved ":" +_colon = reservedChar ':' _at :: Parser () -_at = reserved "@" +_at = reservedChar '@' _missing :: Parser () _missing = reserved "missing" _importAlt :: Parser () -_importAlt = reserved "?" +_importAlt = reservedChar '?' _combine :: Parser () _combine = do diff --git a/src/Dhall/Pretty.hs b/src/Dhall/Pretty.hs --- a/src/Dhall/Pretty.hs +++ b/src/Dhall/Pretty.hs @@ -6,6 +6,10 @@ Ann(..) , annToAnsiStyle , prettyExpr + + , CharacterSet(..) + , prettyCharacterSet + , layoutOpts ) where @@ -17,4 +21,3 @@ layoutOpts = Pretty.defaultLayoutOptions { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } - diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -10,840 +10,879 @@ Ann(..) , annToAnsiStyle , prettyExpr - , prettyVar - , pretty - , escapeText - - , prettyConst - , prettyLabel - , prettyLabels - , prettyNatural - , prettyNumber - , prettyScientific - , prettyToStrictText - , prettyToString - - , docToStrictText - - , builtin - , keyword - , literal - , operator - - , colon - , comma - , dot - , equals - , forall - , label - , lambda - , langle - , lbrace - , lbracket - , lparen - , pipe - , rangle - , rarrow - , rbrace - , rbracket - , rparen - ) where - -import {-# SOURCE #-} Dhall.Core - -#if MIN_VERSION_base(4,8,0) -#else -import Control.Applicative (Applicative(..), (<$>)) -#endif -import Data.Foldable -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) -import Data.Monoid ((<>)) -import Data.Scientific (Scientific) -import Data.Set (Set) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty, space) -import Numeric.Natural (Natural) -import Prelude hiding (succ) -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal - -import qualified Data.Char -import qualified Data.HashMap.Strict.InsOrd -import qualified Data.HashSet -import qualified Data.List -import qualified Data.Set -import qualified Data.Text as Text -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty - -{-| Annotation type used to tag elements in a pretty-printed document for - syntax highlighting purposes --} -data Ann - = Keyword -- ^ Used for syntactic keywords - | Syntax -- ^ Syntax punctuation such as commas, parenthesis, and braces - | Label -- ^ Record labels - | Literal -- ^ Literals such as integers and strings - | Builtin -- ^ Builtin types and values - | Operator -- ^ Operators - -{-| Convert annotations to their corresponding color for syntax highlighting - purposes --} -annToAnsiStyle :: Ann -> Terminal.AnsiStyle -annToAnsiStyle Keyword = Terminal.bold <> Terminal.colorDull Terminal.Green -annToAnsiStyle Syntax = Terminal.bold <> Terminal.colorDull Terminal.Green -annToAnsiStyle Label = mempty -annToAnsiStyle Literal = Terminal.colorDull Terminal.Magenta -annToAnsiStyle Builtin = Terminal.underlined -annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green - --- | Pretty print an expression -prettyExpr :: Pretty a => Expr s a -> Doc Ann -prettyExpr = prettyExpression - -{-| Internal utility for pretty-printing, used when generating element lists - to supply to `enclose` or `enclose'`. This utility indicates that the - compact represent is the same as the multi-line representation for each - element --} -duplicate :: a -> (a, a) -duplicate x = (x, x) - --- Annotation helpers -keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann -keyword = Pretty.annotate Keyword -syntax = Pretty.annotate Syntax -label = Pretty.annotate Label -literal = Pretty.annotate Literal -builtin = Pretty.annotate Builtin -operator = Pretty.annotate Operator - -comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, rarrow, backtick, dollar, colon, lambda, forall, equals, dot :: Doc Ann -comma = syntax Pretty.comma -lbracket = syntax Pretty.lbracket -rbracket = syntax Pretty.rbracket -langle = syntax Pretty.langle -rangle = syntax Pretty.rangle -lbrace = syntax Pretty.lbrace -rbrace = syntax Pretty.rbrace -lparen = syntax Pretty.lparen -rparen = syntax Pretty.rparen -pipe = syntax Pretty.pipe -rarrow = syntax "→" -backtick = syntax "`" -dollar = syntax "$" -colon = syntax ":" -lambda = syntax "λ" -forall = syntax "∀" -equals = syntax "=" -dot = syntax "." - --- | Pretty-print a list -list :: [Doc Ann] -> Doc Ann -list [] = lbracket <> rbracket -list docs = - enclose - (lbracket <> space) - (lbracket <> space) - (comma <> space) - (comma <> space) - (space <> rbracket) - rbracket - (fmap duplicate docs) - --- | Pretty-print union types and literals -angles :: [(Doc Ann, Doc Ann)] -> Doc Ann -angles [] = langle <> rangle -angles docs = - enclose - (langle <> space) - (langle <> space) - (space <> pipe <> space) - (pipe <> space) - (space <> rangle) - rangle - docs - --- | Pretty-print record types and literals -braces :: [(Doc Ann, Doc Ann)] -> Doc Ann -braces [] = lbrace <> rbrace -braces docs = - enclose - (lbrace <> space) - (lbrace <> space) - (comma <> space) - (comma <> space) - (space <> rbrace) - rbrace - docs - --- | Pretty-print anonymous functions and function types -arrows :: [(Doc Ann, Doc Ann)] -> Doc Ann -arrows = - enclose' - "" - " " - (" " <> rarrow <> " ") - (rarrow <> space) - -{-| Format an expression that holds a variable number of elements, such as a - list, record, or union --} -enclose - :: Doc ann - -- ^ Beginning document for compact representation - -> Doc ann - -- ^ Beginning document for multi-line representation - -> Doc ann - -- ^ Separator for compact representation - -> Doc ann - -- ^ Separator for multi-line representation - -> Doc ann - -- ^ Ending document for compact representation - -> Doc ann - -- ^ Ending document for multi-line representation - -> [(Doc ann, Doc ann)] - -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ - -> Doc ann -enclose beginShort _ _ _ endShort _ [] = - beginShort <> endShort - where -enclose beginShort beginLong sepShort sepLong endShort endLong docs = - Pretty.group - (Pretty.flatAlt - (Pretty.align - (mconcat (zipWith combineLong (beginLong : repeat sepLong) docsLong) <> endLong) - ) - (mconcat (zipWith combineShort (beginShort : repeat sepShort) docsShort) <> endShort) - ) - where - docsShort = fmap fst docs - - docsLong = fmap snd docs - - combineLong x y = x <> y <> Pretty.hardline - - combineShort x y = x <> y - -{-| Format an expression that holds a variable number of elements without a - trailing document such as nested `let`, nested lambdas, or nested `forall`s --} -enclose' - :: Doc ann - -- ^ Beginning document for compact representation - -> Doc ann - -- ^ Beginning document for multi-line representation - -> Doc ann - -- ^ Separator for compact representation - -> Doc ann - -- ^ Separator for multi-line representation - -> [(Doc ann, Doc ann)] - -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ - -> Doc ann -enclose' beginShort beginLong sepShort sepLong docs = - Pretty.group (Pretty.flatAlt long short) - where - longLines = zipWith (<>) (beginLong : repeat sepLong) docsLong - - long = - Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) - - short = mconcat (zipWith (<>) (beginShort : repeat sepShort) docsShort) - - docsShort = fmap fst docs - - docsLong = fmap snd docs - -alpha :: Char -> Bool -alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A') - -digit :: Char -> Bool -digit c = '\x30' <= c && c <= '\x39' - -headCharacter :: Char -> Bool -headCharacter c = alpha c || c == '_' - -tailCharacter :: Char -> Bool -tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/' - -prettyLabel :: Text -> Doc Ann -prettyLabel a = label doc - where - doc = - case Text.uncons a of - Just (h, t) - | headCharacter h && Text.all tailCharacter t && not (Data.HashSet.member a reservedIdentifiers) - -> Pretty.pretty a - _ -> backtick <> Pretty.pretty a <> backtick - -prettyLabels :: Set Text -> Doc Ann -prettyLabels a - | Data.Set.null a = - lbrace <> rbrace - | otherwise = - braces (map (duplicate . prettyLabel) (Data.Set.toList a)) - -prettyNumber :: Integer -> Doc Ann -prettyNumber = literal . Pretty.pretty - -prettyNatural :: Natural -> Doc Ann -prettyNatural = literal . Pretty.pretty - -prettyScientific :: Scientific -> Doc Ann -prettyScientific = literal . Pretty.pretty . show - -prettyChunks :: Pretty a => Chunks s a -> Doc Ann -prettyChunks (Chunks a b) = - if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b - then Pretty.flatAlt long short - else short - where - long = - Pretty.align - ( literal ("''" <> Pretty.hardline) - <> Pretty.align - (foldMap prettyMultilineChunk a <> prettyMultilineBuilder b) - <> literal "''" - ) - - short = - literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") - - hasNewLine = Text.any (== '\n') - - prettyMultilineChunk (c, d) = - prettyMultilineBuilder c - <> dollar - <> lbrace - <> prettyExpression d - <> rbrace - - prettyMultilineBuilder builder = literal (mconcat docs) - where - lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder) - - docs = - Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines) - - prettyChunk (c, d) = - prettyText c <> syntax "${" <> prettyExpression d <> syntax rbrace - - prettyText t = literal (Pretty.pretty (escapeText t)) - -prettyConst :: Const -> Doc Ann -prettyConst Type = builtin "Type" -prettyConst Kind = builtin "Kind" - -prettyVar :: Var -> Doc Ann -prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) -prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyNumber n)) - -prettyExpression :: Pretty a => Expr s a -> Doc Ann -prettyExpression a0@(Lam _ _ _) = arrows (fmap duplicate (docs a0)) - where - docs (Lam a b c) = Pretty.group (Pretty.flatAlt long short) : docs c - where - long = (lambda <> space) - <> Pretty.align - ( (lparen <> space) - <> prettyLabel a - <> Pretty.hardline - <> (colon <> space) - <> prettyExpression b - <> Pretty.hardline - <> rparen - ) - - short = (lambda <> lparen) - <> prettyLabel a - <> (space <> colon <> space) - <> prettyExpression b - <> rparen - docs (Note _ c) = docs c - docs c = [ prettyExpression c ] -prettyExpression a0@(BoolIf _ _ _) = - Pretty.group (Pretty.flatAlt long short) - where - prefixesLong = - " " - : cycle - [ Pretty.hardline <> keyword "then" <> " " - , Pretty.hardline <> keyword "else" <> " " - ] - - prefixesShort = - "" - : cycle - [ space <> keyword "then" <> space - , space <> keyword "else" <> space - ] - - longLines = zipWith (<>) prefixesLong (docsLong a0) - - long = - Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) - - short = mconcat (zipWith (<>) prefixesShort (docsShort a0)) - - docsLong (BoolIf a b c) = - docLong ++ docsLong c - where - docLong = - [ keyword "if" <> " " <> prettyExpression a - , prettyExpression b - ] - docsLong (Note _ c) = docsLong c - docsLong c = [ prettyExpression c ] - - docsShort (BoolIf a b c) = - docShort ++ docsShort c - where - docShort = - [ keyword "if" <> " " <> prettyExpression a - , prettyExpression b - ] - docsShort (Note _ c) = docsShort c - docsShort c = [ prettyExpression c ] -prettyExpression a0@(Let _ _ _ _) = - enclose' "" " " (space <> keyword "in" <> space) (Pretty.hardline <> keyword "in" <> " ") - (fmap duplicate (docs a0)) - where - docs (Let a Nothing c d) = - Pretty.group (Pretty.flatAlt long short) : docs d - where - long = keyword "let" <> space - <> Pretty.align - ( prettyLabel a - <> space <> equals - <> Pretty.hardline - <> " " - <> prettyExpression c - ) - - short = keyword "let" <> space - <> prettyLabel a - <> (space <> equals <> space) - <> prettyExpression c - docs (Let a (Just b) c d) = - Pretty.group (Pretty.flatAlt long short) : docs d - where - long = keyword "let" <> space - <> Pretty.align - ( prettyLabel a - <> Pretty.hardline - <> colon <> space - <> prettyExpression b - <> Pretty.hardline - <> equals <> space - <> prettyExpression c - ) - - short = keyword "let" <> space - <> prettyLabel a - <> space <> colon <> space - <> prettyExpression b - <> space <> equals <> space - <> prettyExpression c - docs (Note _ d) = - docs d - docs d = - [ prettyExpression d ] -prettyExpression a0@(Pi _ _ _) = - arrows (fmap duplicate (docs a0)) - where - docs (Pi "_" b c) = prettyOperatorExpression b : docs c - docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c - where - long = forall <> space - <> Pretty.align - ( lparen <> space - <> prettyLabel a - <> Pretty.hardline - <> colon <> space - <> prettyExpression b - <> Pretty.hardline - <> rparen - ) - - short = forall <> lparen - <> prettyLabel a - <> space <> colon <> space - <> prettyExpression b - <> rparen - docs (Note _ c) = docs c - docs c = [ prettyExpression c ] -prettyExpression (Note _ a) = - prettyExpression a -prettyExpression a0 = - prettyAnnotatedExpression a0 - -prettyAnnotatedExpression :: Pretty a => Expr s a -> Doc Ann -prettyAnnotatedExpression (Merge a b (Just c)) = - Pretty.group (Pretty.flatAlt long short) - where - long = - Pretty.align - ( keyword "merge" - <> Pretty.hardline - <> prettyImportExpression a - <> Pretty.hardline - <> prettyImportExpression b - <> Pretty.hardline - <> colon <> space - <> prettyApplicationExpression c - ) - - short = keyword "merge" <> space - <> prettyImportExpression a - <> " " - <> 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 - <> prettyImportExpression a - <> Pretty.hardline - <> prettyImportExpression b - ) - - short = keyword "merge" <> space - <> prettyImportExpression a - <> " " - <> prettyImportExpression b -prettyAnnotatedExpression a0@(Annot _ _) = - enclose' - "" - " " - (" " <> colon <> " ") - (colon <> space) - (fmap duplicate (docs a0)) - where - docs (Annot a b) = prettyOperatorExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyExpression b ] -prettyAnnotatedExpression (ListLit (Just a) b) = - list (map prettyExpression (Data.Foldable.toList b)) - <> " : " - <> prettyApplicationExpression (App List a) -prettyAnnotatedExpression (OptionalLit a b) = - list (map prettyExpression (Data.Foldable.toList b)) - <> " : " - <> prettyApplicationExpression (App Optional a) -prettyAnnotatedExpression (Note _ a) = - prettyAnnotatedExpression a -prettyAnnotatedExpression a0 = - prettyOperatorExpression a0 - -prettyOperatorExpression :: Pretty a => Expr s a -> Doc Ann -prettyOperatorExpression = prettyImportAltExpression - -prettyImportAltExpression :: Pretty a => Expr s a -> Doc Ann -prettyImportAltExpression a0@(ImportAlt _ _) = - enclose' "" " " (space <> operator "?" <> space) (operator "?" <> " ") (fmap duplicate (docs a0)) - where - docs (ImportAlt a b) = prettyOrExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyOrExpression b ] -prettyImportAltExpression (Note _ a) = - prettyImportAltExpression a -prettyImportAltExpression a0 = - prettyOrExpression a0 - -prettyOrExpression :: Pretty a => Expr s a -> Doc Ann -prettyOrExpression a0@(BoolOr _ _) = - enclose' "" " " (space <> operator "||" <> space) (operator "||" <> " ") (fmap duplicate (docs a0)) - where - docs (BoolOr a b) = prettyPlusExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyPlusExpression b ] -prettyOrExpression (Note _ a) = - prettyOrExpression a -prettyOrExpression a0 = - prettyPlusExpression a0 - -prettyPlusExpression :: Pretty a => Expr s a -> Doc Ann -prettyPlusExpression a0@(NaturalPlus _ _) = - enclose' "" " " (" " <> operator "+" <> " ") (operator "+" <> " ") (fmap duplicate (docs a0)) - where - docs (NaturalPlus a b) = prettyTextAppendExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyTextAppendExpression b ] -prettyPlusExpression (Note _ a) = - prettyPlusExpression a -prettyPlusExpression a0 = - prettyTextAppendExpression a0 - -prettyTextAppendExpression :: Pretty a => Expr s a -> Doc Ann -prettyTextAppendExpression a0@(TextAppend _ _) = - enclose' "" " " (" " <> operator "++" <> " ") (operator "++" <> " ") (fmap duplicate (docs a0)) - where - docs (TextAppend a b) = prettyListAppendExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyListAppendExpression b ] -prettyTextAppendExpression (Note _ a) = - prettyTextAppendExpression a -prettyTextAppendExpression a0 = - prettyListAppendExpression a0 - -prettyListAppendExpression :: Pretty a => Expr s a -> Doc Ann -prettyListAppendExpression a0@(ListAppend _ _) = - enclose' "" " " (" " <> operator "#" <> " ") (operator "#" <> " ") (fmap duplicate (docs a0)) - where - docs (ListAppend a b) = prettyAndExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyAndExpression b ] -prettyListAppendExpression (Note _ a) = - prettyListAppendExpression a -prettyListAppendExpression a0 = - prettyAndExpression a0 - -prettyAndExpression :: Pretty a => Expr s a -> Doc Ann -prettyAndExpression a0@(BoolAnd _ _) = - enclose' "" " " (" " <> operator "&&" <> " ") (operator "&&" <> " ") (fmap duplicate (docs a0)) - where - docs (BoolAnd a b) = prettyCombineExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyCombineExpression b ] -prettyAndExpression (Note _ a) = - prettyAndExpression a -prettyAndExpression a0 = - prettyCombineExpression a0 - -prettyCombineExpression :: Pretty a => Expr s a -> Doc Ann -prettyCombineExpression a0@(Combine _ _) = - enclose' "" " " (" " <> operator "∧" <> " ") (operator "∧" <> " ") (fmap duplicate (docs a0)) - where - docs (Combine a b) = prettyPreferExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyPreferExpression b ] -prettyCombineExpression (Note _ a) = - prettyCombineExpression a -prettyCombineExpression a0 = - prettyPreferExpression a0 - -prettyPreferExpression :: Pretty a => Expr s a -> Doc Ann -prettyPreferExpression a0@(Prefer _ _) = - enclose' "" " " (" " <> operator "⫽" <> " ") (operator "⫽" <> " ") (fmap duplicate (docs a0)) - where - docs (Prefer a b) = prettyCombineTypesExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyCombineTypesExpression b ] -prettyPreferExpression (Note _ a) = - prettyPreferExpression a -prettyPreferExpression a0 = - prettyCombineTypesExpression a0 - -prettyCombineTypesExpression :: Pretty a => Expr s a -> Doc Ann -prettyCombineTypesExpression a0@(CombineTypes _ _) = - enclose' "" " " (" " <> operator "⩓" <> " ") (operator "⩓" <> " ") (fmap duplicate (docs a0)) - where - docs (CombineTypes a b) = prettyTimesExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyTimesExpression b ] -prettyCombineTypesExpression (Note _ a) = - prettyCombineTypesExpression a -prettyCombineTypesExpression a0 = - prettyTimesExpression a0 - -prettyTimesExpression :: Pretty a => Expr s a -> Doc Ann -prettyTimesExpression a0@(NaturalTimes _ _) = - enclose' "" " " (" " <> operator "*" <> " ") (operator "*" <> " ") (fmap duplicate (docs a0)) - where - docs (NaturalTimes a b) = prettyEqualExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyEqualExpression b ] -prettyTimesExpression (Note _ a) = - prettyTimesExpression a -prettyTimesExpression a0 = - prettyEqualExpression a0 - -prettyEqualExpression :: Pretty a => Expr s a -> Doc Ann -prettyEqualExpression a0@(BoolEQ _ _) = - enclose' "" " " (" " <> operator "==" <> " ") (operator "==" <> " ") (fmap duplicate (docs a0)) - where - docs (BoolEQ a b) = prettyNotEqualExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyNotEqualExpression b ] -prettyEqualExpression (Note _ a) = - prettyEqualExpression a -prettyEqualExpression a0 = - prettyNotEqualExpression a0 - -prettyNotEqualExpression :: Pretty a => Expr s a -> Doc Ann -prettyNotEqualExpression a0@(BoolNE _ _) = - enclose' "" " " (" " <> operator "!=" <> " ") (operator "!=" <> " ") (fmap duplicate (docs a0)) - where - docs (BoolNE a b) = prettyApplicationExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyApplicationExpression b ] -prettyNotEqualExpression (Note _ a) = - prettyNotEqualExpression a -prettyNotEqualExpression a0 = - prettyApplicationExpression a0 - -prettyApplicationExpression :: Pretty a => Expr s a -> Doc Ann -prettyApplicationExpression a0 = case a0 of - App _ _ -> result - Constructors _ -> result - Note _ b -> prettyApplicationExpression b - _ -> prettyImportExpression a0 - where - result = enclose' "" "" " " "" (fmap duplicate (reverse (docs a0))) - - docs (App a b) = prettyImportExpression b : docs a - docs (Constructors b) = [ prettyImportExpression b , keyword "constructors" ] - docs (Note _ b) = docs b - docs b = [ prettyImportExpression b ] - -prettyImportExpression :: Pretty a => Expr s a -> Doc Ann -prettyImportExpression (Embed a) = - Pretty.pretty a -prettyImportExpression (Note _ a) = - prettyImportExpression a -prettyImportExpression a0 = - prettySelectorExpression a0 - -prettySelectorExpression :: Pretty a => Expr s a -> Doc Ann -prettySelectorExpression (Field a b) = - prettySelectorExpression a <> dot <> prettyLabel b -prettySelectorExpression (Project a b) = - prettySelectorExpression a <> dot <> prettyLabels b -prettySelectorExpression (Note _ b) = - prettySelectorExpression b -prettySelectorExpression a0 = - prettyPrimitiveExpression a0 - -prettyPrimitiveExpression :: Pretty a => Expr s a -> Doc Ann -prettyPrimitiveExpression (Var a) = - prettyVar a -prettyPrimitiveExpression (Const k) = - prettyConst k -prettyPrimitiveExpression Bool = - builtin "Bool" -prettyPrimitiveExpression Natural = - builtin "Natural" -prettyPrimitiveExpression NaturalFold = - builtin "Natural/fold" -prettyPrimitiveExpression NaturalBuild = - builtin "Natural/build" -prettyPrimitiveExpression NaturalIsZero = - builtin "Natural/isZero" -prettyPrimitiveExpression NaturalEven = - builtin "Natural/even" -prettyPrimitiveExpression NaturalOdd = - builtin "Natural/odd" -prettyPrimitiveExpression NaturalToInteger = - builtin "Natural/toInteger" -prettyPrimitiveExpression NaturalShow = - builtin "Natural/show" -prettyPrimitiveExpression Integer = - builtin "Integer" -prettyPrimitiveExpression IntegerShow = - builtin "Integer/show" -prettyPrimitiveExpression IntegerToDouble = - builtin "Integer/toDouble" -prettyPrimitiveExpression Double = - builtin "Double" -prettyPrimitiveExpression DoubleShow = - builtin "Double/show" -prettyPrimitiveExpression Text = - builtin "Text" -prettyPrimitiveExpression List = - builtin "List" -prettyPrimitiveExpression ListBuild = - builtin "List/build" -prettyPrimitiveExpression ListFold = - builtin "List/fold" -prettyPrimitiveExpression ListLength = - builtin "List/length" -prettyPrimitiveExpression ListHead = - builtin "List/head" -prettyPrimitiveExpression ListLast = - builtin "List/last" -prettyPrimitiveExpression ListIndexed = - builtin "List/indexed" -prettyPrimitiveExpression ListReverse = - builtin "List/reverse" -prettyPrimitiveExpression Optional = - builtin "Optional" -prettyPrimitiveExpression OptionalFold = - builtin "Optional/fold" -prettyPrimitiveExpression OptionalBuild = - builtin "Optional/build" -prettyPrimitiveExpression (BoolLit True) = - builtin "True" -prettyPrimitiveExpression (BoolLit False) = - builtin "False" -prettyPrimitiveExpression (IntegerLit a) - | 0 <= a = literal "+" <> prettyNumber a - | otherwise = prettyNumber a -prettyPrimitiveExpression (NaturalLit a) = - prettyNatural a -prettyPrimitiveExpression (DoubleLit a) = - prettyScientific a -prettyPrimitiveExpression (TextLit a) = - prettyChunks a -prettyPrimitiveExpression (Record a) = - prettyRecord a -prettyPrimitiveExpression (RecordLit a) = - prettyRecordLit a -prettyPrimitiveExpression (Union a) = - prettyUnion a -prettyPrimitiveExpression (UnionLit a b c) = - prettyUnionLit a b c -prettyPrimitiveExpression (ListLit Nothing b) = - list (map prettyExpression (Data.Foldable.toList b)) -prettyPrimitiveExpression (Note _ b) = - prettyPrimitiveExpression b -prettyPrimitiveExpression a = - Pretty.group (Pretty.flatAlt long short) - where - long = - Pretty.align - (lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen) - - short = lparen <> prettyExpression a <> rparen - -prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr s a) -> (Doc Ann, Doc Ann) -prettyKeyValue separator (key, value) = - ( prettyLabel key <> " " <> separator <> " " <> prettyExpression value - , prettyLabel key - <> " " - <> separator - <> long - ) - where - long = Pretty.hardline <> " " <> prettyExpression value - -prettyRecord :: Pretty a => InsOrdHashMap Text (Expr s a) -> Doc Ann -prettyRecord = - braces . map (prettyKeyValue colon) . Data.HashMap.Strict.InsOrd.toList - -prettyRecordLit :: Pretty a => InsOrdHashMap Text (Expr s a) -> Doc Ann -prettyRecordLit a - | Data.HashMap.Strict.InsOrd.null a = - lbrace <> equals <> rbrace - | otherwise - = braces (map (prettyKeyValue equals) (Data.HashMap.Strict.InsOrd.toList a)) - -prettyUnion :: Pretty a => InsOrdHashMap Text (Expr s a) -> Doc Ann -prettyUnion = - angles . map (prettyKeyValue colon) . Data.HashMap.Strict.InsOrd.toList - -prettyUnionLit - :: Pretty a => Text -> Expr s a -> InsOrdHashMap Text (Expr s a) -> Doc Ann -prettyUnionLit a b c = - angles (front : map adapt (Data.HashMap.Strict.InsOrd.toList c)) - where - front = prettyKeyValue equals (a, b) - - adapt = prettyKeyValue colon + + , CharacterSet(..) + , prettyCharacterSet + + , prettyVar + , pretty + , escapeText + + , prettyConst + , prettyLabel + , prettyLabels + , prettyNatural + , prettyNumber + , prettyScientific + , prettyToStrictText + , prettyToString + + , docToStrictText + + , builtin + , keyword + , literal + , operator + + , colon + , comma + , dot + , equals + , forall + , label + , lambda + , langle + , lbrace + , lbracket + , lparen + , pipe + , rangle + , rarrow + , rbrace + , rbracket + , rparen + ) where + +import {-# SOURCE #-} Dhall.Core + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative (Applicative(..), (<$>)) +#endif +import Data.Foldable +import Data.Monoid ((<>)) +import Data.Scientific (Scientific) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc, Pretty, space) +import Dhall.Map (Map) +import Numeric.Natural (Natural) +import Prelude hiding (succ) +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal + +import qualified Data.Char +import qualified Data.HashSet +import qualified Data.List +import qualified Data.Set +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty +import qualified Dhall.Map + +{-| Annotation type used to tag elements in a pretty-printed document for + syntax highlighting purposes +-} +data Ann + = Keyword -- ^ Used for syntactic keywords + | Syntax -- ^ Syntax punctuation such as commas, parenthesis, and braces + | Label -- ^ Record labels + | Literal -- ^ Literals such as integers and strings + | Builtin -- ^ Builtin types and values + | Operator -- ^ Operators + +{-| Convert annotations to their corresponding color for syntax highlighting + purposes +-} +annToAnsiStyle :: Ann -> Terminal.AnsiStyle +annToAnsiStyle Keyword = Terminal.bold <> Terminal.colorDull Terminal.Green +annToAnsiStyle Syntax = Terminal.bold <> Terminal.colorDull Terminal.Green +annToAnsiStyle Label = mempty +annToAnsiStyle Literal = Terminal.colorDull Terminal.Magenta +annToAnsiStyle Builtin = Terminal.underlined +annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green + +data CharacterSet = ASCII | Unicode + +-- | Pretty print an expression +prettyExpr :: Pretty a => Expr s a -> Doc Ann +prettyExpr = prettyCharacterSet Unicode + +{-| Internal utility for pretty-printing, used when generating element lists + to supply to `enclose` or `enclose'`. This utility indicates that the + compact represent is the same as the multi-line representation for each + element +-} +duplicate :: a -> (a, a) +duplicate x = (x, x) + +-- Annotation helpers +keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann +keyword = Pretty.annotate Keyword +syntax = Pretty.annotate Syntax +label = Pretty.annotate Label +literal = Pretty.annotate Literal +builtin = Pretty.annotate Builtin +operator = Pretty.annotate Operator + +comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, backtick, dollar, colon, equals, dot :: Doc Ann +comma = syntax Pretty.comma +lbracket = syntax Pretty.lbracket +rbracket = syntax Pretty.rbracket +langle = syntax Pretty.langle +rangle = syntax Pretty.rangle +lbrace = syntax Pretty.lbrace +rbrace = syntax Pretty.rbrace +lparen = syntax Pretty.lparen +rparen = syntax Pretty.rparen +pipe = syntax Pretty.pipe +backtick = syntax "`" +dollar = syntax "$" +colon = syntax ":" +equals = syntax "=" +dot = syntax "." + +lambda :: CharacterSet -> Doc Ann +lambda Unicode = syntax "λ" +lambda ASCII = syntax "\\" + +forall :: CharacterSet -> Doc Ann +forall Unicode = syntax "∀" +forall ASCII = syntax "forall " + +rarrow :: CharacterSet -> Doc Ann +rarrow Unicode = syntax "→" +rarrow ASCII = syntax "->" + +-- | Pretty-print a list +list :: [Doc Ann] -> Doc Ann +list [] = lbracket <> rbracket +list docs = + enclose + (lbracket <> space) + (lbracket <> space) + (comma <> space) + (comma <> space) + (space <> rbracket) + rbracket + (fmap duplicate docs) + +-- | Pretty-print union types and literals +angles :: [(Doc Ann, Doc Ann)] -> Doc Ann +angles [] = langle <> rangle +angles docs = + enclose + (langle <> space) + (langle <> space) + (space <> pipe <> space) + (pipe <> space) + (space <> rangle) + rangle + docs + +-- | Pretty-print record types and literals +braces :: [(Doc Ann, Doc Ann)] -> Doc Ann +braces [] = lbrace <> rbrace +braces docs = + enclose + (lbrace <> space) + (lbrace <> space) + (comma <> space) + (comma <> space) + (space <> rbrace) + rbrace + docs + +-- | Pretty-print anonymous functions and function types +arrows :: CharacterSet -> [(Doc Ann, Doc Ann)] -> Doc Ann +arrows characterSet = + enclose' + "" + " " + (" " <> rarrow characterSet <> " ") + (rarrow characterSet <> space) + +{-| Format an expression that holds a variable number of elements, such as a + list, record, or union +-} +enclose + :: Doc ann + -- ^ Beginning document for compact representation + -> Doc ann + -- ^ Beginning document for multi-line representation + -> Doc ann + -- ^ Separator for compact representation + -> Doc ann + -- ^ Separator for multi-line representation + -> Doc ann + -- ^ Ending document for compact representation + -> Doc ann + -- ^ Ending document for multi-line representation + -> [(Doc ann, Doc ann)] + -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ + -> Doc ann +enclose beginShort _ _ _ endShort _ [] = + beginShort <> endShort + where +enclose beginShort beginLong sepShort sepLong endShort endLong docs = + Pretty.group + (Pretty.flatAlt + (Pretty.align + (mconcat (zipWith combineLong (beginLong : repeat sepLong) docsLong) <> endLong) + ) + (mconcat (zipWith combineShort (beginShort : repeat sepShort) docsShort) <> endShort) + ) + where + docsShort = fmap fst docs + + docsLong = fmap snd docs + + combineLong x y = x <> y <> Pretty.hardline + + combineShort x y = x <> y + +{-| Format an expression that holds a variable number of elements without a + trailing document such as nested `let`, nested lambdas, or nested `forall`s +-} +enclose' + :: Doc ann + -- ^ Beginning document for compact representation + -> Doc ann + -- ^ Beginning document for multi-line representation + -> Doc ann + -- ^ Separator for compact representation + -> Doc ann + -- ^ Separator for multi-line representation + -> [(Doc ann, Doc ann)] + -- ^ Elements to format, each of which is a pair: @(compact, multi-line)@ + -> Doc ann +enclose' beginShort beginLong sepShort sepLong docs = + Pretty.group (Pretty.flatAlt long short) + where + longLines = zipWith (<>) (beginLong : repeat sepLong) docsLong + + long = + Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) + + short = mconcat (zipWith (<>) (beginShort : repeat sepShort) docsShort) + + docsShort = fmap fst docs + + docsLong = fmap snd docs + +alpha :: Char -> Bool +alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A') + +digit :: Char -> Bool +digit c = '\x30' <= c && c <= '\x39' + +headCharacter :: Char -> Bool +headCharacter c = alpha c || c == '_' + +tailCharacter :: Char -> Bool +tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/' + +prettyLabel :: Text -> Doc Ann +prettyLabel a = label doc + where + doc = + case Text.uncons a of + Just (h, t) + | headCharacter h && Text.all tailCharacter t && not (Data.HashSet.member a reservedIdentifiers) + -> Pretty.pretty a + _ -> backtick <> Pretty.pretty a <> backtick + +prettyLabels :: Set Text -> Doc Ann +prettyLabels a + | Data.Set.null a = + lbrace <> rbrace + | otherwise = + braces (map (duplicate . prettyLabel) (Data.Set.toList a)) + +prettyNumber :: Integer -> Doc Ann +prettyNumber = literal . Pretty.pretty + +prettyNatural :: Natural -> Doc Ann +prettyNatural = literal . Pretty.pretty + +prettyScientific :: Scientific -> Doc Ann +prettyScientific = literal . Pretty.pretty . show + +prettyConst :: Const -> Doc Ann +prettyConst Type = builtin "Type" +prettyConst Kind = builtin "Kind" +prettyConst Sort = builtin "Sort" + +prettyVar :: Var -> Doc Ann +prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) +prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyNumber n)) + +prettyCharacterSet :: Pretty a => CharacterSet -> Expr s a -> Doc Ann +prettyCharacterSet characterSet = prettyExpression + where + prettyExpression a0@(Lam _ _ _) = + arrows characterSet (fmap duplicate (docs a0)) + where + docs (Lam a b c) = Pretty.group (Pretty.flatAlt long short) : docs c + where + long = (lambda characterSet <> space) + <> Pretty.align + ( (lparen <> space) + <> prettyLabel a + <> Pretty.hardline + <> (colon <> space) + <> prettyExpression b + <> Pretty.hardline + <> rparen + ) + + short = (lambda characterSet <> lparen) + <> prettyLabel a + <> (space <> colon <> space) + <> prettyExpression b + <> rparen + docs (Note _ c) = docs c + docs c = [ prettyExpression c ] + prettyExpression a0@(BoolIf _ _ _) = + Pretty.group (Pretty.flatAlt long short) + where + prefixesLong = + " " + : cycle + [ Pretty.hardline <> keyword "then" <> " " + , Pretty.hardline <> keyword "else" <> " " + ] + + prefixesShort = + "" + : cycle + [ space <> keyword "then" <> space + , space <> keyword "else" <> space + ] + + longLines = zipWith (<>) prefixesLong (docsLong a0) + + long = + Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) + + short = mconcat (zipWith (<>) prefixesShort (docsShort a0)) + + docsLong (BoolIf a b c) = + docLong ++ docsLong c + where + docLong = + [ keyword "if" <> " " <> prettyExpression a + , prettyExpression b + ] + docsLong (Note _ c) = docsLong c + docsLong c = [ prettyExpression c ] + + docsShort (BoolIf a b c) = + docShort ++ docsShort c + where + docShort = + [ keyword "if" <> " " <> prettyExpression a + , prettyExpression b + ] + docsShort (Note _ c) = docsShort c + docsShort c = [ prettyExpression c ] + prettyExpression a0@(Let _ _ _ _) = + enclose' "" " " (space <> keyword "in" <> space) (Pretty.hardline <> keyword "in" <> " ") + (fmap duplicate (docs a0)) + where + docs (Let a Nothing c d) = + Pretty.group (Pretty.flatAlt long short) : docs d + where + long = keyword "let" <> space + <> Pretty.align + ( prettyLabel a + <> space <> equals + <> Pretty.hardline + <> " " + <> prettyExpression c + ) + + short = keyword "let" <> space + <> prettyLabel a + <> (space <> equals <> space) + <> prettyExpression c + docs (Let a (Just b) c d) = + Pretty.group (Pretty.flatAlt long short) : docs d + where + long = keyword "let" <> space + <> Pretty.align + ( prettyLabel a + <> Pretty.hardline + <> colon <> space + <> prettyExpression b + <> Pretty.hardline + <> equals <> space + <> prettyExpression c + ) + + short = keyword "let" <> space + <> prettyLabel a + <> space <> colon <> space + <> prettyExpression b + <> space <> equals <> space + <> prettyExpression c + docs (Note _ d) = + docs d + docs d = + [ prettyExpression d ] + prettyExpression a0@(Pi _ _ _) = + arrows characterSet (fmap duplicate (docs a0)) + where + docs (Pi "_" b c) = prettyOperatorExpression b : docs c + docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c + where + long = forall characterSet <> space + <> Pretty.align + ( lparen <> space + <> prettyLabel a + <> Pretty.hardline + <> colon <> space + <> prettyExpression b + <> Pretty.hardline + <> rparen + ) + + short = forall characterSet <> lparen + <> prettyLabel a + <> space <> colon <> space + <> prettyExpression b + <> rparen + docs (Note _ c) = docs c + docs c = [ prettyExpression c ] + prettyExpression (Note _ a) = + prettyExpression a + prettyExpression a0 = + prettyAnnotatedExpression a0 + + prettyAnnotatedExpression :: Pretty a => Expr s a -> Doc Ann + prettyAnnotatedExpression (Merge a b (Just c)) = + Pretty.group (Pretty.flatAlt long short) + where + long = + Pretty.align + ( keyword "merge" + <> Pretty.hardline + <> prettyImportExpression a + <> Pretty.hardline + <> prettyImportExpression b + <> Pretty.hardline + <> colon <> space + <> prettyApplicationExpression c + ) + + short = keyword "merge" <> space + <> prettyImportExpression a + <> " " + <> 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 + <> prettyImportExpression a + <> Pretty.hardline + <> prettyImportExpression b + ) + + short = keyword "merge" <> space + <> prettyImportExpression a + <> " " + <> prettyImportExpression b + prettyAnnotatedExpression a0@(Annot _ _) = + enclose' + "" + " " + (" " <> colon <> " ") + (colon <> space) + (fmap duplicate (docs a0)) + where + docs (Annot a b) = prettyOperatorExpression a : docs b + docs (Note _ b) = docs b + docs b = [ prettyExpression b ] + prettyAnnotatedExpression (ListLit (Just a) b) = + list (map prettyExpression (Data.Foldable.toList b)) + <> " : " + <> prettyApplicationExpression (App List a) + prettyAnnotatedExpression (OptionalLit a b) = + list (map prettyExpression (Data.Foldable.toList b)) + <> " : " + <> prettyApplicationExpression (App Optional a) + prettyAnnotatedExpression (Note _ a) = + prettyAnnotatedExpression a + prettyAnnotatedExpression a0 = + prettyOperatorExpression a0 + + prettyOperatorExpression :: Pretty a => Expr s a -> Doc Ann + prettyOperatorExpression = prettyImportAltExpression + + prettyOperator :: Text -> [Doc Ann] -> Doc Ann + prettyOperator op docs = + enclose' + "" + prefix + (" " <> operator (Pretty.pretty op) <> " ") + (operator (Pretty.pretty op) <> spacer) + (reverse (fmap duplicate docs)) + where + prefix = if Text.length op == 1 then " " else " " + + spacer = if Text.length op == 1 then " " else " " + + prettyImportAltExpression :: Pretty a => Expr s a -> Doc Ann + prettyImportAltExpression a0@(ImportAlt _ _) = + prettyOperator "?" (docs a0) + where + docs (ImportAlt a b) = prettyOrExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyOrExpression b ] + prettyImportAltExpression (Note _ a) = + prettyImportAltExpression a + prettyImportAltExpression a0 = + prettyOrExpression a0 + + prettyOrExpression :: Pretty a => Expr s a -> Doc Ann + prettyOrExpression a0@(BoolOr _ _) = + prettyOperator "||" (docs a0) + where + docs (BoolOr a b) = prettyPlusExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyPlusExpression b ] + prettyOrExpression (Note _ a) = + prettyOrExpression a + prettyOrExpression a0 = + prettyPlusExpression a0 + + prettyPlusExpression :: Pretty a => Expr s a -> Doc Ann + prettyPlusExpression a0@(NaturalPlus _ _) = + prettyOperator "+" (docs a0) + where + docs (NaturalPlus a b) = prettyTextAppendExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyTextAppendExpression b ] + prettyPlusExpression (Note _ a) = + prettyPlusExpression a + prettyPlusExpression a0 = + prettyTextAppendExpression a0 + + prettyTextAppendExpression :: Pretty a => Expr s a -> Doc Ann + prettyTextAppendExpression a0@(TextAppend _ _) = + prettyOperator "++" (docs a0) + where + docs (TextAppend a b) = prettyListAppendExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyListAppendExpression b ] + prettyTextAppendExpression (Note _ a) = + prettyTextAppendExpression a + prettyTextAppendExpression a0 = + prettyListAppendExpression a0 + + prettyListAppendExpression :: Pretty a => Expr s a -> Doc Ann + prettyListAppendExpression a0@(ListAppend _ _) = + prettyOperator "#" (docs a0) + where + docs (ListAppend a b) = prettyAndExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyAndExpression b ] + prettyListAppendExpression (Note _ a) = + prettyListAppendExpression a + prettyListAppendExpression a0 = + prettyAndExpression a0 + + prettyAndExpression :: Pretty a => Expr s a -> Doc Ann + prettyAndExpression a0@(BoolAnd _ _) = + prettyOperator "&&" (docs a0) + where + docs (BoolAnd a b) = prettyCombineExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyCombineExpression b ] + prettyAndExpression (Note _ a) = + prettyAndExpression a + prettyAndExpression a0 = + prettyCombineExpression a0 + + prettyCombineExpression :: Pretty a => Expr s a -> Doc Ann + prettyCombineExpression a0@(Combine _ _) = + prettyOperator "∧" (docs a0) + where + docs (Combine a b) = prettyPreferExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyPreferExpression b ] + prettyCombineExpression (Note _ a) = + prettyCombineExpression a + prettyCombineExpression a0 = + prettyPreferExpression a0 + + prettyPreferExpression :: Pretty a => Expr s a -> Doc Ann + prettyPreferExpression a0@(Prefer _ _) = + prettyOperator "⫽" (docs a0) + where + docs (Prefer a b) = prettyCombineTypesExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyCombineTypesExpression b ] + prettyPreferExpression (Note _ a) = + prettyPreferExpression a + prettyPreferExpression a0 = + prettyCombineTypesExpression a0 + + prettyCombineTypesExpression :: Pretty a => Expr s a -> Doc Ann + prettyCombineTypesExpression a0@(CombineTypes _ _) = + prettyOperator "⩓" (docs a0) + where + docs (CombineTypes a b) = prettyTimesExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyTimesExpression b ] + prettyCombineTypesExpression (Note _ a) = + prettyCombineTypesExpression a + prettyCombineTypesExpression a0 = + prettyTimesExpression a0 + + prettyTimesExpression :: Pretty a => Expr s a -> Doc Ann + prettyTimesExpression a0@(NaturalTimes _ _) = + prettyOperator "*" (docs a0) + where + docs (NaturalTimes a b) = prettyEqualExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyEqualExpression b ] + prettyTimesExpression (Note _ a) = + prettyTimesExpression a + prettyTimesExpression a0 = + prettyEqualExpression a0 + + prettyEqualExpression :: Pretty a => Expr s a -> Doc Ann + prettyEqualExpression a0@(BoolEQ _ _) = + prettyOperator "==" (docs a0) + where + docs (BoolEQ a b) = prettyNotEqualExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyNotEqualExpression b ] + prettyEqualExpression (Note _ a) = + prettyEqualExpression a + prettyEqualExpression a0 = + prettyNotEqualExpression a0 + + prettyNotEqualExpression :: Pretty a => Expr s a -> Doc Ann + prettyNotEqualExpression a0@(BoolNE _ _) = + prettyOperator "!=" (docs a0) + where + docs (BoolNE a b) = prettyApplicationExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyApplicationExpression b ] + prettyNotEqualExpression (Note _ a) = + prettyNotEqualExpression a + prettyNotEqualExpression a0 = + prettyApplicationExpression a0 + + prettyApplicationExpression :: Pretty a => Expr s a -> Doc Ann + prettyApplicationExpression a0 = case a0 of + App _ _ -> result + Constructors _ -> result + Some _ -> result + Note _ b -> prettyApplicationExpression b + _ -> prettyImportExpression a0 + where + result = enclose' "" "" " " "" (fmap duplicate (reverse (docs a0))) + + docs (App a b) = prettyImportExpression b : docs a + docs (Constructors b) = [ prettyImportExpression b , keyword "constructors" ] + docs (Some a) = [ prettyImportExpression a , builtin "Some" ] + docs (Note _ b) = docs b + docs b = [ prettyImportExpression b ] + + prettyImportExpression :: Pretty a => Expr s a -> Doc Ann + prettyImportExpression (Embed a) = + Pretty.pretty a + prettyImportExpression (Note _ a) = + prettyImportExpression a + prettyImportExpression a0 = + prettySelectorExpression a0 + + prettySelectorExpression :: Pretty a => Expr s a -> Doc Ann + prettySelectorExpression (Field a b) = + prettySelectorExpression a <> dot <> prettyLabel b + prettySelectorExpression (Project a b) = + prettySelectorExpression a <> dot <> prettyLabels b + prettySelectorExpression (Note _ b) = + prettySelectorExpression b + prettySelectorExpression a0 = + prettyPrimitiveExpression a0 + + prettyPrimitiveExpression :: Pretty a => Expr s a -> Doc Ann + prettyPrimitiveExpression (Var a) = + prettyVar a + prettyPrimitiveExpression (Const k) = + prettyConst k + prettyPrimitiveExpression Bool = + builtin "Bool" + prettyPrimitiveExpression Natural = + builtin "Natural" + prettyPrimitiveExpression NaturalFold = + builtin "Natural/fold" + prettyPrimitiveExpression NaturalBuild = + builtin "Natural/build" + prettyPrimitiveExpression NaturalIsZero = + builtin "Natural/isZero" + prettyPrimitiveExpression NaturalEven = + builtin "Natural/even" + prettyPrimitiveExpression NaturalOdd = + builtin "Natural/odd" + prettyPrimitiveExpression NaturalToInteger = + builtin "Natural/toInteger" + prettyPrimitiveExpression NaturalShow = + builtin "Natural/show" + prettyPrimitiveExpression Integer = + builtin "Integer" + prettyPrimitiveExpression IntegerShow = + builtin "Integer/show" + prettyPrimitiveExpression IntegerToDouble = + builtin "Integer/toDouble" + prettyPrimitiveExpression Double = + builtin "Double" + prettyPrimitiveExpression DoubleShow = + builtin "Double/show" + prettyPrimitiveExpression Text = + builtin "Text" + prettyPrimitiveExpression List = + builtin "List" + prettyPrimitiveExpression ListBuild = + builtin "List/build" + prettyPrimitiveExpression ListFold = + builtin "List/fold" + prettyPrimitiveExpression ListLength = + builtin "List/length" + prettyPrimitiveExpression ListHead = + builtin "List/head" + prettyPrimitiveExpression ListLast = + builtin "List/last" + prettyPrimitiveExpression ListIndexed = + builtin "List/indexed" + prettyPrimitiveExpression ListReverse = + builtin "List/reverse" + prettyPrimitiveExpression Optional = + builtin "Optional" + prettyPrimitiveExpression None = + builtin "None" + prettyPrimitiveExpression OptionalFold = + builtin "Optional/fold" + prettyPrimitiveExpression OptionalBuild = + builtin "Optional/build" + prettyPrimitiveExpression (BoolLit True) = + builtin "True" + prettyPrimitiveExpression (BoolLit False) = + builtin "False" + prettyPrimitiveExpression (IntegerLit a) + | 0 <= a = literal "+" <> prettyNumber a + | otherwise = prettyNumber a + prettyPrimitiveExpression (NaturalLit a) = + prettyNatural a + prettyPrimitiveExpression (DoubleLit a) = + prettyScientific a + prettyPrimitiveExpression (TextLit a) = + prettyChunks a + prettyPrimitiveExpression (Record a) = + prettyRecord a + prettyPrimitiveExpression (RecordLit a) = + prettyRecordLit a + prettyPrimitiveExpression (Union a) = + prettyUnion a + prettyPrimitiveExpression (UnionLit a b c) = + prettyUnionLit a b c + prettyPrimitiveExpression (ListLit Nothing b) = + list (map prettyExpression (Data.Foldable.toList b)) + prettyPrimitiveExpression (Note _ b) = + prettyPrimitiveExpression b + prettyPrimitiveExpression a = + Pretty.group (Pretty.flatAlt long short) + where + long = + Pretty.align + (lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen) + + short = lparen <> prettyExpression a <> rparen + + prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr s a) -> (Doc Ann, Doc Ann) + prettyKeyValue separator (key, value) = + ( prettyLabel key <> " " <> separator <> " " <> prettyExpression value + , prettyLabel key + <> " " + <> separator + <> long + ) + where + long = Pretty.hardline <> " " <> prettyExpression value + + prettyRecord :: Pretty a => Map Text (Expr s a) -> Doc Ann + prettyRecord = + braces . map (prettyKeyValue colon) . Dhall.Map.toList + + prettyRecordLit :: Pretty a => Map Text (Expr s a) -> Doc Ann + prettyRecordLit a + | Data.Foldable.null a = + lbrace <> equals <> rbrace + | otherwise + = braces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + + prettyUnion :: Pretty a => Map Text (Expr s a) -> Doc Ann + prettyUnion = + angles . map (prettyKeyValue colon) . Dhall.Map.toList + + prettyUnionLit + :: Pretty a => Text -> Expr s a -> Map Text (Expr s a) -> Doc Ann + prettyUnionLit a b c = + angles (front : map adapt (Dhall.Map.toList c)) + where + front = prettyKeyValue equals (a, b) + + adapt = prettyKeyValue colon + + prettyChunks :: Pretty a => Chunks s a -> Doc Ann + prettyChunks (Chunks a b) = + if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b + then Pretty.flatAlt long short + else short + where + long = + Pretty.align + ( literal ("''" <> Pretty.hardline) + <> Pretty.align + (foldMap prettyMultilineChunk a <> prettyMultilineBuilder b) + <> literal "''" + ) + + short = + literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") + + hasNewLine = Text.any (== '\n') + + prettyMultilineChunk (c, d) = + prettyMultilineBuilder c + <> dollar + <> lbrace + <> prettyExpression d + <> rbrace + + prettyMultilineBuilder builder = literal (mconcat docs) + where + lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder) + + docs = + Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines) + + prettyChunk (c, d) = + prettyText c + <> syntax "${" + <> prettyExpression d + <> syntax rbrace + + prettyText t = literal (Pretty.pretty (escapeText t)) -- | Pretty-print a value pretty :: Pretty a => a -> Text diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -14,8 +14,9 @@ import Control.Monad.State.Class ( MonadState, get, modify ) import Control.Monad.State.Strict ( evalStateT ) import Data.List ( foldl' ) -import Dhall.Binary (ProtocolVersion(..)) -import Dhall.Import (protocolVersion) +import Dhall.Binary (StandardVersion(..)) +import Dhall.Import (standardVersion) +import Dhall.Pretty (CharacterSet(..)) import Lens.Family (set) import qualified Control.Monad.Trans.State.Strict as State @@ -37,26 +38,29 @@ import qualified System.IO -- | Implementation of the @dhall repl@ subcommand -repl :: Bool -> ProtocolVersion -> IO () -repl explain _protocolVersion = if explain then Dhall.detailed io else io +repl :: CharacterSet -> Bool -> StandardVersion -> IO () +repl characterSet explain _standardVersion = + if explain then Dhall.detailed io else io where io = evalStateT ( Repline.evalRepl - "⊢ " + ( pure "⊢ " ) ( dontCrash . eval ) options - ( Repline.Word completer ) + (Just ':') + ( Repline.Word completer ) greeter ) - (emptyEnv { explain, _protocolVersion }) + (emptyEnv { characterSet, explain, _standardVersion }) data Env = Env { envBindings :: Dhall.Context.Context Binding , envIt :: Maybe Binding , explain :: Bool - , _protocolVersion :: ProtocolVersion + , characterSet :: CharacterSet + , _standardVersion :: StandardVersion } @@ -66,7 +70,8 @@ { envBindings = Dhall.Context.empty , envIt = Nothing , explain = False - , _protocolVersion = Dhall.Binary.defaultProtocolVersion + , _standardVersion = Dhall.Binary.defaultStandardVersion + , characterSet = Unicode } @@ -102,7 +107,7 @@ return a let status = - set protocolVersion (_protocolVersion env) (Dhall.emptyStatus ".") + set standardVersion (_standardVersion env) (Dhall.emptyStatus ".") liftIO ( State.evalStateT (Dhall.loadWith parsed) status ) @@ -220,8 +225,11 @@ normalizedExpression <- normalize loadedExpression - let handler handle = output handle normalizedExpression + env <- get + let handler handle = + State.evalStateT (output handle normalizedExpression) env + liftIO (System.IO.withFile file System.IO.WriteMode handler) saveBinding _ = fail ":save should be of the form `:save x = y`" @@ -254,12 +262,17 @@ output - :: (Pretty.Pretty a, MonadIO m) + :: (Pretty.Pretty a, MonadState Env m, MonadIO m) => System.IO.Handle -> Dhall.Expr s a -> m () output handle expr = do + Env { characterSet } <- get + liftIO (System.IO.hPutStrLn handle "") -- Visual spacing - let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts (Dhall.Pretty.prettyExpr expr) + let stream = + Pretty.layoutSmart Dhall.Pretty.layoutOpts + (Dhall.Pretty.prettyCharacterSet characterSet expr) + supportsANSI <- liftIO (System.Console.ANSI.hSupportsANSI handle) let ansiStream = if supportsANSI diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -5,21 +5,22 @@ Dhall expressions from Haskell without having a runtime dependency on the location of Dhall files. - For example, given a file “Some/Type.dhall” containing + For example, given a file @".\/Some\/Type.dhall"@ containing - < This : Natural | Other : ../Other/Type.dhall > + > < This : Natural | Other : ../Other/Type.dhall > - rather than duplicating the AST manually in a Haskell `Type`, you can do + ... rather than duplicating the AST manually in a Haskell `Type`, you can + do: - Dhall.Type - (\case - UnionLit "This" _ _ -> ... - UnionLit "Other" _ _ -> ...) - $(staticDhallExpression "../../Some/Type.dhall") + > Dhall.Type + > (\case + > UnionLit "This" _ _ -> ... + > UnionLit "Other" _ _ -> ...) + > $(staticDhallExpression "./Some/Type.dhall") - This would create the Dhall Expr AST from the `Type.dhall` file at compile - time with all imports resolved, making it easy to keep your Dhall configs - and Haskell interpreters in sync. + This would create the Dhall Expr AST from the @".\/Some\/Type.dhall"@ file + at compile time with all imports resolved, making it easy to keep your Dhall + configs and Haskell interpreters in sync. -} module Dhall.TH ( -- * Template Haskell diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -511,15 +511,10 @@ -- -- >>> input auto "[]" :: IO (Vector Natural) -- *** Exception: --- ...Error...: Invalid input --- ... --- (input):1:3: --- | --- 1 | [] --- | ^ --- unexpected end of input --- expecting ':' or whitespace +-- ...Error...: An empty list requires a type annotation -- ... +-- [] +-- (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: @@ -531,7 +526,7 @@ -- - Natural -- + Bool -- ... --- True +-- True -- ... -- (input):1:5 -- ... @@ -543,37 +538,27 @@ -- $optional0 -- --- @Optional@ values are exactly like lists except they can only hold 0 or 1 --- elements. They cannot hold 2 or more elements: +-- @Optional@ values are either of the form @Some aValue@ or @None aType@. -- -- For example, these are valid @Optional@ values: -- --- > [1] : Optional Natural +-- > Some 1 -- > --- > [] : Optional Natural --- --- ... but this is /not/ valid: +-- > None Natural -- --- > [1, 2] : Optional Natural -- NOT valid +-- ... which both have type @Optional Natural@ -- -- An @Optional@ corresponds to Haskell's `Maybe` type for decoding purposes: -- --- >>> input auto "[1] : Optional Natural" :: IO (Maybe Natural) +-- >>> input auto "Some 1" :: IO (Maybe Natural) -- Just 1 --- >>> input auto "[] : Optional Natural" :: IO (Maybe Natural) +-- >>> input auto "None Natural" :: IO (Maybe Natural) -- Nothing -- --- You cannot omit the type annotation for @Optional@ values. The type --- annotation is mandatory --- --- __Exercise:__ What is the shortest possible @./config@ file that you can decode --- like this: +-- __Exercise:__ Author a @./config@ file that you can decode like this: -- -- > >>> input auto "./config" :: IO (Maybe (Maybe (Maybe Natural))) -- > ??? --- --- __Exercise:__ Try to decode an @Optional@ value with more than one element and --- see what happens -- $records -- @@ -1402,7 +1387,7 @@ -- > -- > Optional Natural -- > --- > [] : Optional Natural +-- > None Natural -- -- __Exercise__: The Dhall Prelude provides a @replicate@ function which you can -- find here: @@ -2423,11 +2408,11 @@ -- > -- > Optional Natural -- > --- > [1] : Optional Natural +-- > Some 1 -- -- Type: -- --- > ───────────────────────────────────── +-- > ─────────────────────────────────────────────── -- > Γ ⊢ List/head ∀(a : Type) → List a → Optional a -- -- Rules: @@ -2440,7 +2425,7 @@ -- > 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) = [x] : Optional a +-- > 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) @@ -2454,11 +2439,11 @@ -- > -- > Optional Natural -- > --- > [1] : Optional Natural +-- > Some 1 -- -- Type: -- --- > ───────────────────────────────────── +-- > ───────────────────────────────────────────────── -- > Γ ⊢ List/last : ∀(a : Type) → List a → Optional a -- -- Rules: @@ -2471,7 +2456,7 @@ -- > 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) = [x] : Optional a +-- > 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) @@ -2535,18 +2520,19 @@ -- $optional1 -- --- Dhall @Optional@ literals are 0 or 1 values inside of brackets: +-- Dhall @Optional@ literals are either @Some@ followed by a value: -- --- > Γ ⊢ t : Type Γ ⊢ x : t +-- > Γ ⊢ x : t Γ ⊢ t : Type -- > ──────────────────────── --- > Γ ⊢ ([x] : Optional t) : Optional t +-- > Γ ⊢ Some x : Optional t -- --- > Γ ⊢ t : Type --- > ──────────────────────── --- > Γ ⊢ ([] : Optional t) : Optional t +-- ... or @None@ followed by a type: -- --- Also, every @Optional@ literal must end with a mandatory type annotation +-- > ─────────────────────────────────── +-- > Γ ⊢ None : ∀(t : Type) → Optional t -- +-- Note that `None` is a valid standalone function +-- -- The built-in operations on @Optional@ values are: -- $optionalFold @@ -2554,7 +2540,7 @@ -- Example: -- -- > $ dhall --- > Optional/fold Text (["ABC"] : Optional Text) Text (λ(t : Text) → t) "" +-- > Optional/fold Text (Some "ABC") Text (λ(t : Text) → t) "" -- > -- > Text -- > @@ -2562,14 +2548,14 @@ -- -- Type: -- --- > ───────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────── --- > Γ ⊢ Optional/fold : ∀(a : Type) → Optional a → ∀(optional : Type) → ∀(just : a → optional) → ∀(nothing : optional) → optional +-- > ────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────── +-- > Γ ⊢ Optional/fold : ∀(a : Type) → Optional a → ∀(optional : Type) → ∀(some : a → optional) → ∀(none : optional) → optional -- -- Rules: -- --- > Optional/fold a ([] : Optional a) o j n = n +-- > Optional/fold a (None a) o j n = n -- > --- > Optional/fold a ([x] : Optional a) o j n = j x +-- > Optional/fold a (Some x) o j n = j x -- $prelude -- diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -24,8 +24,8 @@ import Control.Exception (Exception) import Data.Data (Data(..)) import Data.Foldable (forM_, toList) -import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL(..)) +import Data.Semigroup (Semigroup(..)) import Data.Set (Set) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) @@ -36,8 +36,6 @@ import Dhall.Pretty (Ann, layoutOpts) import qualified Data.Foldable -import qualified Data.HashMap.Strict -import qualified Data.HashMap.Strict.InsOrd import qualified Data.Sequence import qualified Data.Set import qualified Data.Text as Text @@ -46,7 +44,9 @@ import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Diff +import qualified Dhall.Map import qualified Dhall.Pretty.Internal +import qualified Dhall.Util traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f () traverseWithIndex_ k xs = @@ -54,15 +54,19 @@ axiom :: Const -> Either (TypeError s a) Const axiom Type = return Kind -axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped) +axiom Kind = return Sort +axiom Sort = Left (TypeError Dhall.Context.empty (Const Sort) Untyped) rule :: Const -> Const -> Either () Const --- This forbids dependent types. If this ever changes, then the fast --- path in the Let case of typeWithA will become unsound. -rule Type Kind = Left () rule Type Type = return Type -rule Kind Kind = return Kind rule Kind Type = return Type +rule Kind Kind = return Kind +rule Sort Type = return Type +rule Sort Kind = return Kind +rule Sort Sort = return Sort +-- This forbids dependent types. If this ever changes, then the fast +-- path in the Let case of typeWithA will become unsound. +rule _ _ = Left () {-| Type-check an expression and return the expression's type if type-checking succeeds or an error if type-checking fails @@ -117,7 +121,6 @@ Const k -> return k _ -> Left (TypeError ctx e (InvalidInputType _A)) - _ <- loop ctx _A let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x (Dhall.Core.normalize _A) ctx) tB <- fmap Dhall.Core.normalize (loop ctx' _B) kB <- case tB of @@ -425,11 +428,13 @@ return (Pi "a" (Const Type) (Pi "_" (App List "a") - (App List (Record (Data.HashMap.Strict.InsOrd.fromList kts))) ) ) + (App List (Record (Dhall.Map.fromList kts))) ) ) loop _ ListReverse = do return (Pi "a" (Const Type) (Pi "_" (App List "a") (App List "a"))) loop _ Optional = do return (Pi "_" (Const Type) (Const Type)) + loop _ None = do + return (Pi "A" (Const Type) (App Optional "A")) loop ctx e@(OptionalLit t xs) = do s <- fmap Dhall.Core.normalize (loop ctx t) case s of @@ -444,6 +449,13 @@ let nf_t' = Dhall.Core.normalize t' Left (TypeError ctx e (InvalidOptionalElement nf_t x nf_t')) ) return (App Optional t) + loop ctx e@(Some a) = do + _A <- loop ctx a + s <- fmap Dhall.Core.normalize (loop ctx _A) + case s of + Const Type -> return () + _ -> Left (TypeError ctx e (InvalidSome a _A s)) + return (App Optional _A) loop _ OptionalFold = do return (Pi "a" (Const Type) @@ -459,47 +471,55 @@ (Pi "just" (Pi "_" "a" "optional") (Pi "nothing" "optional" "optional") ) loop ctx e@(Record kts ) = do - case Data.HashMap.Strict.InsOrd.toList kts of - [] -> return (Const Type) - (k0, t0):rest -> do + case Dhall.Map.uncons kts of + Nothing -> return (Const Type) + Just (k0, t0, rest) -> do s0 <- fmap Dhall.Core.normalize (loop ctx t0) c <- case s0 of Const Type -> return Type - Const Kind - | Dhall.Core.judgmentallyEqual t0 (Const Type) -> - return Kind + Const Kind -> + return Kind + Const Sort + | Dhall.Core.judgmentallyEqual t0 (Const Kind) -> + return Sort _ -> Left (TypeError ctx e (InvalidFieldType k0 t0)) - let process (k, t) = do + let process k t = do s <- fmap Dhall.Core.normalize (loop ctx t) case s of Const Type -> if c == Type then return () - else Left (TypeError ctx e (FieldAnnotationMismatch k t k0 t0 Type)) + else Left (TypeError ctx e (FieldAnnotationMismatch k t c k0 t0 Type)) Const Kind -> if c == Kind + then return () + else Left (TypeError ctx e (FieldAnnotationMismatch k t c k0 t0 Kind)) + Const Sort -> + if c == Sort then - if Dhall.Core.judgmentallyEqual t (Const Type) + if Dhall.Core.judgmentallyEqual t (Const Kind) then return () else Left (TypeError ctx e (InvalidFieldType k t)) - else Left (TypeError ctx e (FieldAnnotationMismatch k t k0 t0 Kind)) + else Left (TypeError ctx e (FieldAnnotationMismatch k t c k0 t0 Sort)) _ -> Left (TypeError ctx e (InvalidFieldType k t)) - mapM_ process rest + Dhall.Map.traverseWithKey_ process rest return (Const c) loop ctx e@(RecordLit kvs ) = do - case Data.HashMap.Strict.InsOrd.toList kvs of - [] -> return (Record Data.HashMap.Strict.InsOrd.empty) + case Dhall.Map.toList kvs of + [] -> return (Record mempty) (k0, v0):_ -> do t0 <- loop ctx v0 s0 <- fmap Dhall.Core.normalize (loop ctx t0) c <- case s0 of Const Type -> return Type - Const Kind - | Dhall.Core.judgmentallyEqual t0 (Const Type) -> - return Kind + Const Kind -> + return Kind + Const Sort + | Dhall.Core.judgmentallyEqual t0 (Const Kind) -> + return Sort _ -> Left (TypeError ctx e (InvalidField k0 v0)) let process k v = do t <- loop ctx v @@ -508,19 +528,23 @@ Const Type -> if c == Type then return () - else Left (TypeError ctx e (FieldMismatch k v k0 v0 Type)) + else Left (TypeError ctx e (FieldMismatch k v c k0 v0 Type)) Const Kind -> if c == Kind + then return () + else Left (TypeError ctx e (FieldMismatch k v c k0 v0 Kind)) + Const Sort -> + if c == Sort then - if Dhall.Core.judgmentallyEqual t (Const Type) + if Dhall.Core.judgmentallyEqual t (Const Kind) then return () - else Left (TypeError ctx e (InvalidFieldType k t)) - else Left (TypeError ctx e (FieldMismatch k v k0 v0 Kind)) + else Left (TypeError ctx e (InvalidField k t)) + else Left (TypeError ctx e (FieldMismatch k v c k0 v0 Sort)) _ -> Left (TypeError ctx e (InvalidField k t)) return t - kts <- Data.HashMap.Strict.InsOrd.traverseWithKey process kvs + kts <- Dhall.Map.traverseWithKey process kvs return (Record kts) loop ctx e@(Union kts ) = do let process k t = do @@ -529,20 +553,14 @@ Const Type -> return () Const Kind -> return () _ -> Left (TypeError ctx e (InvalidAlternativeType k t)) - -- toList from insert-ordered-containers does some work to - -- ensure that the elements do follow insertion order. In this - -- instance, insertion order doesn't matter: we only need to - -- peek at each element to make sure it is well-typed. If - -- there are multiple type errors, it does not matter which - -- gets reported first here. - Data.HashMap.Strict.foldrWithKey (\ k t prev -> prev >> process k t) (Right ()) (Data.HashMap.Strict.InsOrd.toHashMap kts) + Dhall.Map.traverseWithKey_ process kts return (Const Type) loop ctx e@(UnionLit k v kts) = do - case Data.HashMap.Strict.InsOrd.lookup k kts of + case Dhall.Map.lookup k kts of Just _ -> Left (TypeError ctx e (DuplicateAlternative k)) Nothing -> return () t <- loop ctx v - let union = Union (Data.HashMap.Strict.InsOrd.insert k (Dhall.Core.normalize t) kts) + let union = Union (Dhall.Map.insert k (Dhall.Core.normalize t) kts) _ <- loop ctx union return union loop ctx e@(Combine kvsX kvsY) = do @@ -559,7 +577,7 @@ ttKvsX <- fmap Dhall.Core.normalize (loop ctx tKvsX) constX <- case ttKvsX of Const constX -> return constX - _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsY tKvsY)) + _ -> Left (TypeError ctx e (MustCombineARecord '∧' kvsX tKvsX)) ttKvsY <- fmap Dhall.Core.normalize (loop ctx tKvsY) constY <- case ttKvsY of @@ -572,12 +590,12 @@ let combineTypes ktsL ktsR = do let ksL = - Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsL) + Data.Set.fromList (Dhall.Map.keys ktsL) let ksR = - Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsR) + Data.Set.fromList (Dhall.Map.keys ktsR) let ks = Data.Set.union ksL ksR kts <- forM (toList ks) (\k -> do - case (Data.HashMap.Strict.InsOrd.lookup k ktsL, Data.HashMap.Strict.InsOrd.lookup k ktsR) of + case (Dhall.Map.lookup k ktsL, Dhall.Map.lookup k ktsR) of (Just (Record ktsL'), Just (Record ktsR')) -> do t <- combineTypes ktsL' ktsR' return (k, t) @@ -587,7 +605,7 @@ return (k, t) _ -> do Left (TypeError ctx e (FieldCollision k)) ) - return (Record (Data.HashMap.Strict.InsOrd.fromList kts)) + return (Record (Dhall.Map.fromList kts)) combineTypes ktsX ktsY loop ctx e@(CombineTypes l r) = do @@ -618,12 +636,12 @@ let combineTypes ktsL ktsR = do let ksL = - Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsL) + Data.Set.fromList (Dhall.Map.keys ktsL) let ksR = - Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsR) + Data.Set.fromList (Dhall.Map.keys ktsR) let ks = Data.Set.union ksL ksR forM_ (toList ks) (\k -> do - case (Data.HashMap.Strict.InsOrd.lookup k ktsL, Data.HashMap.Strict.InsOrd.lookup k ktsR) of + case (Dhall.Map.lookup k ktsL, Dhall.Map.lookup k ktsR) of (Just (Record ktsL'), Just (Record ktsR')) -> do combineTypes ktsL' ktsR' (Nothing, Just _) -> do @@ -650,7 +668,7 @@ ttKvsX <- fmap Dhall.Core.normalize (loop ctx tKvsX) constX <- case ttKvsX of Const constX -> return constX - _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsY tKvsY)) + _ -> Left (TypeError ctx e (MustCombineARecord '⫽' kvsX tKvsX)) ttKvsY <- fmap Dhall.Core.normalize (loop ctx tKvsY) constY <- case ttKvsY of @@ -661,7 +679,7 @@ then return () else Left (TypeError ctx e (RecordMismatch '⫽' kvsX kvsY constX constY)) - return (Record (Data.HashMap.Strict.InsOrd.union ktsY ktsX)) + return (Record (Dhall.Map.union ktsY ktsX)) loop ctx e@(Merge kvsX kvsY (Just t)) = do _ <- loop ctx t @@ -669,13 +687,13 @@ ktsX <- case tKvsX of Record kts -> return kts _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) - let ksX = Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsX) + let ksX = Data.Set.fromList (Dhall.Map.keys ktsX) tKvsY <- fmap Dhall.Core.normalize (loop ctx kvsY) ktsY <- case tKvsY of Union kts -> return kts _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) - let ksY = Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsY) + let ksY = Data.Set.fromList (Dhall.Map.keys ktsY) let diffX = Data.Set.difference ksX ksY let diffY = Data.Set.difference ksY ksX @@ -685,7 +703,7 @@ else Left (TypeError ctx e (UnusedHandler diffX)) let process (kY, tY) = do - case Data.HashMap.Strict.InsOrd.lookup kY ktsX of + case Dhall.Map.lookup kY ktsX of Nothing -> Left (TypeError ctx e (MissingHandler diffY)) Just tX -> case tX of @@ -698,20 +716,20 @@ then return () else Left (TypeError ctx e (InvalidHandlerOutputType kY t t'')) _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) - mapM_ process (Data.HashMap.Strict.InsOrd.toList ktsY) + mapM_ process (Dhall.Map.toList ktsY) return t loop ctx e@(Merge kvsX kvsY Nothing) = do tKvsX <- fmap Dhall.Core.normalize (loop ctx kvsX) ktsX <- case tKvsX of Record kts -> return kts _ -> Left (TypeError ctx e (MustMergeARecord kvsX tKvsX)) - let ksX = Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsX) + let ksX = Data.Set.fromList (Dhall.Map.keys ktsX) tKvsY <- fmap Dhall.Core.normalize (loop ctx kvsY) ktsY <- case tKvsY of Union kts -> return kts _ -> Left (TypeError ctx e (MustMergeUnion kvsY tKvsY)) - let ksY = Data.Set.fromList (Data.HashMap.Strict.InsOrd.keys ktsY) + let ksY = Data.Set.fromList (Dhall.Map.keys ktsY) let diffX = Data.Set.difference ksX ksY let diffY = Data.Set.difference ksY ksX @@ -720,12 +738,12 @@ then return () else Left (TypeError ctx e (UnusedHandler diffX)) - (kX, t) <- case Data.HashMap.Strict.InsOrd.toList ktsX of + (kX, t) <- case Dhall.Map.toList ktsX of [] -> Left (TypeError ctx e MissingMergeType) (kX, Pi y _ t):_ -> return (kX, Dhall.Core.shift (-1) (V y 0) t) (kX, tX ):_ -> Left (TypeError ctx e (HandlerNotAFunction kX tX)) let process (kY, tY) = do - case Data.HashMap.Strict.InsOrd.lookup kY ktsX of + case Dhall.Map.lookup kY ktsX of Nothing -> Left (TypeError ctx e (MissingHandler diffY)) Just tX -> case tX of @@ -738,7 +756,7 @@ then return () else Left (TypeError ctx e (HandlerOutputTypeMismatch kX t kY t'')) _ -> Left (TypeError ctx e (HandlerNotAFunction kY tX)) - mapM_ process (Data.HashMap.Strict.InsOrd.toList ktsY) + mapM_ process (Dhall.Map.toList ktsY) return t loop ctx e@(Constructors t ) = do _ <- loop ctx t @@ -749,14 +767,14 @@ let adapt k t_ = Pi k t_ (Union kts) - return (Record (Data.HashMap.Strict.InsOrd.mapWithKey adapt kts)) + return (Record (Dhall.Map.mapWithKey adapt kts)) loop ctx e@(Field r x ) = do t <- fmap Dhall.Core.normalize (loop ctx r) case t of Record kts -> do _ <- loop ctx t - case Data.HashMap.Strict.InsOrd.lookup x kts of + case Dhall.Map.lookup x kts of Just t' -> return t' Nothing -> Left (TypeError ctx e (MissingField x t)) _ -> do @@ -769,10 +787,10 @@ _ <- loop ctx t let process k = - case Data.HashMap.Strict.InsOrd.lookup k kts of + case Dhall.Map.lookup k kts of Just t' -> return (k, t') Nothing -> Left (TypeError ctx e (MissingField k t)) - let adapt = Record . Data.HashMap.Strict.InsOrd.fromList + let adapt = Record . Dhall.Map.fromList fmap adapt (traverse process (Data.Set.toList xs)) _ -> do let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabels xs) @@ -824,13 +842,14 @@ | InvalidListType (Expr s a) | InvalidOptionalElement (Expr s a) (Expr s a) (Expr s a) | InvalidOptionalType (Expr s a) + | 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) | IfBranchMustBeTerm Bool (Expr s a) (Expr s a) (Expr s a) | InvalidField Text (Expr s a) | InvalidFieldType Text (Expr s a) - | FieldAnnotationMismatch Text (Expr s a) Text (Expr s a) Const - | FieldMismatch Text (Expr s a) Text (Expr s a) Const + | FieldAnnotationMismatch Text (Expr s a) Const Text (Expr s a) Const + | FieldMismatch Text (Expr s a) Const Text (Expr s a) Const | InvalidAlternative Text (Expr s a) | InvalidAlternativeType Text (Expr s a) | ListAppendMismatch (Expr s a) (Expr s a) @@ -889,42 +908,43 @@ _NOT = "\ESC[1mnot\ESC[0m" insert :: Pretty a => a -> Doc Ann -insert expression = "↳ " <> Pretty.align (Pretty.pretty expression) +insert expression = + "↳ " <> Pretty.align (Dhall.Util.snipDoc (Pretty.pretty expression)) prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann prettyDiff exprL exprR = Dhall.Diff.diffNormalized exprL exprR prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages -prettyTypeMessage (UnboundVariable _) = ErrorMessages {..} +prettyTypeMessage (UnboundVariable x) = ErrorMessages {..} -- We do not need to print variable name here. For the discussion see: -- https://github.com/dhall-lang/dhall-haskell/pull/116 where - short = "Unbound variable" + short = "Unbound variable: " <> Pretty.pretty x long = - "Explanation: Expressions can only reference previously introduced (i.e. \"bound\")\n\ - \variables that are still \"in scope\" \n\ + "Explanation: Expressions can only reference previously introduced (i.e. “bound”)\n\ + \variables that are still “in scope” \n\ \ \n\ - \For example, the following valid expressions introduce a \"bound\" variable named\n\ + \For example, the following valid expressions introduce a “bound” variable named \n\ \❰x❱: \n\ \ \n\ \ \n\ \ ┌─────────────────┐ \n\ - \ │ λ(x : Bool) → x │ Anonymous functions introduce \"bound\" variables \n\ + \ │ λ(x : Bool) → x │ Anonymous functions introduce “bound” variables \n\ \ └─────────────────┘ \n\ \ ⇧ \n\ \ This is the bound variable \n\ \ \n\ \ \n\ \ ┌─────────────────┐ \n\ - \ │ let x = 1 in x │ ❰let❱ expressions introduce \"bound\" variables \n\ + \ │ let x = 1 in x │ ❰let❱ expressions introduce “bound” variables \n\ \ └─────────────────┘ \n\ \ ⇧ \n\ \ This is the bound variable \n\ \ \n\ \ \n\ \However, the following expressions are not valid because they all reference a \n\ - \variable that has not been introduced yet (i.e. an \"unbound\" variable): \n\ + \variable that has not been introduced yet (i.e. an “unbound” variable): \n\ \ \n\ \ \n\ \ ┌─────────────────┐ \n\ @@ -954,7 +974,7 @@ \ \n\ \ \n\ \ ┌────────────────────────────────────────────────────┐ \n\ - \ │ λ(empty : Bool) → if emty then \"Empty\" else \"Full\" │ \n\ + \ │ λ(empty : Bool) → if emty then \"Empty\" else \"Full\" │ \n\ \ └────────────────────────────────────────────────────┘ \n\ \ ⇧ \n\ \ Typo \n\ @@ -1015,7 +1035,7 @@ short = "Invalid function input" long = - "Explanation: A function can accept an input \"term\" that has a given \"type\", like\n\ + "Explanation: A function can accept an input “term” that has a given “type”, like\n\ \this: \n\ \ \n\ \ \n\ @@ -1035,7 +1055,7 @@ \ This is the type of the input term \n\ \ \n\ \ \n\ - \... or a function can accept an input \"type\" that has a given \"kind\", like this:\n\ + \... or a function can accept an input “type” that has a given “kind”, like this:\n\ \ \n\ \ \n\ \ This is the input type that the function accepts \n\ @@ -1058,15 +1078,15 @@ \ \n\ \ \n\ \ ┌──────────────┐ \n\ - \ │ ∀(x : 1) → x │ ❰1❱ is a \"term\" and not a \"type\" nor a \"kind\" so ❰x❱\n\ - \ └──────────────┘ cannot have \"type\" ❰1❱ or \"kind\" ❰1❱ \n\ + \ │ ∀(x : 1) → x │ ❰1❱ is a “term” and not a “type” nor a “kind” so ❰x❱ \n\ + \ └──────────────┘ cannot have “type” ❰1❱ or “kind” ❰1❱ \n\ \ ⇧ \n\ \ This is not a type or kind \n\ \ \n\ \ \n\ \ ┌──────────┐ \n\ - \ │ True → x │ ❰True❱ is a \"term\" and not a \"type\" nor a \"kind\" so the \n\ - \ └──────────┘ anonymous input cannot have \"type\" ❰True❱ or \"kind\" ❰True❱\n\ + \ │ True → x │ ❰True❱ is a “term” and not a “type” nor a “kind” so the \n\ + \ └──────────┘ anonymous input cannot have “type” ❰True❱ or “kind” ❰True❱ \n\ \ ⇧ \n\ \ This is not a type or kind \n\ \ \n\ @@ -1084,7 +1104,7 @@ short = "Invalid function output" long = - "Explanation: A function can return an output \"term\" that has a given \"type\",\n\ + "Explanation: A function can return an output “term” that has a given “type”, \n\ \like this: \n\ \ \n\ \ \n\ @@ -1102,7 +1122,7 @@ \ This is the type of the output term \n\ \ \n\ \ \n\ - \... or a function can return an output \"type\" that has a given \"kind\", like \n\ + \... or a function can return an output “type” that has a given “kind”, like \n\ \this: \n\ \ \n\ \ ┌────────────────────┐ \n\ @@ -1123,15 +1143,15 @@ \ \n\ \ \n\ \ ┌─────────────────┐ \n\ - \ │ ∀(x : Bool) → x │ ❰x❱ is a \"term\" and not a \"type\" nor a \"kind\" so the\n\ - \ └─────────────────┘ output cannot have \"type\" ❰x❱ or \"kind\" ❰x❱ \n\ + \ │ ∀(x : Bool) → x │ ❰x❱ is a “term” and not a “type” nor a “kind” so the \n\ + \ └─────────────────┘ output cannot have “type” ❰x❱ or “kind” ❰x❱ \n\ \ ⇧ \n\ \ This is not a type or kind \n\ \ \n\ \ \n\ \ ┌─────────────┐ \n\ - \ │ Text → True │ ❰True❱ is a \"term\" and not a \"type\" nor a \"kind\" so the\n\ - \ └─────────────┘ output cannot have \"type\" ❰True❱ or \"kind\" ❰True❱ \n\ + \ │ Text → True │ ❰True❱ is a “term” and not a “type” nor a “kind” so the \n\ + \ └─────────────┘ output cannot have “type” ❰True❱ or “kind” ❰True❱ \n\ \ ⇧ \n\ \ This is not a type or kind \n\ \ \n\ @@ -1529,38 +1549,39 @@ prettyTypeMessage Untyped = ErrorMessages {..} where - short = "❰Kind❱ has no type or kind" + short = "❰Sort❱ has no type, kind, or sort" long = - "Explanation: There are four levels of expressions that form a hierarchy: \n\ + "Explanation: There are five levels of expressions that form a hierarchy: \n\ \ \n\ \● terms \n\ \● types \n\ \● kinds \n\ \● sorts \n\ + \● orders \n\ \ \n\ \The following example illustrates this hierarchy: \n\ \ \n\ - \ ┌────────────────────────────┐ \n\ - \ │ \"ABC\" : Text : Type : Kind │ \n\ - \ └────────────────────────────┘ \n\ - \ ⇧ ⇧ ⇧ ⇧ \n\ - \ term type kind sort \n\ + \ ┌───────────────────────────────────┐ \n\ + \ │ \"ABC\" : Text : Type : Kind : Sort │ \n\ + \ └───────────────────────────────────┘ \n\ + \ ⇧ ⇧ ⇧ ⇧ ⇧ \n\ + \ term type kind sort order \n\ \ \n\ - \There is nothing above ❰Kind❱ in this hierarchy, so if you try to type check any\n\ - \expression containing ❰Kind❱ anywhere in the expression then type checking fails\n\ + \There is nothing above ❰Sort❱ in this hierarchy, so if you try to type check any\n\ + \expression containing ❰Sort❱ anywhere in the expression then type checking fails\n\ \ \n\ \Some common reasons why you might get this error: \n\ \ \n\ - \● You supplied a kind where a type was expected \n\ + \● You supplied a sort where a kind was expected \n\ \ \n\ \ For example, the following expression will fail to type check: \n\ \ \n\ - \ ┌────────────────┐ \n\ - \ │ [] : List Type │ \n\ - \ └────────────────┘ \n\ - \ ⇧ \n\ - \ ❰Type❱ is a kind, not a type \n" + \ ┌──────────────────┐ \n\ + \ │ f : Type -> Kind │ \n\ + \ └──────────────────┘ \n\ + \ ⇧ \n\ + \ ❰Kind❱ is a sort, not a kind \n" prettyTypeMessage (InvalidPredicate expr0 expr1) = ErrorMessages {..} where @@ -1644,10 +1665,10 @@ \ Expression for ❰else❱ branch \n\ \ \n\ \ \n\ - \These expressions must be a \"term\", where a \"term\" is defined as an expression\n\ + \These expressions must be a “term”, where a “term” is defined as an expression \n\ \that has a type thas has kind ❰Type❱ \n\ \ \n\ - \For example, the following expressions are all valid \"terms\": \n\ + \For example, the following expressions are all valid “terms”: \n\ \ \n\ \ \n\ \ ┌────────────────────┐ \n\ @@ -1945,8 +1966,8 @@ short = "Invalid type for ❰Optional❱ element" long = - "Explanation: Every optional element ends with a type annotation for the element \n\ - \that might be present, like this: \n\ + "Explanation: The legacy ❰List❱-like syntax for ❰Optional❱ literals ends with a \n\ + \type annotation for the element that might be present, like this: \n\ \ \n\ \ \n\ \ ┌────────────────────────┐ \n\ @@ -2033,13 +2054,55 @@ txt1 = insert expr1 txt2 = insert expr2 +prettyTypeMessage (InvalidSome expr0 expr1 expr2) = ErrorMessages {..} + where + short = "❰Some❱ argument has the wrong type" + + long = + "Explanation: The ❰Some❱ constructor expects an argument that is a term, where \n\ + \the type of the type of a term must be ❰Type❱ \n\ + \ \n\ + \For example, this is a valid use of ❰Some❱: \n\ + \ \n\ + \ \n\ + \ ┌────────┐ \n\ + \ │ Some 1 │ ❰1❱ is a valid term because ❰1 : Natural : Type❱ \n\ + \ └────────┘ \n\ + \ \n\ + \ \n\ + \... but this is " <> _NOT <> " a valid ❰Optional❱ value: \n\ + \ \n\ + \ \n\ + \ ┌───────────┐ \n\ + \ │ Some Text │ ❰Text❱ is not a valid term because ❰Text : Type : Kind ❱ \n\ + \ └───────────┘ \n\ + \ \n\ + \ \n\ + \The ❰Some❱ argument you provided: \n\ + \ \n\ + \" <> txt0 <> "\n\ + \ \n\ + \... has this type: \n\ + \ \n\ + \" <> txt1 <> "\n\ + \ \n\ + \... but the type of that type is: \n\ + \ \n\ + \" <> txt2 <> "\n\ + \ \n\ + \... which is not ❰Type❱ \n" + where + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 + prettyTypeMessage (InvalidFieldType k expr0) = ErrorMessages {..} where short = "Invalid field type" long = - "Explanation: Every record type annotates each field with a ❰Type❱ or a ❰Kind❱, \n\ - \like this: \n\ + "Explanation: Every record type annotates each field with a ❰Type❱, a ❰Kind❱, or \n\ + \a ❰Sort❱ like this: \n\ \ \n\ \ \n\ \ ┌──────────────────────────────────────────────┐ \n\ @@ -2059,8 +2122,8 @@ \ │ { foo : Natural, bar : 1 } │ Invalid record type \n\ \ └────────────────────────────┘ \n\ \ ⇧ \n\ - \ ❰1❱ is a ❰Natural❱ number and not a ❰Type❱ or \n\ - \ ❰Kind❱ \n\ + \ ❰1❱ is a ❰Natural❱ number and not a ❰Type❱, \n\ + \ ❰Kind❱, or ❰Sort❱ \n\ \ \n\ \ \n\ \You provided a record type with a field named: \n\ @@ -2071,12 +2134,12 @@ \ \n\ \" <> txt1 <> "\n\ \ \n\ - \... which is neither a ❰Type❱ nor a ❰Kind❱ \n" + \... which is neither a ❰Type❱, a ❰Kind❱, nor a ❰Sort❱ \n" where txt0 = insert k txt1 = insert expr0 -prettyTypeMessage (FieldAnnotationMismatch k0 expr0 k1 expr1 c) = ErrorMessages {..} +prettyTypeMessage (FieldAnnotationMismatch k0 expr0 c0 k1 expr1 c1) = ErrorMessages {..} where short = "Field annotation mismatch" @@ -2115,7 +2178,7 @@ \ \n\ \" <> txt1 <> "\n\ \ \n\ - \... which is a " <> here <> " whereas another field named: \n\ + \... which is a " <> level c1 <> " whereas another field named: \n\ \ \n\ \" <> txt2 <> "\n\ \ \n\ @@ -2123,22 +2186,18 @@ \ \n\ \" <> txt3 <> "\n\ \ \n\ - \... is a " <> there <> ", which does not match \n" + \... is a " <> level c0 <> ", which does not match \n" where txt0 = insert k0 txt1 = insert expr0 txt2 = insert k1 txt3 = insert expr1 - here = case c of - Type -> "❰Type❱" - Kind -> "❰Kind❱" - - there = case c of - Type -> "❰Kind❱" - Kind -> "❰Type❱" + level Type = "❰Type❱" + level Kind = "❰Kind❱" + level Sort = "❰Sort❱" -prettyTypeMessage (FieldMismatch k0 expr0 k1 expr1 c) = ErrorMessages {..} +prettyTypeMessage (FieldMismatch k0 expr0 c0 k1 expr1 c1) = ErrorMessages {..} where short = "Field mismatch" @@ -2177,7 +2236,7 @@ \ \n\ \" <> txt1 <> "\n\ \ \n\ - \... which is a " <> here <> " whereas another field named: \n\ + \... which is a " <> level c1 <> " whereas another field named: \n\ \ \n\ \" <> txt2 <> "\n\ \ \n\ @@ -2185,20 +2244,16 @@ \ \n\ \" <> txt3 <> "\n\ \ \n\ - \... is a " <> there <> ", which does not match \n" + \... is a " <> level c0 <> ", which does not match \n" where txt0 = insert k0 txt1 = insert expr0 txt2 = insert k1 txt3 = insert expr1 - here = case c of - Type -> "term" - Kind -> "type" - - there = case c of - Type -> "type" - Kind -> "term" + level Type = "term" + level Kind = "type" + level Sort = "kind" prettyTypeMessage (InvalidField k expr0) = ErrorMessages {..} where @@ -2535,6 +2590,7 @@ toClass Type = "terms" toClass Kind = "types" + toClass Sort = "kinds" class0 = toClass const0 class1 = toClass const1 @@ -2691,7 +2747,7 @@ \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = 2 } │ \n\ \ └────────────────────────────────────────┘ \n\ \ ⇧ \n\ - \ Invalid attempt to update ❰foo❱'s value to ❰2❱\n\ + \ Invalid attempt to update ❰foo❱'s value to ❰2❱\n\ \ \n\ \ Field updates are intentionally not allowed as the Dhall language discourages \n\ \ patch-oriented programming \n\ @@ -2724,7 +2780,7 @@ \ \n\ \... but the first argument to ❰merge❱ must be a record and not some other type. \n\ \ \n\ - \For example, the following expression is " <> _NOT <> " valid: \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ \ \n\ \ \n\ \ ┌─────────────────────────────────────────┐ \n\ @@ -2992,8 +3048,8 @@ \ └─────────────────────────────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ - \... as long as the output type of each handler function matches the declared type\n\ - \of the result: \n\ + \... as long as the output type of each handler function matches the declared \n\ + \type of the result: \n\ \ \n\ \ \n\ \ ┌───────────────────────────────────────────────────────────┐ \n\ @@ -3280,7 +3336,8 @@ \ \n\ \" <> txt0 <> "\n\ \ \n\ - \... but the field is missing because the record only defines the following fields:\n\ + \... but the field is missing because the record only defines the following \n\ + \fields: \n\ \ \n\ \" <> txt1 <> "\n" where @@ -3310,17 +3367,17 @@ \ \n\ \ \n\ \ ┌──────────────────┐ \n\ - \ │ \"ABC${\"DEF\"}GHI\" │ \n\ + \ │ \"ABC${\"DEF\"}GHI\" │ \n\ \ └──────────────────┘ \n\ \ \n\ \ \n\ \ ┌────────────────────────────┐ \n\ - \ │ λ(x : Text) → \"ABC${x}GHI\" │ \n\ + \ │ λ(x : Text) → \"ABC${x}GHI\" │ \n\ \ └────────────────────────────┘ \n\ \ \n\ \ \n\ \ ┌───────────────────────────────────────────────┐ \n\ - \ │ λ(age : Natural) → \"Age: ${Natural/show age}\" │ \n\ + \ │ λ(age : Natural) → \"Age: ${Natural/show age}\" │ \n\ \ └───────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ @@ -3331,7 +3388,7 @@ \ \n\ \ \n\ \ ┌──────────────────────────────────┐ \n\ - \ │ λ(age : Natural) → \"Age: ${age}\" │ \n\ + \ │ λ(age : Natural) → \"Age: ${age}\" │ \n\ \ └──────────────────────────────────┘ \n\ \ ⇧ \n\ \ Invalid: ❰age❱ has type ❰Natural❱ \n\ @@ -3342,7 +3399,7 @@ \ \n\ \ \n\ \ ┌────────────────┐ \n\ - \ │ \"echo ${HOME}\" │ \n\ + \ │ \"echo ${HOME}\" │ \n\ \ └────────────────┘ \n\ \ ⇧ \n\ \ ❰HOME❱ is not in scope and this might have meant to use ❰\\${HOME}❱\n\ @@ -3372,7 +3429,7 @@ \ \n\ \ \n\ \ ┌────────────────┐ \n\ - \ │ \"ABC\" ++ \"DEF\" │ \n\ + \ │ \"ABC\" ++ \"DEF\" │ \n\ \ └────────────────┘ \n\ \ \n\ \ \n\ @@ -3447,8 +3504,8 @@ long = "Explanation: The Dhall programming language does not allow functions from terms \n\ - \to types. These function types are also known as \"dependent function types\" \n\ - \because you have a type whose value \"depends\" on the value of a term. \n\ + \to types. These function types are also known as “dependent function types” \n\ + \because you have a type whose value “depends” on the value of a term. \n\ \ \n\ \For example, this is " <> _NOT <> " a legal function type: \n\ \ \n\ @@ -3586,16 +3643,17 @@ instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where pretty (TypeError ctx expr msg) = Pretty.unAnnotate - ("\n" + ( "\n" <> ( if null (Dhall.Context.toList ctx) then "" - else prettyContext ctx <> "\n" + else prettyContext ctx <> "\n\n" ) <> shortTypeMessage msg <> "\n" <> source ) where - prettyKV (key, val) = pretty key <> " : " <> pretty val + prettyKV (key, val) = + pretty key <> " : " <> Dhall.Util.snipDoc (pretty val) prettyContext = Pretty.vsep @@ -3622,9 +3680,9 @@ pretty (DetailedTypeError (TypeError ctx expr msg)) = Pretty.unAnnotate ( "\n" - <> ( if null (Dhall.Context.toList ctx) + <> ( if null (Dhall.Context.toList ctx) then "" - else prettyContext ctx <> "\n" + else prettyContext ctx <> "\n\n" ) <> longTypeMessage msg <> "\n" <> "────────────────────────────────────────────────────────────────────────────────\n" @@ -3632,7 +3690,8 @@ <> source ) where - prettyKV (key, val) = pretty key <> " : " <> pretty val + prettyKV (key, val) = + pretty key <> " : " <> Dhall.Util.snipDoc (pretty val) prettyContext = Pretty.vsep diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Util.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared utility functions + +module Dhall.Util + ( snip + , snipDoc + ) where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc) +import Dhall.Pretty (Ann) + +import qualified Data.Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import qualified Dhall.Pretty + +-- | Utility function to cut out the interior of a large text block +snip :: Text -> Text +snip text + | length ls <= 7 = text + | otherwise = + if Data.Text.last text == '\n' then preview else Data.Text.init preview + where + ls = Data.Text.lines text + + header = take 3 ls + + footer = takeEnd 3 ls + + excerpt = filter (Data.Text.any (/= ' ')) (header <> footer) + + leadingSpaces = + Data.Text.length . Data.Text.takeWhile (== ' ') + + minSpaces = minimum (map leadingSpaces excerpt) + + maxLength = maximum (map Data.Text.length excerpt) + + separator = + Data.Text.replicate minSpaces " " + <> Data.Text.replicate (maxLength - minSpaces) "=" + + preview = + Data.Text.unlines header + <> separator <> "\n" + <> Data.Text.unlines footer + +{-| Like `snip`, but for `Doc`s + + Note that this has to be opinionated and render ANSI color codes, but that + should be fine because we don't use this in a non-interactive context +-} +snipDoc :: Doc Ann -> Doc a +snipDoc doc = Pretty.align (Pretty.pretty (snip text)) + where + stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts doc + + ansiStream = fmap Dhall.Pretty.annToAnsiStyle stream + + text = Pretty.renderStrict ansiStream + +takeEnd :: Int -> [a] -> [a] +takeEnd n l = go (drop n l) l + where + go (_:xs) (_:ys) = go xs ys + go _ r = r diff --git a/tests/Format.hs b/tests/Format.hs --- a/tests/Format.hs +++ b/tests/Format.hs @@ -4,6 +4,7 @@ import Data.Monoid (mempty, (<>)) import Data.Text (Text) +import Dhall.Pretty (CharacterSet(..)) import Test.Tasty (TestTree) import qualified Control.Exception @@ -20,45 +21,61 @@ formatTests = Test.Tasty.testGroup "format tests" [ should + Unicode "prefer multi-line strings when newlines present" "multiline" , should + Unicode "escape ${ for single-quoted strings" "escapeSingleQuotedOpenInterpolation" , should + Unicode "preserve the original order of fields" "fieldOrder" , should + Unicode "escape numeric labels correctly" "escapeNumericLabel" , should + Unicode "correctly handle scientific notation with a large exponent" "largeExponent" , should + Unicode "correctly format the empty record literal" "emptyRecord" , should + Unicode "indent then/else to the same column" "ifThenElse" , should + Unicode "handle indenting long imports correctly without trailing space per line" "importLines" , should + Unicode "handle indenting small imports correctly without trailing space inline" "importLines2" , should + Unicode "not remove parentheses when accessing a field of a record" "importAccess" , should + Unicode "handle formatting sha256 imports correctly" "sha256Printing" , should + Unicode "handle formatting of Import suffix correctly" "importSuffix" + , should + ASCII + "be able to format with ASCII characters" + "ascii" ] -should :: Text -> Text -> TestTree -should name basename = +should :: CharacterSet -> Text -> Text -> TestTree +should characterSet name basename = Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do let inputFile = Data.Text.unpack ("./tests/format/" <> basename <> "A.dhall") @@ -70,7 +87,7 @@ Left err -> Control.Exception.throwIO err Right expr -> return expr - let doc = Data.Text.Prettyprint.Doc.pretty expr + let doc = Dhall.Pretty.prettyCharacterSet characterSet expr let docStream = Data.Text.Prettyprint.Doc.layoutSmart Dhall.Pretty.layoutOpts doc let actualText = Data.Text.Prettyprint.Doc.Render.Text.renderStrict docStream diff --git a/tests/Normalization.hs b/tests/Normalization.hs --- a/tests/Normalization.hs +++ b/tests/Normalization.hs @@ -33,6 +33,7 @@ , customization , shouldNormalize "a remote-systems.conf builder" "remoteSystems" , shouldNormalize "multi-line strings correctly" "multiLine" + , shouldNormalize "the // operator and sort the fields" "sortOperator" ] tutorialExamples :: TestTree @@ -148,8 +149,10 @@ , shouldNormalize "Optional/fold" "./examples/Optional/fold/1" , shouldNormalize "Optional/head" "./examples/Optional/head/0" , shouldNormalize "Optional/head" "./examples/Optional/head/1" + , shouldNormalize "Optional/head" "./examples/Optional/head/2" , shouldNormalize "Optional/last" "./examples/Optional/last/0" , shouldNormalize "Optional/last" "./examples/Optional/last/1" + , shouldNormalize "Optional/last" "./examples/Optional/last/2" , shouldNormalize "Optional/length" "./examples/Optional/length/0" , shouldNormalize "Optional/length" "./examples/Optional/length/1" , shouldNormalize "Optional/map" "./examples/Optional/map/0" @@ -243,7 +246,9 @@ case Dhall.TypeCheck.typeOf actualResolved of Left err -> Control.Exception.throwIO err Right _ -> return () - let actualNormalized = Dhall.Core.normalize actualResolved :: Expr X X + let actualNormalized = + Dhall.Core.alphaNormalize + (Dhall.Core.normalize actualResolved :: Expr X X) expectedExpr <- case Dhall.Parser.exprFromText mempty expectedCode of Left err -> Control.Exception.throwIO err @@ -254,7 +259,8 @@ Right _ -> return () -- Use `denote` instead of `normalize` to enforce that the expected -- expression is already in normal form - let expectedNormalized = Dhall.Core.denote expectedResolved + let expectedNormalized = + Dhall.Core.alphaNormalize (Dhall.Core.denote expectedResolved) let message = "The normalized expression did not match the expected output" diff --git a/tests/Parser.hs b/tests/Parser.hs --- a/tests/Parser.hs +++ b/tests/Parser.hs @@ -34,121 +34,124 @@ , shouldParse "whitespace buffet" "./tests/parser/whitespaceBuffet.dhall" - , shouldParse - "label" - "./tests/parser/label.dhall" - , shouldParse - "quoted label" - "./tests/parser/quotedLabel.dhall" - , shouldParse - "double quoted string" - "./tests/parser/doubleQuotedString.dhall" - , shouldParse - "Unicode double quoted string" - "./tests/parser/unicodeDoubleQuotedString.dhall" - , shouldParse - "escaped double quoted string" - "./tests/parser/escapedDoubleQuotedString.dhall" - , shouldParse - "interpolated double quoted string" - "./tests/parser/interpolatedDoubleQuotedString.dhall" - , shouldParse - "single quoted string" - "./tests/parser/singleQuotedString.dhall" - , shouldParse - "escaped single quoted string" - "./tests/parser/escapedSingleQuotedString.dhall" - , shouldParse - "interpolated single quoted string" - "./tests/parser/interpolatedSingleQuotedString.dhall" - , shouldParse - "double" - "./tests/parser/double.dhall" - , shouldParse - "natural" - "./tests/parser/natural.dhall" - , shouldParse - "identifier" - "./tests/parser/identifier.dhall" - , shouldParse - "paths" - "./tests/parser/paths.dhall" - , shouldParse - "path termination" - "./tests/parser/pathTermination.dhall" - , shouldParse - "urls" - "./tests/parser/urls.dhall" - , shouldParse - "environmentVariables" - "./tests/parser/environmentVariables.dhall" - , shouldParse - "lambda" - "./tests/parser/lambda.dhall" - , shouldParse - "if then else" - "./tests/parser/ifThenElse.dhall" - , shouldParse - "let" - "./tests/parser/let.dhall" - , shouldParse - "forall" - "./tests/parser/forall.dhall" - , shouldParse - "function type" - "./tests/parser/functionType.dhall" - , shouldParse - "operators" - "./tests/parser/operators.dhall" - , shouldParse - "annotations" - "./tests/parser/annotations.dhall" - , shouldParse - "merge" - "./tests/parser/merge.dhall" - , shouldParse - "constructors" - "./tests/parser/constructors.dhall" - , shouldParse - "fields" - "./tests/parser/fields.dhall" - , shouldParse - "record" - "./tests/parser/record.dhall" - , shouldParse - "union" - "./tests/parser/union.dhall" - , shouldParse - "list" - "./tests/parser/list.dhall" - , shouldParse - "builtins" - "./tests/parser/builtins.dhall" - , shouldParse - "import alternatives" - "./tests/parser/importAlt.dhall" - , shouldParse - "large expression" - "./tests/parser/largeExpression.dhall" - , shouldParse - "names that begin with reserved identifiers" - "./tests/parser/reservedPrefix.dhall" - , shouldParse - "interpolated expressions with leading whitespace" - "./tests/parser/template.dhall" - , shouldNotParse - "records with duplicate fields" - "./tests/parser/failure/duplicateFields.dhall" - , shouldParse - "collections with type annotations containing imports" - "./tests/parser/collectionImportType.dhall" - , shouldParse - "a parenthesized custom header import" - "./tests/parser/parenthesizeUsing.dhall" - , shouldNotParse - "accessing a field of an import without parentheses" - "./tests/parser/failure/importAccess.dhall" ] + , shouldParse + "label" + "./tests/parser/label.dhall" + , shouldParse + "quoted label" + "./tests/parser/quotedLabel.dhall" + , shouldParse + "double quoted string" + "./tests/parser/doubleQuotedString.dhall" + , shouldParse + "Unicode double quoted string" + "./tests/parser/unicodeDoubleQuotedString.dhall" + , shouldParse + "escaped double quoted string" + "./tests/parser/escapedDoubleQuotedString.dhall" + , shouldParse + "interpolated double quoted string" + "./tests/parser/interpolatedDoubleQuotedString.dhall" + , shouldParse + "single quoted string" + "./tests/parser/singleQuotedString.dhall" + , shouldParse + "escaped single quoted string" + "./tests/parser/escapedSingleQuotedString.dhall" + , shouldParse + "interpolated single quoted string" + "./tests/parser/interpolatedSingleQuotedString.dhall" + , shouldParse + "double" + "./tests/parser/double.dhall" + , shouldParse + "natural" + "./tests/parser/natural.dhall" + , shouldParse + "identifier" + "./tests/parser/identifier.dhall" + , shouldParse + "paths" + "./tests/parser/paths.dhall" + , shouldParse + "path termination" + "./tests/parser/pathTermination.dhall" + , shouldParse + "urls" + "./tests/parser/urls.dhall" + , shouldParse + "environmentVariables" + "./tests/parser/environmentVariables.dhall" + , shouldParse + "lambda" + "./tests/parser/lambda.dhall" + , shouldParse + "if then else" + "./tests/parser/ifThenElse.dhall" + , shouldParse + "let" + "./tests/parser/let.dhall" + , shouldParse + "forall" + "./tests/parser/forall.dhall" + , shouldParse + "function type" + "./tests/parser/functionType.dhall" + , shouldParse + "operators" + "./tests/parser/operators.dhall" + , shouldParse + "annotations" + "./tests/parser/annotations.dhall" + , shouldParse + "merge" + "./tests/parser/merge.dhall" + , shouldParse + "constructors" + "./tests/parser/constructors.dhall" + , shouldParse + "fields" + "./tests/parser/fields.dhall" + , shouldParse + "record" + "./tests/parser/record.dhall" + , shouldParse + "union" + "./tests/parser/union.dhall" + , shouldParse + "list" + "./tests/parser/list.dhall" + , shouldParse + "builtins" + "./tests/parser/builtins.dhall" + , shouldParse + "import alternatives" + "./tests/parser/importAlt.dhall" + , shouldParse + "large expression" + "./tests/parser/largeExpression.dhall" + , shouldParse + "names that begin with reserved identifiers" + "./tests/parser/reservedPrefix.dhall" + , shouldParse + "interpolated expressions with leading whitespace" + "./tests/parser/template.dhall" + , shouldNotParse + "records with duplicate fields" + "./tests/parser/failure/duplicateFields.dhall" + , shouldParse + "collections with type annotations containing imports" + "./tests/parser/collectionImportType.dhall" + , shouldParse + "a parenthesized custom header import" + "./tests/parser/parenthesizeUsing.dhall" + , shouldNotParse + "accessing a field of an import without parentheses" + "./tests/parser/failure/importAccess.dhall" + , shouldParse + "Sort" + "./tests/parser/sort.dhall" ] shouldParse :: Text -> FilePath -> TestTree diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -8,8 +8,7 @@ import Codec.Serialise (DeserialiseFailure(..)) import Control.Monad (guard) -import Data.Hashable (Hashable) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import Dhall.Map (Map) import Dhall.Core ( Chunks(..) , Const(..) @@ -33,7 +32,7 @@ import qualified Codec.Serialise import qualified Data.Coerce -import qualified Data.HashMap.Strict.InsOrd +import qualified Dhall.Map import qualified Data.Sequence import qualified Dhall.Binary import qualified Dhall.Core @@ -111,16 +110,16 @@ , (1, fmap (\x -> x - (2 ^ (64 :: Int))) arbitrary) ] -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (InsOrdHashMap k v) where +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where arbitrary = do n <- Test.QuickCheck.choose (0, 2) kvs <- Test.QuickCheck.vectorOf n ((,) <$> arbitrary <*> arbitrary) - return (Data.HashMap.Strict.InsOrd.fromList kvs) + return (Dhall.Map.fromList kvs) shrink = - map Data.HashMap.Strict.InsOrd.fromList + map Dhall.Map.fromList . shrink - . Data.HashMap.Strict.InsOrd.toList + . Dhall.Map.toList instance (Arbitrary s, Arbitrary a) => Arbitrary (Chunks s a) where arbitrary = do @@ -130,7 +129,7 @@ shrink = genericShrink instance Arbitrary Const where - arbitrary = Test.QuickCheck.oneof [ pure Type, pure Kind ] + arbitrary = Test.QuickCheck.oneof [ pure Type, pure Kind, pure Sort ] shrink = genericShrink @@ -314,10 +313,10 @@ binaryRoundtrip expression = wrap (fmap - Dhall.Binary.decode + Dhall.Binary.decodeWithVersion (Codec.Serialise.deserialiseOrFail (Codec.Serialise.serialise - (Dhall.Binary.encode Dhall.Binary.defaultProtocolVersion expression) + (Dhall.Binary.encodeWithVersion Dhall.Binary.defaultStandardVersion expression) ) ) ) diff --git a/tests/Regression.hs b/tests/Regression.hs --- a/tests/Regression.hs +++ b/tests/Regression.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module Regression where import qualified Control.Exception -import qualified Data.HashMap.Strict.InsOrd import qualified Data.Text.Lazy.IO import qualified Data.Text.Prettyprint.Doc import qualified Data.Text.Prettyprint.Doc.Render.Text import qualified Dhall import qualified Dhall.Context import qualified Dhall.Core +import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty import qualified Dhall.TypeCheck @@ -52,24 +51,28 @@ unnamedFields :: TestTree unnamedFields = Test.Tasty.HUnit.testCase "Unnamed Fields" (do - let ty = Dhall.auto @Foo - Test.Tasty.HUnit.assertEqual "Good type" (Dhall.expected ty) (Dhall.Core.Union ( - Data.HashMap.Strict.InsOrd.fromList [ - ("Bar",Dhall.Core.Record (Data.HashMap.Strict.InsOrd.fromList [ - ("_1",Dhall.Core.Bool),("_2",Dhall.Core.Bool),("_3",Dhall.Core.Bool)])) - , ("Baz",Dhall.Core.Record (Data.HashMap.Strict.InsOrd.fromList [ - ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Integer)])) - ,("Foo",Dhall.Core.Record (Data.HashMap.Strict.InsOrd.fromList [ - ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool)]))])) + let ty = Dhall.auto :: Dhall.Type Foo + Test.Tasty.HUnit.assertEqual "Good type" (Dhall.expected ty) + (Dhall.Core.Union + (Dhall.Map.fromList + [ ("Foo",Dhall.Core.Record (Dhall.Map.fromList [ + ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool)])) + , ("Bar",Dhall.Core.Record (Dhall.Map.fromList [ + ("_1",Dhall.Core.Bool),("_2",Dhall.Core.Bool),("_3",Dhall.Core.Bool)])) + , ("Baz",Dhall.Core.Record (Dhall.Map.fromList [ + ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Integer)])) + ] + ) + ) - let inj = Dhall.inject @Foo + let inj = Dhall.inject :: Dhall.InputType Foo Test.Tasty.HUnit.assertEqual "Good Inject" (Dhall.declared inj) (Dhall.expected ty) - let tu_ty = Dhall.auto @(Integer, Bool) + let tu_ty = Dhall.auto :: Dhall.Type (Integer, Bool) Test.Tasty.HUnit.assertEqual "Auto Tuple" (Dhall.expected tu_ty) (Dhall.Core.Record ( - Data.HashMap.Strict.InsOrd.fromList [ ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool) ])) + Dhall.Map.fromList [ ("_1",Dhall.Core.Integer),("_2",Dhall.Core.Bool) ])) - let tu_in = Dhall.inject @(Integer, Bool) + let tu_in = Dhall.inject :: Dhall.InputType (Integer, Bool) Test.Tasty.HUnit.assertEqual "Inj. Tuple" (Dhall.declared tu_in) (Dhall.expected tu_ty) return () ) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -8,8 +8,12 @@ import TypeCheck (typecheckTests) import Format (formatTests) import Import (importTests) +import System.FilePath (()) import Test.Tasty +import qualified System.Directory +import qualified System.Environment + allTests :: TestTree allTests = testGroup "Dhall Tests" @@ -24,4 +28,7 @@ ] main :: IO () -main = defaultMain allTests +main = do + pwd <- System.Directory.getCurrentDirectory + System.Environment.setEnv "XDG_CACHE_HOME" (pwd ".cache") + defaultMain allTests diff --git a/tests/TypeCheck.hs b/tests/TypeCheck.hs --- a/tests/TypeCheck.hs +++ b/tests/TypeCheck.hs @@ -46,13 +46,15 @@ , should "correctly handle α-equivalent merge alternatives" "mergeEquivalence" - + , should + "allow Kind variables" + "kindParameter" , shouldNotTypeCheck "combining records of terms and types" - "combineMixedRecords" + "failure/combineMixedRecords" , shouldNotTypeCheck "preferring a record of types over a record of terms" - "preferMixedRecords" + "failure/preferMixedRecords" ] should :: Text -> Text -> TestTree diff --git a/tests/format/asciiA.dhall b/tests/format/asciiA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/asciiA.dhall @@ -0,0 +1,1 @@ +λ(a : Type) → ∀(b : a) → a diff --git a/tests/format/asciiB.dhall b/tests/format/asciiB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/asciiB.dhall @@ -0,0 +1,1 @@ +\(a : Type) -> forall (b : a) -> a diff --git a/tests/import/fieldOrderC.dhall b/tests/import/fieldOrderC.dhall --- a/tests/import/fieldOrderC.dhall +++ b/tests/import/fieldOrderC.dhall @@ -1,3 +1,5 @@ -{ example0 = ./fieldOrderA.dhall sha256:c8e5944a964f1b35da4f2a7dc16b8de0221a518997fd84b0363a955d8f4459a4 -, example1 = ./fieldOrderB.dhall sha256:c8e5944a964f1b35da4f2a7dc16b8de0221a518997fd84b0363a955d8f4459a4 +{ example0 = + ./fieldOrderA.dhall sha256:72791c3846cef2ec49baabe6a5d38ca25301ed30b45754dfa1c6b06bab8faaf6 +, example1 = + ./fieldOrderB.dhall sha256:72791c3846cef2ec49baabe6a5d38ca25301ed30b45754dfa1c6b06bab8faaf6 } diff --git a/tests/import/issue553B.dhall b/tests/import/issue553B.dhall --- a/tests/import/issue553B.dhall +++ b/tests/import/issue553B.dhall @@ -1,1 +1,1 @@ -./issue553A.dhall sha256:2324a5352105b6835db60b127c7096c5d5b81027969ccd368d163edc5d9692e0 +./issue553A.dhall sha256:ef4cce5b6c440b2409f9ba86e48fb788b7ccb757569a713492654f23209cb19b diff --git a/tests/normalization/examples/Bool/and/0A.dhall b/tests/normalization/examples/Bool/and/0A.dhall --- a/tests/normalization/examples/Bool/and/0A.dhall +++ b/tests/normalization/examples/Bool/and/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/and [ True, False, True ] +(../../../../../Prelude/package.dhall).`Bool`.and [ True, False, True ] diff --git a/tests/normalization/examples/Bool/and/1A.dhall b/tests/normalization/examples/Bool/and/1A.dhall --- a/tests/normalization/examples/Bool/and/1A.dhall +++ b/tests/normalization/examples/Bool/and/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/and ([] : List Bool) +(../../../../../Prelude/package.dhall).`Bool`.and ([] : List Bool) diff --git a/tests/normalization/examples/Bool/build/0A.dhall b/tests/normalization/examples/Bool/build/0A.dhall --- a/tests/normalization/examples/Bool/build/0A.dhall +++ b/tests/normalization/examples/Bool/build/0A.dhall @@ -1,2 +1,2 @@ -../../../../../Prelude/Bool/build +(../../../../../Prelude/package.dhall).`Bool`.build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → true) diff --git a/tests/normalization/examples/Bool/build/1A.dhall b/tests/normalization/examples/Bool/build/1A.dhall --- a/tests/normalization/examples/Bool/build/1A.dhall +++ b/tests/normalization/examples/Bool/build/1A.dhall @@ -1,2 +1,2 @@ -../../../../../Prelude/Bool/build +(../../../../../Prelude/package.dhall).`Bool`.build (λ(bool : Type) → λ(true : bool) → λ(false : bool) → false) diff --git a/tests/normalization/examples/Bool/even/0A.dhall b/tests/normalization/examples/Bool/even/0A.dhall --- a/tests/normalization/examples/Bool/even/0A.dhall +++ b/tests/normalization/examples/Bool/even/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/even [ False, True, False ] +(../../../../../Prelude/package.dhall).`Bool`.even [ False, True, False ] diff --git a/tests/normalization/examples/Bool/even/1A.dhall b/tests/normalization/examples/Bool/even/1A.dhall --- a/tests/normalization/examples/Bool/even/1A.dhall +++ b/tests/normalization/examples/Bool/even/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/even [ False, True ] +(../../../../../Prelude/package.dhall).`Bool`.even [ False, True ] diff --git a/tests/normalization/examples/Bool/even/2A.dhall b/tests/normalization/examples/Bool/even/2A.dhall --- a/tests/normalization/examples/Bool/even/2A.dhall +++ b/tests/normalization/examples/Bool/even/2A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/even [ False ] +(../../../../../Prelude/package.dhall).`Bool`.even [ False ] diff --git a/tests/normalization/examples/Bool/even/3A.dhall b/tests/normalization/examples/Bool/even/3A.dhall --- a/tests/normalization/examples/Bool/even/3A.dhall +++ b/tests/normalization/examples/Bool/even/3A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/even ([] : List Bool) +(../../../../../Prelude/package.dhall).`Bool`.even ([] : List Bool) diff --git a/tests/normalization/examples/Bool/fold/0A.dhall b/tests/normalization/examples/Bool/fold/0A.dhall --- a/tests/normalization/examples/Bool/fold/0A.dhall +++ b/tests/normalization/examples/Bool/fold/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/fold True Natural 0 1 +(../../../../../Prelude/package.dhall).`Bool`.fold True Natural 0 1 diff --git a/tests/normalization/examples/Bool/fold/1A.dhall b/tests/normalization/examples/Bool/fold/1A.dhall --- a/tests/normalization/examples/Bool/fold/1A.dhall +++ b/tests/normalization/examples/Bool/fold/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/fold False Natural 0 1 +(../../../../../Prelude/package.dhall).`Bool`.fold False Natural 0 1 diff --git a/tests/normalization/examples/Bool/not/0A.dhall b/tests/normalization/examples/Bool/not/0A.dhall --- a/tests/normalization/examples/Bool/not/0A.dhall +++ b/tests/normalization/examples/Bool/not/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/not True +(../../../../../Prelude/package.dhall).`Bool`.not True diff --git a/tests/normalization/examples/Bool/not/1A.dhall b/tests/normalization/examples/Bool/not/1A.dhall --- a/tests/normalization/examples/Bool/not/1A.dhall +++ b/tests/normalization/examples/Bool/not/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/not False +(../../../../../Prelude/package.dhall).`Bool`.not False diff --git a/tests/normalization/examples/Bool/odd/0A.dhall b/tests/normalization/examples/Bool/odd/0A.dhall --- a/tests/normalization/examples/Bool/odd/0A.dhall +++ b/tests/normalization/examples/Bool/odd/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/odd [ True, False, True ] +(../../../../../Prelude/package.dhall).`Bool`.odd [ True, False, True ] diff --git a/tests/normalization/examples/Bool/odd/1A.dhall b/tests/normalization/examples/Bool/odd/1A.dhall --- a/tests/normalization/examples/Bool/odd/1A.dhall +++ b/tests/normalization/examples/Bool/odd/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/odd [ True, False ] +(../../../../../Prelude/package.dhall).`Bool`.odd [ True, False ] diff --git a/tests/normalization/examples/Bool/odd/2A.dhall b/tests/normalization/examples/Bool/odd/2A.dhall --- a/tests/normalization/examples/Bool/odd/2A.dhall +++ b/tests/normalization/examples/Bool/odd/2A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/odd [ True ] +(../../../../../Prelude/package.dhall).`Bool`.odd [ True ] diff --git a/tests/normalization/examples/Bool/odd/3A.dhall b/tests/normalization/examples/Bool/odd/3A.dhall --- a/tests/normalization/examples/Bool/odd/3A.dhall +++ b/tests/normalization/examples/Bool/odd/3A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/odd ([] : List Bool) +(../../../../../Prelude/package.dhall).`Bool`.odd ([] : List Bool) diff --git a/tests/normalization/examples/Bool/or/0A.dhall b/tests/normalization/examples/Bool/or/0A.dhall --- a/tests/normalization/examples/Bool/or/0A.dhall +++ b/tests/normalization/examples/Bool/or/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/or [ True, False, True ] +(../../../../../Prelude/package.dhall).`Bool`.or [ True, False, True ] diff --git a/tests/normalization/examples/Bool/or/1A.dhall b/tests/normalization/examples/Bool/or/1A.dhall --- a/tests/normalization/examples/Bool/or/1A.dhall +++ b/tests/normalization/examples/Bool/or/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/or ([] : List Bool) +(../../../../../Prelude/package.dhall).`Bool`.or ([] : List Bool) diff --git a/tests/normalization/examples/Bool/show/0A.dhall b/tests/normalization/examples/Bool/show/0A.dhall --- a/tests/normalization/examples/Bool/show/0A.dhall +++ b/tests/normalization/examples/Bool/show/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/show True +(../../../../../Prelude/package.dhall).`Bool`.show True diff --git a/tests/normalization/examples/Bool/show/1A.dhall b/tests/normalization/examples/Bool/show/1A.dhall --- a/tests/normalization/examples/Bool/show/1A.dhall +++ b/tests/normalization/examples/Bool/show/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Bool/show False +(../../../../../Prelude/package.dhall).`Bool`.show False diff --git a/tests/normalization/examples/Double/show/0A.dhall b/tests/normalization/examples/Double/show/0A.dhall --- a/tests/normalization/examples/Double/show/0A.dhall +++ b/tests/normalization/examples/Double/show/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Double/show -3.1 +(../../../../../Prelude/package.dhall).`Double`.show -3.1 diff --git a/tests/normalization/examples/Double/show/1A.dhall b/tests/normalization/examples/Double/show/1A.dhall --- a/tests/normalization/examples/Double/show/1A.dhall +++ b/tests/normalization/examples/Double/show/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Double/show 0.4 +(../../../../../Prelude/package.dhall).`Double`.show 0.4 diff --git a/tests/normalization/examples/Integer/show/0A.dhall b/tests/normalization/examples/Integer/show/0A.dhall --- a/tests/normalization/examples/Integer/show/0A.dhall +++ b/tests/normalization/examples/Integer/show/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Integer/show -3 +(../../../../../Prelude/package.dhall).`Integer`.show -3 diff --git a/tests/normalization/examples/Integer/show/1A.dhall b/tests/normalization/examples/Integer/show/1A.dhall --- a/tests/normalization/examples/Integer/show/1A.dhall +++ b/tests/normalization/examples/Integer/show/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Integer/show +0 +(../../../../../Prelude/package.dhall).`Integer`.show +0 diff --git a/tests/normalization/examples/Integer/toDouble/0A.dhall b/tests/normalization/examples/Integer/toDouble/0A.dhall --- a/tests/normalization/examples/Integer/toDouble/0A.dhall +++ b/tests/normalization/examples/Integer/toDouble/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Integer/toDouble -3 +(../../../../../Prelude/package.dhall).`Integer`.toDouble -3 diff --git a/tests/normalization/examples/Integer/toDouble/1A.dhall b/tests/normalization/examples/Integer/toDouble/1A.dhall --- a/tests/normalization/examples/Integer/toDouble/1A.dhall +++ b/tests/normalization/examples/Integer/toDouble/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Integer/toDouble +2 +(../../../../../Prelude/package.dhall).`Integer`.toDouble +2 diff --git a/tests/normalization/examples/List/all/0A.dhall b/tests/normalization/examples/List/all/0A.dhall --- a/tests/normalization/examples/List/all/0A.dhall +++ b/tests/normalization/examples/List/all/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/all Natural Natural/even [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.all Natural Natural/even [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/all/1A.dhall b/tests/normalization/examples/List/all/1A.dhall --- a/tests/normalization/examples/List/all/1A.dhall +++ b/tests/normalization/examples/List/all/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/all Natural Natural/even ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.all Natural Natural/even ([] : List Natural) diff --git a/tests/normalization/examples/List/any/0A.dhall b/tests/normalization/examples/List/any/0A.dhall --- a/tests/normalization/examples/List/any/0A.dhall +++ b/tests/normalization/examples/List/any/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/any Natural Natural/even [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.any Natural Natural/even [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/any/1A.dhall b/tests/normalization/examples/List/any/1A.dhall --- a/tests/normalization/examples/List/any/1A.dhall +++ b/tests/normalization/examples/List/any/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/any Natural Natural/even ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.any Natural Natural/even ([] : List Natural) diff --git a/tests/normalization/examples/List/build/0A.dhall b/tests/normalization/examples/List/build/0A.dhall --- a/tests/normalization/examples/List/build/0A.dhall +++ b/tests/normalization/examples/List/build/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/build +(../../../../../Prelude/package.dhall).`List`.build Text ( λ(list : Type) → λ(cons : Text → list → list) diff --git a/tests/normalization/examples/List/build/1A.dhall b/tests/normalization/examples/List/build/1A.dhall --- a/tests/normalization/examples/List/build/1A.dhall +++ b/tests/normalization/examples/List/build/1A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/build +(../../../../../Prelude/package.dhall).`List`.build Text ( λ(list : Type) → λ(cons : Text → list → list) diff --git a/tests/normalization/examples/List/concat/0A.dhall b/tests/normalization/examples/List/concat/0A.dhall --- a/tests/normalization/examples/List/concat/0A.dhall +++ b/tests/normalization/examples/List/concat/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/concat Natural +(../../../../../Prelude/package.dhall).`List`.concat Natural [ [ 0, 1, 2 ] , [ 3, 4 ] , [ 5, 6, 7, 8 ] diff --git a/tests/normalization/examples/List/concat/1A.dhall b/tests/normalization/examples/List/concat/1A.dhall --- a/tests/normalization/examples/List/concat/1A.dhall +++ b/tests/normalization/examples/List/concat/1A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/concat Natural +(../../../../../Prelude/package.dhall).`List`.concat Natural [ [] : List Natural , [] : List Natural , [] : List Natural diff --git a/tests/normalization/examples/List/concatMap/0A.dhall b/tests/normalization/examples/List/concatMap/0A.dhall --- a/tests/normalization/examples/List/concatMap/0A.dhall +++ b/tests/normalization/examples/List/concatMap/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/concatMap Natural Natural (λ(n : Natural) → [ n, n ]) [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.concatMap Natural Natural (λ(n : Natural) → [ n, n ]) [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/concatMap/1A.dhall b/tests/normalization/examples/List/concatMap/1A.dhall --- a/tests/normalization/examples/List/concatMap/1A.dhall +++ b/tests/normalization/examples/List/concatMap/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/concatMap Natural Natural (λ(n : Natural) → [ n, n ]) ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.concatMap Natural Natural (λ(n : Natural) → [ n, n ]) ([] : List Natural) diff --git a/tests/normalization/examples/List/filter/0A.dhall b/tests/normalization/examples/List/filter/0A.dhall --- a/tests/normalization/examples/List/filter/0A.dhall +++ b/tests/normalization/examples/List/filter/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/filter Natural Natural/even [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.filter Natural Natural/even [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/filter/1A.dhall b/tests/normalization/examples/List/filter/1A.dhall --- a/tests/normalization/examples/List/filter/1A.dhall +++ b/tests/normalization/examples/List/filter/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/filter Natural Natural/odd [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.filter Natural Natural/odd [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/fold/0A.dhall b/tests/normalization/examples/List/fold/0A.dhall --- a/tests/normalization/examples/List/fold/0A.dhall +++ b/tests/normalization/examples/List/fold/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/fold +(../../../../../Prelude/package.dhall).`List`.fold Natural [ 2, 3, 5 ] Natural diff --git a/tests/normalization/examples/List/fold/1A.dhall b/tests/normalization/examples/List/fold/1A.dhall --- a/tests/normalization/examples/List/fold/1A.dhall +++ b/tests/normalization/examples/List/fold/1A.dhall @@ -1,5 +1,5 @@ λ(nil : Natural) -→ ../../../../../Prelude/List/fold +→ (../../../../../Prelude/package.dhall).`List`.fold Natural [ 2, 3, 5 ] Natural diff --git a/tests/normalization/examples/List/fold/1B.dhall b/tests/normalization/examples/List/fold/1B.dhall --- a/tests/normalization/examples/List/fold/1B.dhall +++ b/tests/normalization/examples/List/fold/1B.dhall @@ -1,1 +1,1 @@ -λ(nil : Natural) → 2 + 3 + 5 + nil +λ(nil : Natural) → 2 + (3 + (5 + nil)) diff --git a/tests/normalization/examples/List/fold/2A.dhall b/tests/normalization/examples/List/fold/2A.dhall --- a/tests/normalization/examples/List/fold/2A.dhall +++ b/tests/normalization/examples/List/fold/2A.dhall @@ -1,4 +1,4 @@ λ(list : Type) → λ(cons : Natural → list → list) → λ(nil : list) -→ ../../../../../Prelude/List/fold Natural [ 2, 3, 5 ] list cons nil +→ (../../../../../Prelude/package.dhall).`List`.fold Natural [ 2, 3, 5 ] list cons nil diff --git a/tests/normalization/examples/List/generate/0A.dhall b/tests/normalization/examples/List/generate/0A.dhall --- a/tests/normalization/examples/List/generate/0A.dhall +++ b/tests/normalization/examples/List/generate/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/generate 5 Bool Natural/even +(../../../../../Prelude/package.dhall).`List`.generate 5 Bool Natural/even diff --git a/tests/normalization/examples/List/generate/1A.dhall b/tests/normalization/examples/List/generate/1A.dhall --- a/tests/normalization/examples/List/generate/1A.dhall +++ b/tests/normalization/examples/List/generate/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/generate 0 Bool Natural/even +(../../../../../Prelude/package.dhall).`List`.generate 0 Bool Natural/even diff --git a/tests/normalization/examples/List/head/0A.dhall b/tests/normalization/examples/List/head/0A.dhall --- a/tests/normalization/examples/List/head/0A.dhall +++ b/tests/normalization/examples/List/head/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/head Natural [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`List`.head Natural [ 0, 1, 2 ] diff --git a/tests/normalization/examples/List/head/0B.dhall b/tests/normalization/examples/List/head/0B.dhall --- a/tests/normalization/examples/List/head/0B.dhall +++ b/tests/normalization/examples/List/head/0B.dhall @@ -1,1 +1,1 @@ -[ 0 ] : Optional Natural +Some 0 diff --git a/tests/normalization/examples/List/head/1A.dhall b/tests/normalization/examples/List/head/1A.dhall --- a/tests/normalization/examples/List/head/1A.dhall +++ b/tests/normalization/examples/List/head/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/head Natural ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.head Natural ([] : List Natural) diff --git a/tests/normalization/examples/List/head/1B.dhall b/tests/normalization/examples/List/head/1B.dhall --- a/tests/normalization/examples/List/head/1B.dhall +++ b/tests/normalization/examples/List/head/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/List/indexed/0A.dhall b/tests/normalization/examples/List/indexed/0A.dhall --- a/tests/normalization/examples/List/indexed/0A.dhall +++ b/tests/normalization/examples/List/indexed/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/indexed Bool [ True, False, True ] +(../../../../../Prelude/package.dhall).`List`.indexed Bool [ True, False, True ] diff --git a/tests/normalization/examples/List/indexed/1A.dhall b/tests/normalization/examples/List/indexed/1A.dhall --- a/tests/normalization/examples/List/indexed/1A.dhall +++ b/tests/normalization/examples/List/indexed/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/indexed Bool ([] : List Bool) +(../../../../../Prelude/package.dhall).`List`.indexed Bool ([] : List Bool) diff --git a/tests/normalization/examples/List/iterate/0A.dhall b/tests/normalization/examples/List/iterate/0A.dhall --- a/tests/normalization/examples/List/iterate/0A.dhall +++ b/tests/normalization/examples/List/iterate/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/iterate 10 Natural (λ(x : Natural) → x * 2) 1 +(../../../../../Prelude/package.dhall).`List`.iterate 10 Natural (λ(x : Natural) → x * 2) 1 diff --git a/tests/normalization/examples/List/iterate/1A.dhall b/tests/normalization/examples/List/iterate/1A.dhall --- a/tests/normalization/examples/List/iterate/1A.dhall +++ b/tests/normalization/examples/List/iterate/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/iterate 0 Natural (λ(x : Natural) → x * 2) 1 +(../../../../../Prelude/package.dhall).`List`.iterate 0 Natural (λ(x : Natural) → x * 2) 1 diff --git a/tests/normalization/examples/List/last/0A.dhall b/tests/normalization/examples/List/last/0A.dhall --- a/tests/normalization/examples/List/last/0A.dhall +++ b/tests/normalization/examples/List/last/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/last Natural [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`List`.last Natural [ 0, 1, 2 ] diff --git a/tests/normalization/examples/List/last/0B.dhall b/tests/normalization/examples/List/last/0B.dhall --- a/tests/normalization/examples/List/last/0B.dhall +++ b/tests/normalization/examples/List/last/0B.dhall @@ -1,1 +1,1 @@ -[ 2 ] : Optional Natural +Some 2 diff --git a/tests/normalization/examples/List/last/1A.dhall b/tests/normalization/examples/List/last/1A.dhall --- a/tests/normalization/examples/List/last/1A.dhall +++ b/tests/normalization/examples/List/last/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/last Natural ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.last Natural ([] : List Natural) diff --git a/tests/normalization/examples/List/last/1B.dhall b/tests/normalization/examples/List/last/1B.dhall --- a/tests/normalization/examples/List/last/1B.dhall +++ b/tests/normalization/examples/List/last/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/List/length/0A.dhall b/tests/normalization/examples/List/length/0A.dhall --- a/tests/normalization/examples/List/length/0A.dhall +++ b/tests/normalization/examples/List/length/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/length Natural [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`List`.length Natural [ 0, 1, 2 ] diff --git a/tests/normalization/examples/List/length/1A.dhall b/tests/normalization/examples/List/length/1A.dhall --- a/tests/normalization/examples/List/length/1A.dhall +++ b/tests/normalization/examples/List/length/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/length Natural ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.length Natural ([] : List Natural) diff --git a/tests/normalization/examples/List/map/0A.dhall b/tests/normalization/examples/List/map/0A.dhall --- a/tests/normalization/examples/List/map/0A.dhall +++ b/tests/normalization/examples/List/map/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/map Natural Bool Natural/even [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`List`.map Natural Bool Natural/even [ 2, 3, 5 ] diff --git a/tests/normalization/examples/List/map/1A.dhall b/tests/normalization/examples/List/map/1A.dhall --- a/tests/normalization/examples/List/map/1A.dhall +++ b/tests/normalization/examples/List/map/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/map Natural Bool Natural/even ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.map Natural Bool Natural/even ([] : List Natural) diff --git a/tests/normalization/examples/List/null/0A.dhall b/tests/normalization/examples/List/null/0A.dhall --- a/tests/normalization/examples/List/null/0A.dhall +++ b/tests/normalization/examples/List/null/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/null Natural [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`List`.null Natural [ 0, 1, 2 ] diff --git a/tests/normalization/examples/List/null/1A.dhall b/tests/normalization/examples/List/null/1A.dhall --- a/tests/normalization/examples/List/null/1A.dhall +++ b/tests/normalization/examples/List/null/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/null Natural ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.null Natural ([] : List Natural) diff --git a/tests/normalization/examples/List/replicate/0A.dhall b/tests/normalization/examples/List/replicate/0A.dhall --- a/tests/normalization/examples/List/replicate/0A.dhall +++ b/tests/normalization/examples/List/replicate/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/replicate 9 Natural 1 +(../../../../../Prelude/package.dhall).`List`.replicate 9 Natural 1 diff --git a/tests/normalization/examples/List/replicate/1A.dhall b/tests/normalization/examples/List/replicate/1A.dhall --- a/tests/normalization/examples/List/replicate/1A.dhall +++ b/tests/normalization/examples/List/replicate/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/replicate 0 Natural 1 +(../../../../../Prelude/package.dhall).`List`.replicate 0 Natural 1 diff --git a/tests/normalization/examples/List/reverse/0A.dhall b/tests/normalization/examples/List/reverse/0A.dhall --- a/tests/normalization/examples/List/reverse/0A.dhall +++ b/tests/normalization/examples/List/reverse/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/reverse Natural [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`List`.reverse Natural [ 0, 1, 2 ] diff --git a/tests/normalization/examples/List/reverse/1A.dhall b/tests/normalization/examples/List/reverse/1A.dhall --- a/tests/normalization/examples/List/reverse/1A.dhall +++ b/tests/normalization/examples/List/reverse/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/reverse Natural ([] : List Natural) +(../../../../../Prelude/package.dhall).`List`.reverse Natural ([] : List Natural) diff --git a/tests/normalization/examples/List/shifted/0A.dhall b/tests/normalization/examples/List/shifted/0A.dhall --- a/tests/normalization/examples/List/shifted/0A.dhall +++ b/tests/normalization/examples/List/shifted/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/shifted +(../../../../../Prelude/package.dhall).`List`.shifted Bool [ [ { index = 0, value = True } , { index = 1, value = True } diff --git a/tests/normalization/examples/List/shifted/1A.dhall b/tests/normalization/examples/List/shifted/1A.dhall --- a/tests/normalization/examples/List/shifted/1A.dhall +++ b/tests/normalization/examples/List/shifted/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/shifted Bool ([] : List (List { index : Natural, value : Bool })) +(../../../../../Prelude/package.dhall).`List`.shifted Bool ([] : List (List { index : Natural, value : Bool })) diff --git a/tests/normalization/examples/List/unzip/0A.dhall b/tests/normalization/examples/List/unzip/0A.dhall --- a/tests/normalization/examples/List/unzip/0A.dhall +++ b/tests/normalization/examples/List/unzip/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/List/unzip +(../../../../../Prelude/package.dhall).`List`.unzip Text Bool [ { _1 = "ABC", _2 = True } diff --git a/tests/normalization/examples/List/unzip/1A.dhall b/tests/normalization/examples/List/unzip/1A.dhall --- a/tests/normalization/examples/List/unzip/1A.dhall +++ b/tests/normalization/examples/List/unzip/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/unzip Text Bool ([] : List { _1 : Text, _2 : Bool }) +(../../../../../Prelude/package.dhall).`List`.unzip Text Bool ([] : List { _1 : Text, _2 : Bool }) diff --git a/tests/normalization/examples/Natural/build/0A.dhall b/tests/normalization/examples/Natural/build/0A.dhall --- a/tests/normalization/examples/Natural/build/0A.dhall +++ b/tests/normalization/examples/Natural/build/0A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/Natural/build +(../../../../../Prelude/package.dhall).`Natural`.build ( λ(natural : Type) → λ(succ : natural → natural) → λ(zero : natural) diff --git a/tests/normalization/examples/Natural/build/1A.dhall b/tests/normalization/examples/Natural/build/1A.dhall --- a/tests/normalization/examples/Natural/build/1A.dhall +++ b/tests/normalization/examples/Natural/build/1A.dhall @@ -1,4 +1,4 @@ -../../../../../Prelude/Natural/build +(../../../../../Prelude/package.dhall).`Natural`.build ( λ(natural : Type) → λ(succ : natural → natural) → λ(zero : natural) diff --git a/tests/normalization/examples/Natural/enumerate/0A.dhall b/tests/normalization/examples/Natural/enumerate/0A.dhall --- a/tests/normalization/examples/Natural/enumerate/0A.dhall +++ b/tests/normalization/examples/Natural/enumerate/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/enumerate 10 +(../../../../../Prelude/package.dhall).`Natural`.enumerate 10 diff --git a/tests/normalization/examples/Natural/enumerate/1A.dhall b/tests/normalization/examples/Natural/enumerate/1A.dhall --- a/tests/normalization/examples/Natural/enumerate/1A.dhall +++ b/tests/normalization/examples/Natural/enumerate/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/enumerate 0 +(../../../../../Prelude/package.dhall).`Natural`.enumerate 0 diff --git a/tests/normalization/examples/Natural/even/0A.dhall b/tests/normalization/examples/Natural/even/0A.dhall --- a/tests/normalization/examples/Natural/even/0A.dhall +++ b/tests/normalization/examples/Natural/even/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/even 3 +(../../../../../Prelude/package.dhall).`Natural`.even 3 diff --git a/tests/normalization/examples/Natural/even/1A.dhall b/tests/normalization/examples/Natural/even/1A.dhall --- a/tests/normalization/examples/Natural/even/1A.dhall +++ b/tests/normalization/examples/Natural/even/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/even 0 +(../../../../../Prelude/package.dhall).`Natural`.even 0 diff --git a/tests/normalization/examples/Natural/fold/0A.dhall b/tests/normalization/examples/Natural/fold/0A.dhall --- a/tests/normalization/examples/Natural/fold/0A.dhall +++ b/tests/normalization/examples/Natural/fold/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/fold 3 Natural (λ(x : Natural) → 5 * x) 1 +(../../../../../Prelude/package.dhall).`Natural`.fold 3 Natural (λ(x : Natural) → 5 * x) 1 diff --git a/tests/normalization/examples/Natural/fold/1A.dhall b/tests/normalization/examples/Natural/fold/1A.dhall --- a/tests/normalization/examples/Natural/fold/1A.dhall +++ b/tests/normalization/examples/Natural/fold/1A.dhall @@ -1,1 +1,1 @@ -λ(zero : Natural) → ../../../../../Prelude/Natural/fold 3 Natural (λ(x : Natural) → 5 * x) zero +λ(zero : Natural) → (../../../../../Prelude/package.dhall).`Natural`.fold 3 Natural (λ(x : Natural) → 5 * x) zero diff --git a/tests/normalization/examples/Natural/fold/1B.dhall b/tests/normalization/examples/Natural/fold/1B.dhall --- a/tests/normalization/examples/Natural/fold/1B.dhall +++ b/tests/normalization/examples/Natural/fold/1B.dhall @@ -1,1 +1,1 @@ -λ(zero : Natural) → 5 * 5 * 5 * zero +λ(zero : Natural) → 5 * (5 * (5 * zero)) diff --git a/tests/normalization/examples/Natural/fold/2A.dhall b/tests/normalization/examples/Natural/fold/2A.dhall --- a/tests/normalization/examples/Natural/fold/2A.dhall +++ b/tests/normalization/examples/Natural/fold/2A.dhall @@ -1,4 +1,4 @@ λ(natural : Type) → λ(succ : natural → natural) → λ(zero : natural) -→ ../../../../../Prelude/Natural/fold 3 natural succ zero +→ (../../../../../Prelude/package.dhall).`Natural`.fold 3 natural succ zero diff --git a/tests/normalization/examples/Natural/isZero/0A.dhall b/tests/normalization/examples/Natural/isZero/0A.dhall --- a/tests/normalization/examples/Natural/isZero/0A.dhall +++ b/tests/normalization/examples/Natural/isZero/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/isZero 2 +(../../../../../Prelude/package.dhall).`Natural`.isZero 2 diff --git a/tests/normalization/examples/Natural/isZero/1A.dhall b/tests/normalization/examples/Natural/isZero/1A.dhall --- a/tests/normalization/examples/Natural/isZero/1A.dhall +++ b/tests/normalization/examples/Natural/isZero/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/isZero 0 +(../../../../../Prelude/package.dhall).`Natural`.isZero 0 diff --git a/tests/normalization/examples/Natural/odd/0A.dhall b/tests/normalization/examples/Natural/odd/0A.dhall --- a/tests/normalization/examples/Natural/odd/0A.dhall +++ b/tests/normalization/examples/Natural/odd/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/odd 3 +(../../../../../Prelude/package.dhall).`Natural`.odd 3 diff --git a/tests/normalization/examples/Natural/odd/1A.dhall b/tests/normalization/examples/Natural/odd/1A.dhall --- a/tests/normalization/examples/Natural/odd/1A.dhall +++ b/tests/normalization/examples/Natural/odd/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/odd 0 +(../../../../../Prelude/package.dhall).`Natural`.odd 0 diff --git a/tests/normalization/examples/Natural/product/0A.dhall b/tests/normalization/examples/Natural/product/0A.dhall --- a/tests/normalization/examples/Natural/product/0A.dhall +++ b/tests/normalization/examples/Natural/product/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/product [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`Natural`.product [ 2, 3, 5 ] diff --git a/tests/normalization/examples/Natural/product/1A.dhall b/tests/normalization/examples/Natural/product/1A.dhall --- a/tests/normalization/examples/Natural/product/1A.dhall +++ b/tests/normalization/examples/Natural/product/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/product ([] : List Natural) +(../../../../../Prelude/package.dhall).`Natural`.product ([] : List Natural) diff --git a/tests/normalization/examples/Natural/show/0A.dhall b/tests/normalization/examples/Natural/show/0A.dhall --- a/tests/normalization/examples/Natural/show/0A.dhall +++ b/tests/normalization/examples/Natural/show/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/show 3 +(../../../../../Prelude/package.dhall).`Natural`.show 3 diff --git a/tests/normalization/examples/Natural/show/1A.dhall b/tests/normalization/examples/Natural/show/1A.dhall --- a/tests/normalization/examples/Natural/show/1A.dhall +++ b/tests/normalization/examples/Natural/show/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/show 0 +(../../../../../Prelude/package.dhall).`Natural`.show 0 diff --git a/tests/normalization/examples/Natural/sum/0A.dhall b/tests/normalization/examples/Natural/sum/0A.dhall --- a/tests/normalization/examples/Natural/sum/0A.dhall +++ b/tests/normalization/examples/Natural/sum/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/sum [ 2, 3, 5 ] +(../../../../../Prelude/package.dhall).`Natural`.sum [ 2, 3, 5 ] diff --git a/tests/normalization/examples/Natural/sum/1A.dhall b/tests/normalization/examples/Natural/sum/1A.dhall --- a/tests/normalization/examples/Natural/sum/1A.dhall +++ b/tests/normalization/examples/Natural/sum/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/sum ([] : List Natural) +(../../../../../Prelude/package.dhall).`Natural`.sum ([] : List Natural) diff --git a/tests/normalization/examples/Natural/toDouble/0A.dhall b/tests/normalization/examples/Natural/toDouble/0A.dhall --- a/tests/normalization/examples/Natural/toDouble/0A.dhall +++ b/tests/normalization/examples/Natural/toDouble/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/toDouble 3 +(../../../../../Prelude/package.dhall).`Natural`.toDouble 3 diff --git a/tests/normalization/examples/Natural/toDouble/1A.dhall b/tests/normalization/examples/Natural/toDouble/1A.dhall --- a/tests/normalization/examples/Natural/toDouble/1A.dhall +++ b/tests/normalization/examples/Natural/toDouble/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/toDouble 0 +(../../../../../Prelude/package.dhall).`Natural`.toDouble 0 diff --git a/tests/normalization/examples/Natural/toInteger/0A.dhall b/tests/normalization/examples/Natural/toInteger/0A.dhall --- a/tests/normalization/examples/Natural/toInteger/0A.dhall +++ b/tests/normalization/examples/Natural/toInteger/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/toInteger 3 +(../../../../../Prelude/package.dhall).`Natural`.toInteger 3 diff --git a/tests/normalization/examples/Natural/toInteger/1A.dhall b/tests/normalization/examples/Natural/toInteger/1A.dhall --- a/tests/normalization/examples/Natural/toInteger/1A.dhall +++ b/tests/normalization/examples/Natural/toInteger/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Natural/toInteger 0 +(../../../../../Prelude/package.dhall).`Natural`.toInteger 0 diff --git a/tests/normalization/examples/Optional/all/0A.dhall b/tests/normalization/examples/Optional/all/0A.dhall --- a/tests/normalization/examples/Optional/all/0A.dhall +++ b/tests/normalization/examples/Optional/all/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/all Natural Natural/even ([ 3 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.all Natural Natural/even (Some 3) diff --git a/tests/normalization/examples/Optional/all/1A.dhall b/tests/normalization/examples/Optional/all/1A.dhall --- a/tests/normalization/examples/Optional/all/1A.dhall +++ b/tests/normalization/examples/Optional/all/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/all Natural Natural/even ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.all Natural Natural/even (None Natural) diff --git a/tests/normalization/examples/Optional/any/0A.dhall b/tests/normalization/examples/Optional/any/0A.dhall --- a/tests/normalization/examples/Optional/any/0A.dhall +++ b/tests/normalization/examples/Optional/any/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/any Natural Natural/even ([ 2 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.any Natural Natural/even (Some 2) diff --git a/tests/normalization/examples/Optional/any/1A.dhall b/tests/normalization/examples/Optional/any/1A.dhall --- a/tests/normalization/examples/Optional/any/1A.dhall +++ b/tests/normalization/examples/Optional/any/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/any Natural Natural/even ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.any Natural Natural/even (None Natural) diff --git a/tests/normalization/examples/Optional/build/0A.dhall b/tests/normalization/examples/Optional/build/0A.dhall --- a/tests/normalization/examples/Optional/build/0A.dhall +++ b/tests/normalization/examples/Optional/build/0A.dhall @@ -1,7 +1,7 @@ -../../../../../Prelude/Optional/build +(../../../../../Prelude/package.dhall).`Optional`.build Natural ( λ(optional : Type) -→ λ(just : Natural → optional) -→ λ(nothing : optional) -→ just 1 +→ λ(some : Natural → optional) +→ λ(none : optional) +→ some 1 ) diff --git a/tests/normalization/examples/Optional/build/0B.dhall b/tests/normalization/examples/Optional/build/0B.dhall --- a/tests/normalization/examples/Optional/build/0B.dhall +++ b/tests/normalization/examples/Optional/build/0B.dhall @@ -1,1 +1,1 @@ -[ 1 ] : Optional Natural +Some 1 diff --git a/tests/normalization/examples/Optional/build/1A.dhall b/tests/normalization/examples/Optional/build/1A.dhall --- a/tests/normalization/examples/Optional/build/1A.dhall +++ b/tests/normalization/examples/Optional/build/1A.dhall @@ -1,7 +1,7 @@ -../../../../../Prelude/Optional/build +(../../../../../Prelude/package.dhall).`Optional`.build Natural ( λ(optional : Type) -→ λ(just : Natural → optional) -→ λ(nothing : optional) -→ nothing +→ λ(some : Natural → optional) +→ λ(none : optional) +→ none ) diff --git a/tests/normalization/examples/Optional/build/1B.dhall b/tests/normalization/examples/Optional/build/1B.dhall --- a/tests/normalization/examples/Optional/build/1B.dhall +++ b/tests/normalization/examples/Optional/build/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/concat/0A.dhall b/tests/normalization/examples/Optional/concat/0A.dhall --- a/tests/normalization/examples/Optional/concat/0A.dhall +++ b/tests/normalization/examples/Optional/concat/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/concat Natural ([ [ 1 ] : Optional Natural ] : Optional (Optional Natural)) +(../../../../../Prelude/package.dhall).`Optional`.concat Natural (Some (Some 1)) diff --git a/tests/normalization/examples/Optional/concat/0B.dhall b/tests/normalization/examples/Optional/concat/0B.dhall --- a/tests/normalization/examples/Optional/concat/0B.dhall +++ b/tests/normalization/examples/Optional/concat/0B.dhall @@ -1,1 +1,1 @@ -[ 1 ] : Optional Natural +Some 1 diff --git a/tests/normalization/examples/Optional/concat/1A.dhall b/tests/normalization/examples/Optional/concat/1A.dhall --- a/tests/normalization/examples/Optional/concat/1A.dhall +++ b/tests/normalization/examples/Optional/concat/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/concat Natural ([ [] : Optional Natural ] : Optional (Optional Natural)) +(../../../../../Prelude/package.dhall).`Optional`.concat Natural (Some (None Natural)) diff --git a/tests/normalization/examples/Optional/concat/1B.dhall b/tests/normalization/examples/Optional/concat/1B.dhall --- a/tests/normalization/examples/Optional/concat/1B.dhall +++ b/tests/normalization/examples/Optional/concat/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/concat/2A.dhall b/tests/normalization/examples/Optional/concat/2A.dhall --- a/tests/normalization/examples/Optional/concat/2A.dhall +++ b/tests/normalization/examples/Optional/concat/2A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/concat Natural ([ [] : Optional Natural ]: Optional (Optional Natural)) +(../../../../../Prelude/package.dhall).`Optional`.concat Natural (None (Optional Natural)) diff --git a/tests/normalization/examples/Optional/concat/2B.dhall b/tests/normalization/examples/Optional/concat/2B.dhall --- a/tests/normalization/examples/Optional/concat/2B.dhall +++ b/tests/normalization/examples/Optional/concat/2B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/filter/0A.dhall b/tests/normalization/examples/Optional/filter/0A.dhall --- a/tests/normalization/examples/Optional/filter/0A.dhall +++ b/tests/normalization/examples/Optional/filter/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/filter Natural Natural/even ([ 2 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.filter Natural Natural/even (Some 2) diff --git a/tests/normalization/examples/Optional/filter/0B.dhall b/tests/normalization/examples/Optional/filter/0B.dhall --- a/tests/normalization/examples/Optional/filter/0B.dhall +++ b/tests/normalization/examples/Optional/filter/0B.dhall @@ -1,1 +1,1 @@ -[ 2 ] : Optional Natural +Some 2 diff --git a/tests/normalization/examples/Optional/filter/1A.dhall b/tests/normalization/examples/Optional/filter/1A.dhall --- a/tests/normalization/examples/Optional/filter/1A.dhall +++ b/tests/normalization/examples/Optional/filter/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/filter Natural Natural/odd ([ 2 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.filter Natural Natural/odd (Some 2) diff --git a/tests/normalization/examples/Optional/filter/1B.dhall b/tests/normalization/examples/Optional/filter/1B.dhall --- a/tests/normalization/examples/Optional/filter/1B.dhall +++ b/tests/normalization/examples/Optional/filter/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/fold/0A.dhall b/tests/normalization/examples/Optional/fold/0A.dhall --- a/tests/normalization/examples/Optional/fold/0A.dhall +++ b/tests/normalization/examples/Optional/fold/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/fold Natural ([ 2 ] : Optional Natural) Natural (λ(x : Natural) → x) 0 +(../../../../../Prelude/package.dhall).`Optional`.fold Natural (Some 2) Natural (λ(x : Natural) → x) 0 diff --git a/tests/normalization/examples/Optional/fold/1A.dhall b/tests/normalization/examples/Optional/fold/1A.dhall --- a/tests/normalization/examples/Optional/fold/1A.dhall +++ b/tests/normalization/examples/Optional/fold/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/fold Natural ([] : Optional Natural) Natural (λ(x : Natural) → x) 0 +(../../../../../Prelude/package.dhall).`Optional`.fold Natural (None Natural) Natural (λ(x : Natural) → x) 0 diff --git a/tests/normalization/examples/Optional/head/0A.dhall b/tests/normalization/examples/Optional/head/0A.dhall --- a/tests/normalization/examples/Optional/head/0A.dhall +++ b/tests/normalization/examples/Optional/head/0A.dhall @@ -1,6 +1,1 @@ -../../../../../Prelude/Optional/head -Natural -[ [] : Optional Natural -, [ 1 ] : Optional Natural -, [ 2 ] : Optional Natural -] +(../../../../../Prelude/package.dhall).`Optional`.head Natural [ None Natural, Some 1, Some 2 ] diff --git a/tests/normalization/examples/Optional/head/0B.dhall b/tests/normalization/examples/Optional/head/0B.dhall --- a/tests/normalization/examples/Optional/head/0B.dhall +++ b/tests/normalization/examples/Optional/head/0B.dhall @@ -1,1 +1,1 @@ -[ 1 ] : Optional Natural +Some 1 diff --git a/tests/normalization/examples/Optional/head/1A.dhall b/tests/normalization/examples/Optional/head/1A.dhall --- a/tests/normalization/examples/Optional/head/1A.dhall +++ b/tests/normalization/examples/Optional/head/1A.dhall @@ -1,3 +1,1 @@ -../../../../../Prelude/Optional/head -Natural -[ [] : Optional Natural, [] : Optional Natural ] +(../../../../../Prelude/package.dhall).`Optional`.head Natural [ None Natural, None Natural ] diff --git a/tests/normalization/examples/Optional/head/1B.dhall b/tests/normalization/examples/Optional/head/1B.dhall --- a/tests/normalization/examples/Optional/head/1B.dhall +++ b/tests/normalization/examples/Optional/head/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/head/2A.dhall b/tests/normalization/examples/Optional/head/2A.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Optional/head/2A.dhall @@ -0,0 +1,1 @@ +(../../../../../Prelude/package.dhall).`Optional`.head Natural ([] : List (Optional Natural)) diff --git a/tests/normalization/examples/Optional/head/2B.dhall b/tests/normalization/examples/Optional/head/2B.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Optional/head/2B.dhall @@ -0,0 +1,1 @@ +None Natural diff --git a/tests/normalization/examples/Optional/last/0A.dhall b/tests/normalization/examples/Optional/last/0A.dhall --- a/tests/normalization/examples/Optional/last/0A.dhall +++ b/tests/normalization/examples/Optional/last/0A.dhall @@ -1,7 +1,1 @@ -../../../../../Prelude/Optional/last -Natural -( [ [] : Optional Natural - , [ 1 ] : Optional Natural - , [ 2 ] : Optional Natural - ] -) +(../../../../../Prelude/package.dhall).`Optional`.last Natural [ None Natural, Some 1, Some 2 ] diff --git a/tests/normalization/examples/Optional/last/0B.dhall b/tests/normalization/examples/Optional/last/0B.dhall --- a/tests/normalization/examples/Optional/last/0B.dhall +++ b/tests/normalization/examples/Optional/last/0B.dhall @@ -1,1 +1,1 @@ -[ 2 ] : Optional Natural +Some 2 diff --git a/tests/normalization/examples/Optional/last/1A.dhall b/tests/normalization/examples/Optional/last/1A.dhall --- a/tests/normalization/examples/Optional/last/1A.dhall +++ b/tests/normalization/examples/Optional/last/1A.dhall @@ -1,3 +1,1 @@ -../../../../../Prelude/Optional/last -Natural -[ [] : Optional Natural, [] : Optional Natural ] +(../../../../../Prelude/package.dhall).`Optional`.last Natural [ None Natural, None Natural ] diff --git a/tests/normalization/examples/Optional/last/1B.dhall b/tests/normalization/examples/Optional/last/1B.dhall --- a/tests/normalization/examples/Optional/last/1B.dhall +++ b/tests/normalization/examples/Optional/last/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/last/2A.dhall b/tests/normalization/examples/Optional/last/2A.dhall --- a/tests/normalization/examples/Optional/last/2A.dhall +++ b/tests/normalization/examples/Optional/last/2A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/last Natural ([] : List (Optional Natural)) +(../../../../../Prelude/package.dhall).`Optional`.last Natural ([] : List (Optional Natural)) diff --git a/tests/normalization/examples/Optional/last/2B.dhall b/tests/normalization/examples/Optional/last/2B.dhall --- a/tests/normalization/examples/Optional/last/2B.dhall +++ b/tests/normalization/examples/Optional/last/2B.dhall @@ -1,1 +1,1 @@ -[] : Optional Natural +None Natural diff --git a/tests/normalization/examples/Optional/length/0A.dhall b/tests/normalization/examples/Optional/length/0A.dhall --- a/tests/normalization/examples/Optional/length/0A.dhall +++ b/tests/normalization/examples/Optional/length/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/length Natural ([ 2 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.length Natural (Some 2) diff --git a/tests/normalization/examples/Optional/length/1A.dhall b/tests/normalization/examples/Optional/length/1A.dhall --- a/tests/normalization/examples/Optional/length/1A.dhall +++ b/tests/normalization/examples/Optional/length/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/length Natural ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.length Natural (None Natural) diff --git a/tests/normalization/examples/Optional/map/0A.dhall b/tests/normalization/examples/Optional/map/0A.dhall --- a/tests/normalization/examples/Optional/map/0A.dhall +++ b/tests/normalization/examples/Optional/map/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/map Natural Bool Natural/even ([ 3 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.map Natural Bool Natural/even (Some 3) diff --git a/tests/normalization/examples/Optional/map/0B.dhall b/tests/normalization/examples/Optional/map/0B.dhall --- a/tests/normalization/examples/Optional/map/0B.dhall +++ b/tests/normalization/examples/Optional/map/0B.dhall @@ -1,1 +1,1 @@ -[ False ] : Optional Bool +Some False diff --git a/tests/normalization/examples/Optional/map/1A.dhall b/tests/normalization/examples/Optional/map/1A.dhall --- a/tests/normalization/examples/Optional/map/1A.dhall +++ b/tests/normalization/examples/Optional/map/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/map Natural Bool Natural/even ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.map Natural Bool Natural/even (None Natural) diff --git a/tests/normalization/examples/Optional/map/1B.dhall b/tests/normalization/examples/Optional/map/1B.dhall --- a/tests/normalization/examples/Optional/map/1B.dhall +++ b/tests/normalization/examples/Optional/map/1B.dhall @@ -1,1 +1,1 @@ -[] : Optional Bool +None Bool diff --git a/tests/normalization/examples/Optional/null/0A.dhall b/tests/normalization/examples/Optional/null/0A.dhall --- a/tests/normalization/examples/Optional/null/0A.dhall +++ b/tests/normalization/examples/Optional/null/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/null Natural ([ 2 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.null Natural (Some 2) diff --git a/tests/normalization/examples/Optional/null/1A.dhall b/tests/normalization/examples/Optional/null/1A.dhall --- a/tests/normalization/examples/Optional/null/1A.dhall +++ b/tests/normalization/examples/Optional/null/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/null Natural ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.null Natural (None Natural) diff --git a/tests/normalization/examples/Optional/toList/0A.dhall b/tests/normalization/examples/Optional/toList/0A.dhall --- a/tests/normalization/examples/Optional/toList/0A.dhall +++ b/tests/normalization/examples/Optional/toList/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/toList Natural ([ 1 ] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.toList Natural (Some 1) diff --git a/tests/normalization/examples/Optional/toList/0B.dhall b/tests/normalization/examples/Optional/toList/0B.dhall --- a/tests/normalization/examples/Optional/toList/0B.dhall +++ b/tests/normalization/examples/Optional/toList/0B.dhall @@ -1,1 +1,1 @@ -[ 1 ] +[ 1 ] : List Natural diff --git a/tests/normalization/examples/Optional/toList/1A.dhall b/tests/normalization/examples/Optional/toList/1A.dhall --- a/tests/normalization/examples/Optional/toList/1A.dhall +++ b/tests/normalization/examples/Optional/toList/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/toList Natural ([] : Optional Natural) +(../../../../../Prelude/package.dhall).`Optional`.toList Natural (None Natural) diff --git a/tests/normalization/examples/Optional/unzip/0A.dhall b/tests/normalization/examples/Optional/unzip/0A.dhall --- a/tests/normalization/examples/Optional/unzip/0A.dhall +++ b/tests/normalization/examples/Optional/unzip/0A.dhall @@ -1,4 +1,1 @@ -../../../../../Prelude/Optional/unzip -Text -Bool -([ { _1 = "ABC", _2 = True } ] : Optional { _1 : Text, _2 : Bool }) +(../../../../../Prelude/package.dhall).`Optional`.unzip Text Bool (Some { _1 = "ABC", _2 = True }) diff --git a/tests/normalization/examples/Optional/unzip/0B.dhall b/tests/normalization/examples/Optional/unzip/0B.dhall --- a/tests/normalization/examples/Optional/unzip/0B.dhall +++ b/tests/normalization/examples/Optional/unzip/0B.dhall @@ -1,1 +1,1 @@ -{ _1 = [ "ABC" ] : Optional Text, _2 = [ True ] : Optional Bool } +{ _1 = Some "ABC", _2 = Some True } diff --git a/tests/normalization/examples/Optional/unzip/1A.dhall b/tests/normalization/examples/Optional/unzip/1A.dhall --- a/tests/normalization/examples/Optional/unzip/1A.dhall +++ b/tests/normalization/examples/Optional/unzip/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Optional/unzip Text Bool ([] : Optional { _1 : Text, _2 : Bool }) +(../../../../../Prelude/package.dhall).`Optional`.unzip Text Bool (None { _1 : Text, _2 : Bool }) diff --git a/tests/normalization/examples/Optional/unzip/1B.dhall b/tests/normalization/examples/Optional/unzip/1B.dhall --- a/tests/normalization/examples/Optional/unzip/1B.dhall +++ b/tests/normalization/examples/Optional/unzip/1B.dhall @@ -1,1 +1,1 @@ -{ _1 = [] : Optional Text, _2 = [] : Optional Bool } +{ _1 = None Text, _2 = None Bool } diff --git a/tests/normalization/examples/Text/concat/0A.dhall b/tests/normalization/examples/Text/concat/0A.dhall --- a/tests/normalization/examples/Text/concat/0A.dhall +++ b/tests/normalization/examples/Text/concat/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concat [ "ABC", "DEF", "GHI" ] +(../../../../../Prelude/package.dhall).`Text`.concat [ "ABC", "DEF", "GHI" ] diff --git a/tests/normalization/examples/Text/concat/1A.dhall b/tests/normalization/examples/Text/concat/1A.dhall --- a/tests/normalization/examples/Text/concat/1A.dhall +++ b/tests/normalization/examples/Text/concat/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concat ([] : List Text) +(../../../../../Prelude/package.dhall).`Text`.concat ([] : List Text) diff --git a/tests/normalization/examples/Text/concatMap/0A.dhall b/tests/normalization/examples/Text/concatMap/0A.dhall --- a/tests/normalization/examples/Text/concatMap/0A.dhall +++ b/tests/normalization/examples/Text/concatMap/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatMap Natural (λ(n : Natural) → "${Natural/show n} ") [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`Text`.concatMap Natural (λ(n : Natural) → "${Natural/show n} ") [ 0, 1, 2 ] diff --git a/tests/normalization/examples/Text/concatMap/1A.dhall b/tests/normalization/examples/Text/concatMap/1A.dhall --- a/tests/normalization/examples/Text/concatMap/1A.dhall +++ b/tests/normalization/examples/Text/concatMap/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatMap Natural (λ(n : Natural) → "${Natural/show n} ") ([] : List Natural) +(../../../../../Prelude/package.dhall).`Text`.concatMap Natural (λ(n : Natural) → "${Natural/show n} ") ([] : List Natural) diff --git a/tests/normalization/examples/Text/concatMapSep/0A.dhall b/tests/normalization/examples/Text/concatMapSep/0A.dhall --- a/tests/normalization/examples/Text/concatMapSep/0A.dhall +++ b/tests/normalization/examples/Text/concatMapSep/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatMapSep ", " Natural Natural/show [ 0, 1, 2 ] +(../../../../../Prelude/package.dhall).`Text`.concatMapSep ", " Natural Natural/show [ 0, 1, 2 ] diff --git a/tests/normalization/examples/Text/concatMapSep/1A.dhall b/tests/normalization/examples/Text/concatMapSep/1A.dhall --- a/tests/normalization/examples/Text/concatMapSep/1A.dhall +++ b/tests/normalization/examples/Text/concatMapSep/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatMapSep ", " Natural Natural/show ([] : List Natural) +(../../../../../Prelude/package.dhall).`Text`.concatMapSep ", " Natural Natural/show ([] : List Natural) diff --git a/tests/normalization/examples/Text/concatSep/0A.dhall b/tests/normalization/examples/Text/concatSep/0A.dhall --- a/tests/normalization/examples/Text/concatSep/0A.dhall +++ b/tests/normalization/examples/Text/concatSep/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatSep ", " [ "ABC", "DEF", "GHI" ] +(../../../../../Prelude/package.dhall).`Text`.concatSep ", " [ "ABC", "DEF", "GHI" ] diff --git a/tests/normalization/examples/Text/concatSep/1A.dhall b/tests/normalization/examples/Text/concatSep/1A.dhall --- a/tests/normalization/examples/Text/concatSep/1A.dhall +++ b/tests/normalization/examples/Text/concatSep/1A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/Text/concatSep ", " ([] : List Text) +(../../../../../Prelude/package.dhall).`Text`.concatSep ", " ([] : List Text) diff --git a/tests/normalization/remoteSystemsA.dhall b/tests/normalization/remoteSystemsA.dhall --- a/tests/normalization/remoteSystemsA.dhall +++ b/tests/normalization/remoteSystemsA.dhall @@ -1,8 +1,8 @@ let Text/concatMap = - ../../Prelude/Text/concatMap +( ../../Prelude/package.dhall).`Text`.concatMap in let Text/concatSep = - ../../Prelude/Text/concatSep +( ../../Prelude/package.dhall).`Text`.concatSep in let Row = { cores : diff --git a/tests/normalization/sortOperatorA.dhall b/tests/normalization/sortOperatorA.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/sortOperatorA.dhall @@ -0,0 +1,1 @@ +{ b = 2 } // { a = 1 } diff --git a/tests/normalization/sortOperatorB.dhall b/tests/normalization/sortOperatorB.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/sortOperatorB.dhall @@ -0,0 +1,1 @@ +{ a = 1, b = 2 } diff --git a/tests/parser/sort.dhall b/tests/parser/sort.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/sort.dhall @@ -0,0 +1,1 @@ +Sort diff --git a/tests/typecheck/combineMixedRecords.dhall b/tests/typecheck/combineMixedRecords.dhall deleted file mode 100644 --- a/tests/typecheck/combineMixedRecords.dhall +++ /dev/null @@ -1,1 +0,0 @@ -{ foo = 1 } ∧ { bar = Text } diff --git a/tests/typecheck/examples/Monoid/00A.dhall b/tests/typecheck/examples/Monoid/00A.dhall --- a/tests/typecheck/examples/Monoid/00A.dhall +++ b/tests/typecheck/examples/Monoid/00A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Bool/and +(../../../../Prelude/package.dhall).`Bool`.and diff --git a/tests/typecheck/examples/Monoid/01A.dhall b/tests/typecheck/examples/Monoid/01A.dhall --- a/tests/typecheck/examples/Monoid/01A.dhall +++ b/tests/typecheck/examples/Monoid/01A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Bool/or +(../../../../Prelude/package.dhall).`Bool`.or diff --git a/tests/typecheck/examples/Monoid/02A.dhall b/tests/typecheck/examples/Monoid/02A.dhall --- a/tests/typecheck/examples/Monoid/02A.dhall +++ b/tests/typecheck/examples/Monoid/02A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Bool/even +(../../../../Prelude/package.dhall).`Bool`.even diff --git a/tests/typecheck/examples/Monoid/03A.dhall b/tests/typecheck/examples/Monoid/03A.dhall --- a/tests/typecheck/examples/Monoid/03A.dhall +++ b/tests/typecheck/examples/Monoid/03A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Bool/odd +(../../../../Prelude/package.dhall).`Bool`.odd diff --git a/tests/typecheck/examples/Monoid/04A.dhall b/tests/typecheck/examples/Monoid/04A.dhall --- a/tests/typecheck/examples/Monoid/04A.dhall +++ b/tests/typecheck/examples/Monoid/04A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/List/concat +(../../../../Prelude/package.dhall).`List`.concat diff --git a/tests/typecheck/examples/Monoid/05A.dhall b/tests/typecheck/examples/Monoid/05A.dhall --- a/tests/typecheck/examples/Monoid/05A.dhall +++ b/tests/typecheck/examples/Monoid/05A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/List/shifted +(../../../../Prelude/package.dhall).`List`.shifted diff --git a/tests/typecheck/examples/Monoid/06A.dhall b/tests/typecheck/examples/Monoid/06A.dhall --- a/tests/typecheck/examples/Monoid/06A.dhall +++ b/tests/typecheck/examples/Monoid/06A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Natural/sum +(../../../../Prelude/package.dhall).`Natural`.sum diff --git a/tests/typecheck/examples/Monoid/07A.dhall b/tests/typecheck/examples/Monoid/07A.dhall --- a/tests/typecheck/examples/Monoid/07A.dhall +++ b/tests/typecheck/examples/Monoid/07A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Natural/product +(../../../../Prelude/package.dhall).`Natural`.product diff --git a/tests/typecheck/examples/Monoid/08A.dhall b/tests/typecheck/examples/Monoid/08A.dhall --- a/tests/typecheck/examples/Monoid/08A.dhall +++ b/tests/typecheck/examples/Monoid/08A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Optional/head +(../../../../Prelude/package.dhall).`Optional`.head diff --git a/tests/typecheck/examples/Monoid/09A.dhall b/tests/typecheck/examples/Monoid/09A.dhall --- a/tests/typecheck/examples/Monoid/09A.dhall +++ b/tests/typecheck/examples/Monoid/09A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Optional/last +(../../../../Prelude/package.dhall).`Optional`.last diff --git a/tests/typecheck/examples/Monoid/10A.dhall b/tests/typecheck/examples/Monoid/10A.dhall --- a/tests/typecheck/examples/Monoid/10A.dhall +++ b/tests/typecheck/examples/Monoid/10A.dhall @@ -1,1 +1,1 @@ -../../../../Prelude/Text/concat +(../../../../Prelude/package.dhall).`Text`.concat diff --git a/tests/typecheck/failure/combineMixedRecords.dhall b/tests/typecheck/failure/combineMixedRecords.dhall new file mode 100644 --- /dev/null +++ b/tests/typecheck/failure/combineMixedRecords.dhall @@ -0,0 +1,1 @@ +{ foo = 1 } ∧ { bar = Text } diff --git a/tests/typecheck/failure/preferMixedRecords.dhall b/tests/typecheck/failure/preferMixedRecords.dhall new file mode 100644 --- /dev/null +++ b/tests/typecheck/failure/preferMixedRecords.dhall @@ -0,0 +1,1 @@ +{ foo = 1 } ⫽ { bar = Text } diff --git a/tests/typecheck/fieldsAreTypesA.dhall b/tests/typecheck/fieldsAreTypesA.dhall --- a/tests/typecheck/fieldsAreTypesA.dhall +++ b/tests/typecheck/fieldsAreTypesA.dhall @@ -1,1 +1,1 @@ -{ x = Bool, y = Text } +{ x = Bool, y = Text, z = List } diff --git a/tests/typecheck/fieldsAreTypesB.dhall b/tests/typecheck/fieldsAreTypesB.dhall --- a/tests/typecheck/fieldsAreTypesB.dhall +++ b/tests/typecheck/fieldsAreTypesB.dhall @@ -1,1 +1,1 @@ -{ x : Type, y : Type } +{ x : Type, y : Type, z : Type → Type } diff --git a/tests/typecheck/kindParameterA.dhall b/tests/typecheck/kindParameterA.dhall new file mode 100644 --- /dev/null +++ b/tests/typecheck/kindParameterA.dhall @@ -0,0 +1,1 @@ +λ(k : Kind) → λ(a : k → k → Type) → λ(x : k) → a x diff --git a/tests/typecheck/kindParameterB.dhall b/tests/typecheck/kindParameterB.dhall new file mode 100644 --- /dev/null +++ b/tests/typecheck/kindParameterB.dhall @@ -0,0 +1,1 @@ +∀(k : Kind) → (k → k → Type) → k → k → Type diff --git a/tests/typecheck/preferMixedRecords.dhall b/tests/typecheck/preferMixedRecords.dhall deleted file mode 100644 --- a/tests/typecheck/preferMixedRecords.dhall +++ /dev/null @@ -1,1 +0,0 @@ -{ foo = 1 } ⫽ { bar = Text }