diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,30 @@
+1.37.0
+
+* [Supports version 20.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v20.0.0)
+ * [Implement revised `Text/replace` β-normalization](https://github.com/dhall-lang/dhall-haskell/pull/2072)
+ * [Allow `Text/replace ""` to support an abstract haystack](https://github.com/dhall-lang/dhall-haskell/pull/2084)
+ * [Support `if` expressions returning a type or kind](https://github.com/dhall-lang/dhall-haskell/pull/2080)
+* BREAKING CHANGE TO THE API: [Improve error message for duplicate projection label](https://github.com/dhall-lang/dhall-haskell/pull/2097)
+ * This also makes the implementation more standards-compliant, by treating
+ a duplicate label as a type error instead of a parse error
+ * This is a breaking change since the `Project` constructor now stores a
+ `[Text]` instead of `Set Text`
+* [Add `--cache` flag to `dhall hash`](https://github.com/dhall-lang/dhall-haskell/pull/2093)
+ * This flag adds the hashed expression to the cache when enabled
+* [Deprecate `Inject` / `Interpret`](https://github.com/dhall-lang/dhall-haskell/pull/2099)
+ * You should instead use `ToDhall` / `FromDhall`, respectively
+* Fixes and improvements to the haddocks:
+ * [#2098](https://github.com/dhall-lang/dhall-haskell/pull/2098)
+ * [#2100](https://github.com/dhall-lang/dhall-haskell/pull/2100)
+* Fixes and improvements to error messages:
+ * [#2082](https://github.com/dhall-lang/dhall-haskell/pull/2082)
+ * [#2095](https://github.com/dhall-lang/dhall-haskell/pull/2095)
+* Fixes and improvements to the parser:
+ * [#2083](https://github.com/dhall-lang/dhall-haskell/pull/2089)
+* Fixes and improvements to the pretty printer:
+ * [#2083](https://github.com/dhall-lang/dhall-haskell/pull/2083)
+ * [#2101](https://github.com/dhall-lang/dhall-haskell/pull/2101)
+
1.36.0
* [Supports version 19.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v19.0.0)
diff --git a/dhall-lang/Prelude/Integer/multiply.dhall b/dhall-lang/Prelude/Integer/multiply.dhall
--- a/dhall-lang/Prelude/Integer/multiply.dhall
+++ b/dhall-lang/Prelude/Integer/multiply.dhall
@@ -1,5 +1,4 @@
--| `multiply m n` computes `m * n`.
-
let nonPositive =
./nonPositive.dhall sha256:e00a852eed5b84ff60487097d8aadce53c9e5301f53ff4954044bd68949fac3b
? ./nonPositive.dhall
diff --git a/dhall-lang/Prelude/JSON/Format.dhall b/dhall-lang/Prelude/JSON/Format.dhall
--- a/dhall-lang/Prelude/JSON/Format.dhall
+++ b/dhall-lang/Prelude/JSON/Format.dhall
@@ -4,5 +4,4 @@
You should not need to use this type directly, simply use `./render`
or `./renderYAML` as appropriate.
-}
-
< YAML | JSON >
diff --git a/dhall-lang/Prelude/JSON/package.dhall b/dhall-lang/Prelude/JSON/package.dhall
--- a/dhall-lang/Prelude/JSON/package.dhall
+++ b/dhall-lang/Prelude/JSON/package.dhall
@@ -1,8 +1,11 @@
{ render =
- ./render.dhall sha256:b5e5aee66b8fc018b50e1019a76340deafe5f8176854ea3611476d79990785da
+ ./render.dhall sha256:36befdd8bb5a1c2b372709da245a8d074533b86429e137b894c08ad16fa34836
? ./render.dhall
+ , renderCompact =
+ ./renderCompact.dhall sha256:e6c8809fbe193fddd430f94350d69cefd45e7aaf8bd379e51b750fde75008562
+ ? ./renderCompact.dhall
, renderYAML =
- ./renderYAML.dhall sha256:dad92a120956ae852be7496d1e1955bbf3f60834ab2ad32641269098f2846477
+ ./renderYAML.dhall sha256:bc71449397bbf48103c3ebbdd570cd27313115e94b2b1b96761d257d5c02d478
? ./renderYAML.dhall
, omitNullFields =
./omitNullFields.dhall sha256:e6850e70094540b75edeb46f4d6038324a62def8d63544a1e9541f79739db6f0
diff --git a/dhall-lang/Prelude/JSON/render b/dhall-lang/Prelude/JSON/render
--- a/dhall-lang/Prelude/JSON/render
+++ b/dhall-lang/Prelude/JSON/render
@@ -1,2 +1,2 @@
- ./render.dhall sha256:b5e5aee66b8fc018b50e1019a76340deafe5f8176854ea3611476d79990785da
+ ./render.dhall sha256:36befdd8bb5a1c2b372709da245a8d074533b86429e137b894c08ad16fa34836
? ./render.dhall
diff --git a/dhall-lang/Prelude/JSON/render.dhall b/dhall-lang/Prelude/JSON/render.dhall
--- a/dhall-lang/Prelude/JSON/render.dhall
+++ b/dhall-lang/Prelude/JSON/render.dhall
@@ -9,7 +9,7 @@
? ./core.dhall
let renderAs =
- ./renderAs.dhall sha256:5576473c02bc447d40d08bf103aaeca9637c1040367fdf07ff70032ba3e28043
+ ./renderAs.dhall sha256:c23be039c9601a33d6546fd99a8d72bee8dde5f46176d57cc96613b31a3bb471
? ./renderAs.dhall
let Format =
diff --git a/dhall-lang/Prelude/JSON/renderAs b/dhall-lang/Prelude/JSON/renderAs
--- a/dhall-lang/Prelude/JSON/renderAs
+++ b/dhall-lang/Prelude/JSON/renderAs
@@ -1,2 +1,2 @@
- ./renderAs.dhall sha256:5576473c02bc447d40d08bf103aaeca9637c1040367fdf07ff70032ba3e28043
+ ./renderAs.dhall sha256:c23be039c9601a33d6546fd99a8d72bee8dde5f46176d57cc96613b31a3bb471
? ./renderAs.dhall
diff --git a/dhall-lang/Prelude/JSON/renderAs.dhall b/dhall-lang/Prelude/JSON/renderAs.dhall
--- a/dhall-lang/Prelude/JSON/renderAs.dhall
+++ b/dhall-lang/Prelude/JSON/renderAs.dhall
@@ -1,5 +1,4 @@
--| Render a `JSON` value as `Text` in either JSON or YAML format.
-
let JSON =
./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5
? ./core.dhall
@@ -195,6 +194,22 @@
let ObjectField = { mapKey : Text, mapValue : Block }
+let -- Essentially the same thing as `Text/show`, except that this does not
+ -- escape `$`
+ escape =
+ List/fold
+ (Text → Text)
+ [ Text/replace "\"" "\\\""
+ , Text/replace "\b" "\\b"
+ , Text/replace "\f" "\\f"
+ , Text/replace "\n" "\\n"
+ , Text/replace "\r" "\\r"
+ , Text/replace "\t" "\\t"
+ , Text/replace "\\" "\\\\"
+ ]
+ Text
+ (λ(replace : Text → Text) → λ(text : Text) → replace text)
+
let renderJSONStruct =
λ(prefix : Text) →
λ(suffix : Text) →
@@ -225,7 +240,7 @@
let renderObject =
λ(format : Format) →
λ(fields : NonEmpty ObjectField) →
- let keystr = λ(field : ObjectField) → "${Text/show field.mapKey}:"
+ let keystr = λ(field : ObjectField) → "\"${escape field.mapKey}\":"
let prefixKeyOnFirst =
λ(field : ObjectField) →
@@ -294,7 +309,7 @@
blockToText
( json
Block
- { string = λ(x : Text) → Block.Simple (Text/show x)
+ { string = λ(x : Text) → Block.Simple "\"${escape x}\""
, double = λ(x : Double) → Block.Simple (Double/show x)
, integer = λ(x : Integer) → Block.Simple (JSON.renderInteger x)
, object = manyBlocks ObjectField "{}" (renderObject format)
@@ -424,5 +439,24 @@
''
in True
+
+let example3 =
+ let specialCharacters =
+ ''
+ "\${"\b\f"}
+ ${"\r"} $''
+
+ let data =
+ JSON.object
+ [ { mapKey = specialCharacters
+ , mapValue = JSON.string specialCharacters
+ }
+ ]
+
+ in assert
+ : renderAs Format.JSON data
+ ≡ ''
+ { "\"\\\b\f\n\r\t$": "\"\\\b\f\n\r\t$" }
+ ''
in renderAs
diff --git a/dhall-lang/Prelude/JSON/renderCompact.dhall b/dhall-lang/Prelude/JSON/renderCompact.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/Prelude/JSON/renderCompact.dhall
@@ -0,0 +1,58 @@
+--| This renders JSON on a single line
+let JSON =
+ ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5
+ ? ./core.dhall
+
+let Text/concatMapSep =
+ ../Text/concatMapSep sha256:c272aca80a607bc5963d1fcb38819e7e0d3e72ac4d02b1183b1afb6a91340840
+ ? ../Text/concatMapSep
+
+let renderInteger =
+ ./renderInteger.dhall sha256:15b8d2ae46d5002832741927af787761df49798c911e2bf85db7a7b9cb5c078c
+ ? ./renderInteger.dhall
+
+let renderCompact
+ : JSON.Type → Text
+ = λ(j : JSON.Type) →
+ j
+ Text
+ { string = Text/show
+ , double = Double/show
+ , integer = renderInteger
+ , object =
+ λ(x : List { mapKey : Text, mapValue : Text }) →
+ let body =
+ Text/concatMapSep
+ ","
+ { mapKey : Text, mapValue : Text }
+ ( λ(e : { mapKey : Text, mapValue : Text }) →
+ " ${Text/show e.mapKey}: ${e.mapValue}"
+ )
+ x
+
+ in "{${body} }"
+ , array =
+ λ(x : List Text) →
+ let body = Text/concatMapSep "," Text (λ(y : Text) → " ${y}") x
+
+ in "[${body} ]"
+ , bool = λ(x : Bool) → if x then "true" else "false"
+ , null = "null"
+ }
+
+let example =
+ assert
+ : renderCompact
+ ( JSON.array
+ [ JSON.bool True
+ , JSON.string "Hello"
+ , JSON.object
+ [ { mapKey = "foo", mapValue = JSON.null }
+ , { mapKey = "bar", mapValue = JSON.double 1.1 }
+ , { mapKey = "baz", mapValue = JSON.integer +2 }
+ ]
+ ]
+ )
+ ≡ "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.1, \"baz\": 2 } ]"
+
+in renderCompact
diff --git a/dhall-lang/Prelude/JSON/renderInteger.dhall b/dhall-lang/Prelude/JSON/renderInteger.dhall
--- a/dhall-lang/Prelude/JSON/renderInteger.dhall
+++ b/dhall-lang/Prelude/JSON/renderInteger.dhall
@@ -2,7 +2,6 @@
Render an `Integer` value as a `JSON number`, according to the JSON standard, in
which a number may not start with a plus sign (`+`).
-}
-
let Integer/nonNegative =
../Integer/nonNegative.dhall sha256:b463373f070df6b1c8c7082051e0810fee38b360bab35256187c8c2b6af5c663
? ../Integer/nonNegative.dhall
diff --git a/dhall-lang/Prelude/JSON/renderYAML b/dhall-lang/Prelude/JSON/renderYAML
--- a/dhall-lang/Prelude/JSON/renderYAML
+++ b/dhall-lang/Prelude/JSON/renderYAML
@@ -1,2 +1,2 @@
- ./renderYAML.dhall sha256:dad92a120956ae852be7496d1e1955bbf3f60834ab2ad32641269098f2846477
+ ./renderYAML.dhall sha256:bc71449397bbf48103c3ebbdd570cd27313115e94b2b1b96761d257d5c02d478
? ./renderYAML.dhall
diff --git a/dhall-lang/Prelude/JSON/renderYAML.dhall b/dhall-lang/Prelude/JSON/renderYAML.dhall
--- a/dhall-lang/Prelude/JSON/renderYAML.dhall
+++ b/dhall-lang/Prelude/JSON/renderYAML.dhall
@@ -8,13 +8,12 @@
For anything more sophisticated you should use `dhall-to-json` or
`dhall-to-yaml`.
-}
-
let JSON =
./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5
? ./core.dhall
let renderAs =
- ./renderAs.dhall sha256:5576473c02bc447d40d08bf103aaeca9637c1040367fdf07ff70032ba3e28043
+ ./renderAs.dhall sha256:c23be039c9601a33d6546fd99a8d72bee8dde5f46176d57cc96613b31a3bb471
? ./renderAs.dhall
let Format =
diff --git a/dhall-lang/Prelude/List/unpackOptionals.dhall b/dhall-lang/Prelude/List/unpackOptionals.dhall
--- a/dhall-lang/Prelude/List/unpackOptionals.dhall
+++ b/dhall-lang/Prelude/List/unpackOptionals.dhall
@@ -1,5 +1,4 @@
--| Unpack Optionals in a List, omitting None items.
-
let List/concatMap =
./concatMap.dhall sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64
? ./concatMap.dhall
diff --git a/dhall-lang/Prelude/Map/unpackOptionals.dhall b/dhall-lang/Prelude/Map/unpackOptionals.dhall
--- a/dhall-lang/Prelude/Map/unpackOptionals.dhall
+++ b/dhall-lang/Prelude/Map/unpackOptionals.dhall
@@ -1,6 +1,5 @@
--| Turn a `Map k (Optional v)` into a `Map k v` by dropping all
-- entries with value `None`.
-
let List/concatMap =
../List/concatMap.dhall sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64
? ../List/concatMap.dhall
diff --git a/dhall-lang/Prelude/Operator/package.dhall b/dhall-lang/Prelude/Operator/package.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/Prelude/Operator/package.dhall
@@ -0,0 +1,85 @@
+{-
+Note: This package does not use one file per function because the operator
+names contain symbols such as `*` that may cause problems.
+-}
+let {-
+ `+` m n
+
+ computes `m + n`
+ -} `+`
+ : Natural → Natural → Natural
+ = λ(m : Natural) → λ(n : Natural) → m + n
+
+let example1 = assert : `+` 2 1 ≡ 3
+
+let {-
+ `*` m n
+
+ computes `m * n`
+ -} `*`
+ : Natural → Natural → Natural
+ = λ(m : Natural) → λ(n : Natural) → m * n
+
+let example2 = assert : `*` 21 2 ≡ 42
+
+let {-
+ `++` m n
+
+ computes `m ++ n`
+ -} `++`
+ : Text → Text → Text
+ = λ(m : Text) → λ(n : Text) → m ++ n
+
+let example3 = assert : `++` "Hello" "Dhall" ≡ "HelloDhall"
+
+let {-
+ `#` Type m n
+
+ computes `m # n`
+ -} `#`
+ : ∀(type : Type) → List type → List type → List type
+ = λ(type : Type) → λ(m : List type) → λ(n : List type) → m # n
+
+let example4 = assert : `#` Natural [ 1, 2 ] [ 3 ] ≡ [ 1, 2, 3 ]
+
+let {-
+ `==` m n
+
+ computes `m == n`
+ -} `==`
+ : Bool → Bool → Bool
+ = λ(m : Bool) → λ(n : Bool) → m == n
+
+let example5 = assert : `==` True False ≡ False
+
+let {-
+ `!=` m n
+
+ computes `m != n`
+ -} `!=`
+ : Bool → Bool → Bool
+ = λ(m : Bool) → λ(n : Bool) → m != n
+
+let example6 = assert : `!=` True False ≡ True
+
+let {-
+ `&&` m n
+
+ computes `m && n`
+ -} `&&`
+ : Bool → Bool → Bool
+ = λ(m : Bool) → λ(n : Bool) → m && n
+
+let example7 = assert : `&&` False True ≡ False
+
+let {-
+ `||` m n
+
+ computes `m || n`
+ -} `||`
+ : Bool → Bool → Bool
+ = λ(m : Bool) → λ(n : Bool) → m || n
+
+let example8 = assert : `||` False True ≡ True
+
+in { `+`, `*`, `++`, `#`, `==`, `!=`, `&&`, `||` }
diff --git a/dhall-lang/Prelude/Optional/concatMap.dhall b/dhall-lang/Prelude/Optional/concatMap.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/Prelude/Optional/concatMap.dhall
@@ -0,0 +1,23 @@
+--| Transform the value with a function and flatten the resulting `Optional`
+let concatMap
+ : ∀(a : Type) → ∀(b : Type) → (a → Optional b) → Optional a → Optional b
+ = λ(a : Type) →
+ λ(b : Type) →
+ λ(f : a → Optional b) →
+ λ(o : Optional a) →
+ merge { Some = f, None = None b } o
+
+let exampleFun
+ : Natural → Optional Natural
+ = λ(n : Natural) → if Natural/even n then Some (n + 1) else None Natural
+
+let example0 =
+ assert : concatMap Natural Natural exampleFun (Some 1) ≡ None Natural
+
+let example1 = assert : concatMap Natural Natural exampleFun (Some 2) ≡ Some 3
+
+let example2 =
+ assert
+ : concatMap Natural Natural exampleFun (None Natural) ≡ None Natural
+
+in concatMap
diff --git a/dhall-lang/Prelude/Optional/package.dhall b/dhall-lang/Prelude/Optional/package.dhall
--- a/dhall-lang/Prelude/Optional/package.dhall
+++ b/dhall-lang/Prelude/Optional/package.dhall
@@ -10,6 +10,9 @@
, concat =
./concat.dhall sha256:b7736bd3ebeab14c3912dfb534d0c970a025b001d06c2d5461d4b0e289e3cb7a
? ./concat.dhall
+, concatMap =
+ ./concatMap.dhall sha256:c06ae93e900a99299c9b4ec4912ca5395a0103ea88292205b08dd7e345632818
+ ? ./concatMap.dhall
, default =
./default.dhall sha256:5bd665b0d6605c374b3c4a7e2e2bd3b9c1e39323d41441149ed5e30d86e889ad
? ./default.dhall
diff --git a/dhall-lang/Prelude/Text/package.dhall b/dhall-lang/Prelude/Text/package.dhall
--- a/dhall-lang/Prelude/Text/package.dhall
+++ b/dhall-lang/Prelude/Text/package.dhall
@@ -16,6 +16,9 @@
, defaultMap =
./defaultMap.dhall sha256:3a3fa1264f6198800c27483cb144de2c5366484876d60b9c739a710ce0288588
? ./defaultMap.dhall
+, replace =
+ ./replace.dhall sha256:7d132df0e091a43817bba8afa06d1bb487ee51c091430404ad6f8c78bc0328a6
+ ? ./replace.dhall
, replicate =
./replicate.dhall sha256:1b398b1d464b3a6c7264a690ac3cacb443b5683b43348c859d68e7c2cb925c4f
? ./replicate.dhall
diff --git a/dhall-lang/Prelude/Text/replicate.dhall b/dhall-lang/Prelude/Text/replicate.dhall
--- a/dhall-lang/Prelude/Text/replicate.dhall
+++ b/dhall-lang/Prelude/Text/replicate.dhall
@@ -1,5 +1,4 @@
--| Build a Text by copying the given Text the specified number of times
-
let concat =
./concat.dhall sha256:731265b0288e8a905ecff95c97333ee2db614c39d69f1514cb8eed9259745fc0
? ./concat.dhall
diff --git a/dhall-lang/Prelude/Text/spaces.dhall b/dhall-lang/Prelude/Text/spaces.dhall
--- a/dhall-lang/Prelude/Text/spaces.dhall
+++ b/dhall-lang/Prelude/Text/spaces.dhall
@@ -4,7 +4,6 @@
This function is particularly helpful when trying to generate Text where
whitespace is significant, i.e. with nested indentation.
-}
-
let replicate =
./replicate.dhall sha256:1b398b1d464b3a6c7264a690ac3cacb443b5683b43348c859d68e7c2cb925c4f
? ./replicate.dhall
diff --git a/dhall-lang/Prelude/XML/Type.dhall b/dhall-lang/Prelude/XML/Type.dhall
--- a/dhall-lang/Prelude/XML/Type.dhall
+++ b/dhall-lang/Prelude/XML/Type.dhall
@@ -44,7 +44,6 @@
}
```
-}
-
let XML/Type
: Type
= ∀(XML : Type) →
diff --git a/dhall-lang/Prelude/XML/attribute.dhall b/dhall-lang/Prelude/XML/attribute.dhall
--- a/dhall-lang/Prelude/XML/attribute.dhall
+++ b/dhall-lang/Prelude/XML/attribute.dhall
@@ -1,5 +1,4 @@
--| Builds a key-value record with a Text key and value.
-
let attribute
: Text → Text → { mapKey : Text, mapValue : Text }
= λ(key : Text) → λ(value : Text) → { mapKey = key, mapValue = value }
diff --git a/dhall-lang/Prelude/XML/element.dhall b/dhall-lang/Prelude/XML/element.dhall
--- a/dhall-lang/Prelude/XML/element.dhall
+++ b/dhall-lang/Prelude/XML/element.dhall
@@ -18,8 +18,6 @@
= ""
```
-}
-
-
let XML =
./Type.dhall sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c
? ./Type.dhall
diff --git a/dhall-lang/Prelude/XML/emptyAttributes.dhall b/dhall-lang/Prelude/XML/emptyAttributes.dhall
--- a/dhall-lang/Prelude/XML/emptyAttributes.dhall
+++ b/dhall-lang/Prelude/XML/emptyAttributes.dhall
@@ -1,3 +1,2 @@
--| Create an empty XML attribute List.
-
[] : List { mapKey : Text, mapValue : Text }
diff --git a/dhall-lang/Prelude/XML/leaf.dhall b/dhall-lang/Prelude/XML/leaf.dhall
--- a/dhall-lang/Prelude/XML/leaf.dhall
+++ b/dhall-lang/Prelude/XML/leaf.dhall
@@ -9,7 +9,6 @@
= ""
```
-}
-
let XML =
./Type.dhall sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c
? ./Type.dhall
diff --git a/dhall-lang/Prelude/XML/package.dhall b/dhall-lang/Prelude/XML/package.dhall
--- a/dhall-lang/Prelude/XML/package.dhall
+++ b/dhall-lang/Prelude/XML/package.dhall
@@ -5,7 +5,7 @@
./attribute.dhall sha256:f7b6c802ca5764d03d5e9a6e48d9cb167c01392f775d9c2c87b83cdaa60ea0cc
? ./attribute.dhall
, render =
- ./render.dhall sha256:8d034f7f97cded14a96147565d489be840e5678480d175b962b2600d85a3230e
+ ./render.dhall sha256:aff7efe61ce299381edca023e24bb5aaa0656c41bfa45dd705dab63519b7c5db
? ./render.dhall
, element =
./element.dhall sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b
diff --git a/dhall-lang/Prelude/XML/render b/dhall-lang/Prelude/XML/render
--- a/dhall-lang/Prelude/XML/render
+++ b/dhall-lang/Prelude/XML/render
@@ -1,2 +1,2 @@
- ./render.dhall sha256:8d034f7f97cded14a96147565d489be840e5678480d175b962b2600d85a3230e
+ ./render.dhall sha256:aff7efe61ce299381edca023e24bb5aaa0656c41bfa45dd705dab63519b7c5db
? ./render.dhall
diff --git a/dhall-lang/Prelude/XML/render.dhall b/dhall-lang/Prelude/XML/render.dhall
--- a/dhall-lang/Prelude/XML/render.dhall
+++ b/dhall-lang/Prelude/XML/render.dhall
@@ -22,7 +22,6 @@
```
-}
-
let XML =
./Type.dhall sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c
? ./Type.dhall
@@ -35,16 +34,38 @@
../Text/concat.dhall sha256:731265b0288e8a905ecff95c97333ee2db614c39d69f1514cb8eed9259745fc0
? ../Text/concat.dhall
+let element =
+ ./element.dhall sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b
+ ? ./element.dhall
+
+let text =
+ ./text.dhall sha256:c83cd721d32d7dc28c04ce429c0cb22812639e572637ec348578a58ffb68844f
+ ? ./text.dhall
+
+let emptyAttributes =
+ ./emptyAttributes.dhall sha256:11b86e2d3f3c75d47a1d580213d2a03fd2c36d64f3e9b6381de0ba23472f64d5
+ ? ./emptyAttributes.dhall
+
let Attr = { mapKey : Text, mapValue : Text }
-let renderAttr = λ(x : Attr) → " ${x.mapKey}=\"${x.mapValue}\""
+let `escape"` = Text/replace "\"" "\\\""
+let `escape<` = Text/replace "<" "\\<"
+
+let `escape&` = Text/replace "&" "\\&"
+
+let escapeText = λ(text : Text) → `escape<` (`escape&` text)
+
+let escapeAttr = λ(text : Text) → `escape"` (`escape<` (`escape&` text))
+
+let renderAttr = λ(x : Attr) → " ${x.mapKey}=\"${escapeAttr x.mapValue}\""
+
let render
: XML → Text
= λ(x : XML) →
x
Text
- { text = λ(d : Text) → d
+ { text = escapeText
, element =
λ ( elem
: { attributes : List { mapKey : Text, mapValue : Text }
@@ -60,5 +81,51 @@
else ">${Text/concat elem.content}"
)
}
+
+let simple =
+ λ(name : Text) →
+ λ(content : List XML) →
+ element { name, attributes = emptyAttributes, content }
+
+let example0 =
+ assert
+ : render
+ ( simple
+ "note"
+ [ simple "to" [ text "Tove" ]
+ , simple "from" [ text "Jani" ]
+ , simple "heading" [ text "Reminder" ]
+ , simple "body" [ text "Don't forget me this weekend!" ]
+ ]
+ )
+ ≡ Text/replace
+ "\n"
+ ""
+ ''
+
+ Tove
+ Jani
+ Reminder
+ Don't forget me this weekend!
+
+ ''
+
+let example1 =
+ assert
+ : render
+ ( element
+ { name = "escape"
+ , attributes = toMap { attribute = "<>'\"&" }
+ , content = [ text "<>'\"&" ]
+ }
+ )
+ ≡ Text/replace
+ "\n"
+ ""
+ ''
+
+ \<>'"\&
+
+ ''
in render
diff --git a/dhall-lang/Prelude/XML/text.dhall b/dhall-lang/Prelude/XML/text.dhall
--- a/dhall-lang/Prelude/XML/text.dhall
+++ b/dhall-lang/Prelude/XML/text.dhall
@@ -14,7 +14,6 @@
= "/foo/bar"
```
-}
-
let XML =
./Type.dhall sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c
? ./Type.dhall
diff --git a/dhall-lang/Prelude/package.dhall b/dhall-lang/Prelude/package.dhall
--- a/dhall-lang/Prelude/package.dhall
+++ b/dhall-lang/Prelude/package.dhall
@@ -25,16 +25,19 @@
, Natural =
./Natural/package.dhall sha256:ee9ed2b28a417ed4e9a0c284801b928bf91b3fbdc1a68616347678c1821f1ddf
? ./Natural/package.dhall
+, Operator =
+ ./Operator/package.dhall sha256:861f724704a7b4755c96f173e54d03f314492a2d046723404c31ff612b7bf2e6
+ ? ./Operator/package.dhall
, Optional =
- ./Optional/package.dhall sha256:4324b2bf84ded40f67485f14355e4cb7b237a8f173e713c791ec44cebebc552c
+ ./Optional/package.dhall sha256:37b84d6fe94c591d603d7b06527a2d3439ba83361e9326bc7b72517c7dc54d4e
? ./Optional/package.dhall
, JSON =
- ./JSON/package.dhall sha256:79dfc281a05bc7b78f927e0da0c274ee5709b1c55c9e5f59499cb28e9d6f3ec0
+ ./JSON/package.dhall sha256:5f98b7722fd13509ef448b075e02b9ff98312ae7a406cf53ed25012dbc9990ac
? ./JSON/package.dhall
, Text =
- ./Text/package.dhall sha256:819a967038fbf6f28cc289fa2651e42835f70b326210c86e51acf48f46f913d8
+ ./Text/package.dhall sha256:46c53957c10bd4c332a5716d6e06068cd24ae1392ca171e6da31e30b9b33c07c
? ./Text/package.dhall
, XML =
- ./XML/package.dhall sha256:137e7b106b2e9743970e5d37b21a165f2e40f56ab593a4dd10605c9acd686fc6
+ ./XML/package.dhall sha256:8f57bda3087cbb34568d58e5dd5ee6860a50576caf48ebe49a5fc60b9af9a1fa
? ./XML/package.dhall
}
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractA.dhall
--- a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractA.dhall
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractA.dhall
@@ -1,4 +1,3 @@
-{- This test verifies that an implementation correctly permits both the
- "replacement" and the "haystack" to be abstract.
+{- This test verifies that an implementation works with an abstract "replacement".
-}
-λ(x : Text) → λ(y : Text) → Text/replace "a" "-${x}-" "_a_${y}_a_"
+λ(x : Text) → Text/replace "a" "-${x}-" "_a__a_"
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractB.dhall
--- a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractB.dhall
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractB.dhall
@@ -1,1 +1,1 @@
-λ(x : Text) → λ(y : Text) → "_-${x}-_${y}_-${x}-_"
+λ(x : Text) → "_-${x}-__-${x}-_"
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackA.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackA.dhall
@@ -0,0 +1,4 @@
+{- This test verifies that an implementation does not beta normalize with an
+ abstract "haystack".
+-}
+λ(x : Text) → λ(y : Text) → Text/replace "a" "-${x}-" "_a_${y}_a_"
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackB.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceAbstractHaystackB.dhall
@@ -0,0 +1,1 @@
+λ(x : Text) → λ(y : Text) → Text/replace "a" "-${x}-" "_a_${y}_a_"
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall
--- a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyA.dhall
@@ -1,1 +1,3 @@
-Text/replace "" "bar" "foo"
+λ(replacement : Text) →
+λ(haystack : Text) →
+ Text/replace "" replacement haystack
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall
--- a/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceEmptyB.dhall
@@ -1,1 +1,1 @@
-"foo"
+λ(replacement : Text) → λ(haystack : Text) → haystack
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceVarA.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceVarA.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceVarA.dhall
@@ -0,0 +1,3 @@
+{- This test verifies that an implementation works with a variable as "replacement".
+-}
+λ(x : Text) → Text/replace "a" x "aaa"
diff --git a/dhall-lang/tests/normalization/success/unit/TextReplaceVarB.dhall b/dhall-lang/tests/normalization/success/unit/TextReplaceVarB.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/normalization/success/unit/TextReplaceVarB.dhall
@@ -0,0 +1,1 @@
+λ(x : Text) → "${x}${x}${x}"
diff --git a/dhall-lang/tests/type-inference/success/preludeB.dhall b/dhall-lang/tests/type-inference/success/preludeB.dhall
--- a/dhall-lang/tests/type-inference/success/preludeB.dhall
+++ b/dhall-lang/tests/type-inference/success/preludeB.dhall
@@ -239,6 +239,22 @@
JSON
) →
Text
+ , renderCompact :
+ ∀ ( j
+ : ∀(JSON : Type) →
+ ∀ ( json
+ : { array : List JSON → JSON
+ , bool : Bool → JSON
+ , double : Double → JSON
+ , integer : Integer → JSON
+ , null : JSON
+ , object : List { mapKey : Text, mapValue : JSON } → JSON
+ , string : Text → JSON
+ }
+ ) →
+ JSON
+ ) →
+ Text
, renderInteger : ∀(integer : Integer) → Text
, renderYAML :
∀ ( json
@@ -408,6 +424,16 @@
, toDouble : ∀(n : Natural) → Double
, toInteger : Natural → Integer
}
+, Operator :
+ { `!=` : ∀(m : Bool) → ∀(n : Bool) → Bool
+ , `#` : ∀(type : Type) → ∀(m : List type) → ∀(n : List type) → List type
+ , `&&` : ∀(m : Bool) → ∀(n : Bool) → Bool
+ , `*` : ∀(m : Natural) → ∀(n : Natural) → Natural
+ , `+` : ∀(m : Natural) → ∀(n : Natural) → Natural
+ , `++` : ∀(m : Text) → ∀(n : Text) → Text
+ , `==` : ∀(m : Bool) → ∀(n : Bool) → Bool
+ , `||` : ∀(m : Bool) → ∀(n : Bool) → Bool
+ }
, Optional :
{ all : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool
, any : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool
@@ -421,6 +447,12 @@
) →
Optional a
, concat : ∀(a : Type) → ∀(x : Optional (Optional a)) → Optional a
+ , concatMap :
+ ∀(a : Type) →
+ ∀(b : Type) →
+ ∀(f : a → Optional b) →
+ ∀(o : Optional a) →
+ Optional b
, default : ∀(a : Type) → ∀(default : a) → ∀(o : Optional a) → a
, filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Optional a
, fold :
@@ -459,6 +491,8 @@
, concatSep : ∀(separator : Text) → ∀(elements : List Text) → Text
, default : ∀(o : Optional Text) → Text
, defaultMap : ∀(a : Type) → ∀(f : a → Text) → ∀(o : Optional a) → Text
+ , replace :
+ ∀(needle : Text) → ∀(replacement : Text) → ∀(haystack : Text) → Text
, replicate : ∀(num : Natural) → ∀(text : Text) → Text
, show : Text → Text
, spaces : ∀(a : Natural) → Text
diff --git a/dhall-lang/tests/type-inference/success/unit/IfBranchesKindA.dhall b/dhall-lang/tests/type-inference/success/unit/IfBranchesKindA.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/type-inference/success/unit/IfBranchesKindA.dhall
@@ -0,0 +1,1 @@
+if True then (Type -> Type) else Type
diff --git a/dhall-lang/tests/type-inference/success/unit/IfBranchesKindB.dhall b/dhall-lang/tests/type-inference/success/unit/IfBranchesKindB.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/type-inference/success/unit/IfBranchesKindB.dhall
@@ -0,0 +1,1 @@
+Kind
diff --git a/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeA.dhall b/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeA.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeA.dhall
@@ -0,0 +1,1 @@
+if True then Bool else Natural
diff --git a/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeB.dhall b/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeB.dhall
new file mode 100644
--- /dev/null
+++ b/dhall-lang/tests/type-inference/success/unit/IfBranchesTypeB.dhall
@@ -0,0 +1,1 @@
+Type
diff --git a/dhall.cabal b/dhall.cabal
--- a/dhall.cabal
+++ b/dhall.cabal
@@ -1,5 +1,5 @@
Name: dhall
-Version: 1.36.0
+Version: 1.37.0
Cabal-Version: >=1.10
Build-Type: Simple
Tested-With: GHC == 8.4.3, GHC == 8.6.1
@@ -85,6 +85,7 @@
dhall-lang/Prelude/JSON/package.dhall
dhall-lang/Prelude/JSON/render
dhall-lang/Prelude/JSON/renderAs
+ dhall-lang/Prelude/JSON/renderCompact.dhall
dhall-lang/Prelude/JSON/renderInteger.dhall
dhall-lang/Prelude/JSON/renderYAML
dhall-lang/Prelude/JSON/string
@@ -158,6 +159,7 @@
dhall-lang/Prelude/Natural/toDouble
dhall-lang/Prelude/Natural/toInteger
dhall-lang/Prelude/Natural/*.dhall
+ dhall-lang/Prelude/Operator/package.dhall
dhall-lang/Prelude/Optional/all
dhall-lang/Prelude/Optional/any
dhall-lang/Prelude/Optional/build
@@ -181,6 +183,7 @@
dhall-lang/Prelude/Text/default
dhall-lang/Prelude/Text/defaultMap
dhall-lang/Prelude/Text/package.dhall
+ dhall-lang/Prelude/Text/replace.dhall
dhall-lang/Prelude/Text/replicate
dhall-lang/Prelude/Text/show
dhall-lang/Prelude/Text/spaces
@@ -509,7 +512,7 @@
scientific >= 0.3.0.0 && < 0.4 ,
template-haskell >= 2.13.0.0 && < 2.17,
text >= 0.11.1.0 && < 1.3 ,
- text-manipulate >= 0.2.0.1 && < 0.3 ,
+ text-manipulate >= 0.2.0.1 && < 0.4 ,
th-lift-instances >= 0.1.13 && < 0.2 ,
transformers >= 0.2.0.0 && < 0.6 ,
transformers-compat >= 0.6.2 && < 0.7 ,
diff --git a/doctest/Main.hs b/doctest/Main.hs
--- a/doctest/Main.hs
+++ b/doctest/Main.hs
@@ -6,6 +6,7 @@
import qualified GHC.IO.Encoding
import qualified System.Directory
+import qualified System.Environment
import qualified System.IO
import qualified Test.DocTest
import qualified Test.Mockery.Directory
@@ -16,6 +17,8 @@
GHC.IO.Encoding.setLocaleEncoding System.IO.utf8
pwd <- System.Directory.getCurrentDirectory
prefix <- System.Directory.makeAbsolute pwd
+
+ System.Environment.setEnv "XDG_CACHE_HOME" (pwd ".cache")
Test.Mockery.Directory.inTempDirectory $ do
writeFile "makeBools.dhall" "λ(n : Bool) → [ n && True, n && False, n || True, n || False ]"
diff --git a/ghc-src/Dhall/Import/HTTP.hs b/ghc-src/Dhall/Import/HTTP.hs
--- a/ghc-src/Dhall/Import/HTTP.hs
+++ b/ghc-src/Dhall/Import/HTTP.hs
@@ -65,6 +65,11 @@
<> "\ESC[1;31mError\ESC[0m: The remote host took too long to respond\n"
<> "\n"
<> "URL: " <> url <> "\n"
+ ConnectionTimeout ->
+ "\n"
+ <> "\ESC[1;31mError\ESC[0m: Connection establishment took too long\n"
+ <> "\n"
+ <> "URL: " <> url <> "\n"
StatusCodeException response body -> prefix <> suffix
where
prefix
@@ -141,7 +146,10 @@
prefixedText = Text.unlines prefixedLines
- e' -> "\n" <> show e' <> "\n"
+ e' -> "\n"
+ <> "\ESC[1;31mError\ESC[0m: " <> show e'
+ <> "\n"
+ <> "URL: " <> url <> "\n"
newManager :: StateT Status IO Manager
newManager = do
diff --git a/src/Dhall.hs b/src/Dhall.hs
--- a/src/Dhall.hs
+++ b/src/Dhall.hs
@@ -1326,11 +1326,9 @@
:: (Generic a, GenericFromDhall a (Rep a)) => InputNormalizer -> Decoder a
autoWith _ = genericAuto
-{-| A compatibility alias for `FromDhall`
-
-This will eventually be removed.
--}
+-- | A compatibility alias for `FromDhall`
type Interpret = FromDhall
+{-# DEPRECATED Interpret "Use FromDhall instead" #-}
instance FromDhall Void where
autoWith _ = void
@@ -1967,11 +1965,9 @@
:: (Generic a, GenericToDhall (Rep a)) => InputNormalizer -> Encoder a
injectWith _ = genericToDhall
-{-| A compatibility alias for `ToDhall`
-
-This will eventually be removed.
--}
+-- | A compatibility alias for `ToDhall`
type Inject = ToDhall
+{-# DEPRECATED Inject "Use ToDhall instead" #-}
{-| Use the default input normalizer for injecting a value
diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs
--- a/src/Dhall/Binary.hs
+++ b/src/Dhall/Binary.hs
@@ -73,7 +73,6 @@
import qualified Data.Sequence
import qualified Dhall.Crypto
import qualified Dhall.Map
-import qualified Dhall.Set
import qualified Dhall.Syntax as Syntax
import qualified Text.Printf as Printf
@@ -415,7 +414,7 @@
TypeString -> do
x <- Decoding.decodeString
- return (Left (Dhall.Set.fromList [x]))
+ return (Left [x])
_ ->
die ("Unexpected token type for projection: " <> show tokenType₂)
@@ -423,7 +422,7 @@
_ -> do
xs <- replicateDecoder (len - 2) Decoding.decodeString
- return (Left (Dhall.Set.fromList xs))
+ return (Left xs)
return (Project t xs)
@@ -852,10 +851,10 @@
Project t (Left xs) ->
encodeListN
- (2 + Dhall.Set.size xs)
+ (2 + length xs)
( Encoding.encodeInt 10
: go t
- : map Encoding.encodeString (Dhall.Set.toList xs)
+ : map Encoding.encodeString xs
)
Project t (Right _T) ->
diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs
--- a/src/Dhall/Diff.hs
+++ b/src/Dhall/Diff.hs
@@ -26,7 +26,6 @@
import Data.Void (Void)
import Dhall.Map (Map)
import Dhall.Pretty.Internal (Ann)
-import Dhall.Set (Set)
import Dhall.Syntax
( Binding (..)
, Chunks (..)
@@ -47,7 +46,6 @@
import qualified Dhall.Map
import qualified Dhall.Normalize as Normalize
import qualified Dhall.Pretty.Internal as Internal
-import qualified Dhall.Set
import qualified Dhall.Syntax as Syntax
{-| This type is a `Doc` enriched with a `same` flag to efficiently track if
@@ -174,20 +172,21 @@
diffLabel :: Text -> Text -> Diff
diffLabel = diffPrimitive (token . Internal.prettyLabel)
-diffLabels :: Set Text -> Set Text -> Diff
+diffLabels :: [Text] -> [Text] -> Diff
diffLabels ksL ksR =
braced (diffFieldNames <> (if anyEqual then [ ignore ] else []))
where
- extraL = Dhall.Set.difference ksL ksR
- extraR = Dhall.Set.difference ksR ksL
+ setL = Data.Set.fromList ksL
+ setR = Data.Set.fromList ksR
+ extraL = Data.Set.difference setL setR
+ extraR = Data.Set.difference setR setL
+
diffFieldNames = foldMap (adapt minus) extraL <> foldMap (adapt plus) extraR
where
adapt sign key = [ sign (token (Internal.prettyLabel key)) ]
- anyEqual = not (Data.Set.null (Data.Set.intersection
- (Dhall.Set.toSet ksL)
- (Dhall.Set.toSet ksR)))
+ anyEqual = not (Data.Set.null (Data.Set.intersection setL setR))
diffNatural :: Natural -> Natural -> Diff
diffNatural = diffPrimitive (token . Internal.prettyNatural)
diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs
--- a/src/Dhall/Eval.hs
+++ b/src/Dhall/Eval.hs
@@ -50,6 +50,7 @@
, textShow
) where
+import Data.Bifunctor (first)
import Data.Foldable (foldr', toList)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Sequence (Seq, ViewL (..), ViewR (..))
@@ -363,16 +364,15 @@
singletonVRecordLit v = VRecordLit (Map.singleton k v)
{-# INLINE vField #-}
-vTextReplaceSlow :: Text -> Val a -> VChunks a -> VChunks a
-vTextReplaceSlow needle replacement haystack = go haystack
+vTextReplace :: Text -> Val a -> Text -> VChunks a
+vTextReplace needle replacement haystack = go haystack
where
- go (VChunks [] lastText) =
- if Text.null suffix
- then VChunks [] lastText
- else
+ go t
+ | Text.null suffix = VChunks [] t
+ | otherwise =
let remainder = Text.drop (Text.length needle) suffix
- rest = go (VChunks [] remainder)
+ rest = go remainder
in case replacement of
VTextLit replacementChunks ->
@@ -380,36 +380,7 @@
_ ->
VChunks [(prefix, replacement)] "" <> rest
where
- (prefix, suffix) = Text.breakOn needle lastText
- go (VChunks ((firstText, firstInterpolation) : chunks) lastText) =
- if Text.null suffix
- then
- let rest = go (VChunks chunks lastText)
-
- in VChunks [(firstText, firstInterpolation)] "" <> rest
- else
- let remainder = Text.drop (Text.length needle) suffix
-
- rest =
- go (VChunks ((remainder, firstInterpolation) : chunks) lastText)
-
- in case replacement of
- VTextLit replacementChunks ->
- VChunks [] prefix <> replacementChunks <> rest
- _ ->
- VChunks [(prefix, replacement)] "" <> rest
- where
- (prefix, suffix) = Text.breakOn needle firstText
-
-vTextReplaceFast :: Text -> Text -> VChunks a -> VChunks a
-vTextReplaceFast needle replacement (VChunks xys z) = VChunks xys' z'
- where
- xys' = do
- (x, y) <- xys
-
- return (Text.replace needle replacement x, y)
-
- z' = Text.replace needle replacement z
+ (prefix, suffix) = Text.breakOn needle t
vProjectByFields :: Eq a => Environment a -> Val a -> Set Text -> Val a
vProjectByFields env t ks =
@@ -633,26 +604,26 @@
VPrim $ \needle ->
VPrim $ \replacement ->
VPrim $ \haystack ->
- case haystack of
- VTextLit haystackChunks ->
- case needle of
- VTextLit (VChunks [] "") ->
- haystack
- VTextLit (VChunks [] needleText) ->
+ case needle of
+ VTextLit (VChunks [] "") ->
+ haystack
+ VTextLit (VChunks [] needleText) ->
+ case haystack of
+ VTextLit (VChunks [] haystackText) ->
case replacement of
VTextLit (VChunks [] replacementText) ->
- VTextLit
- (vTextReplaceFast
+ VTextLit $ VChunks []
+ (Text.replace
needleText
replacementText
- haystackChunks
+ haystackText
)
_ ->
VTextLit
- (vTextReplaceSlow
+ (vTextReplace
needleText
replacement
- haystackChunks
+ haystackText
)
_ ->
VTextReplace needle replacement haystack
@@ -806,11 +777,11 @@
Field t (Syntax.fieldSelectionLabel -> k) ->
vField (eval env t) k
Project t (Left ks) ->
- vProjectByFields env (eval env t) (Dhall.Set.sort ks)
+ vProjectByFields env (eval env t) (Dhall.Set.sort (Dhall.Set.fromList ks))
Project t (Right e) ->
case eval env e of
VRecord kts ->
- eval env (Project t (Left (Dhall.Set.fromSet (Map.keysSet kts))))
+ vProjectByFields env (eval env t) (Dhall.Set.fromSet (Map.keysSet kts))
e' ->
VProject (eval env t) (Right e')
Assert t ->
@@ -1209,7 +1180,7 @@
VField t k ->
Field (quote env t) $ Syntax.makeFieldSelection k
VProject t p ->
- Project (quote env t) (fmap (quote env) p)
+ Project (quote env t) (first Dhall.Set.toList (fmap (quote env) p))
VAssert t ->
Assert (quote env t)
VEquivalent t u ->
diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs
--- a/src/Dhall/Import.hs
+++ b/src/Dhall/Import.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@@ -111,10 +112,10 @@
, hashExpression
, hashExpressionToCode
, writeExpressionToSemanticCache
- , warnAboutMissingCaches
, assertNoImports
, Manager
, defaultNewManager
+ , CacheWarning(..)
, Status(..)
, SemanticCacheMode(..)
, Chained
@@ -154,12 +155,10 @@
, SomeException
, toException
)
-import Control.Monad (when)
import Control.Monad.Catch (MonadCatch (catch), handle, throwM)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Morph (hoist)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State.Strict (StateT)
+import Control.Monad.State.Strict (MonadState, StateT)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.List.NonEmpty (NonEmpty (..))
@@ -202,8 +201,8 @@
import qualified Codec.CBOR.Encoding as Encoding
import qualified Codec.CBOR.Write as Write
import qualified Codec.Serialise
+import qualified Control.Monad.State.Strict as State
import qualified Control.Monad.Trans.Maybe as Maybe
-import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.CaseInsensitive
@@ -536,8 +535,10 @@
Status { .. } <- State.get
mCached <-
case _semanticCacheMode of
- UseSemanticCache -> liftIO $ fetchFromSemanticCache semanticHash
- IgnoreSemanticCache -> pure Nothing
+ UseSemanticCache ->
+ zoom cacheWarning (fetchFromSemanticCache semanticHash)
+ IgnoreSemanticCache ->
+ pure Nothing
case mCached of
Just bytesStrict -> do
@@ -568,7 +569,7 @@
let variants = map (\version -> encodeExpression version (Core.alphaNormalize importSemantics))
[ minBound .. maxBound ]
case Data.Foldable.find ((== semanticHash). Dhall.Crypto.sha256Hash) variants of
- Just bytes -> liftIO $ writeToSemanticCache semanticHash bytes
+ Just bytes -> zoom cacheWarning (writeToSemanticCache semanticHash bytes)
Nothing -> do
let expectedHash = semanticHash
Status { _stack } <- State.get
@@ -580,7 +581,10 @@
-- Fetch encoded normal form from "semantic cache"
-fetchFromSemanticCache :: Dhall.Crypto.SHA256Digest -> IO (Maybe Data.ByteString.ByteString)
+fetchFromSemanticCache
+ :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
+ => Dhall.Crypto.SHA256Digest
+ -> m (Maybe Data.ByteString.ByteString)
fetchFromSemanticCache expectedHash = Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall" expectedHash
True <- liftIO (Directory.doesFileExist cacheFile)
@@ -589,12 +593,19 @@
-- | Ensure that the given expression is present in the semantic cache. The
-- given expression should be alpha-beta-normal.
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
-writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes
+writeExpressionToSemanticCache expression =
+ -- Defaulting to not displaying the warning is for backwards compatibility
+ -- with the old behavior
+ State.evalStateT (writeToSemanticCache hash bytes) CacheWarned
where
bytes = encodeExpression NoVersion expression
hash = Dhall.Crypto.sha256Hash bytes
-writeToSemanticCache :: Dhall.Crypto.SHA256Digest -> Data.ByteString.ByteString -> IO ()
+writeToSemanticCache
+ :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
+ => Dhall.Crypto.SHA256Digest
+ -> Data.ByteString.ByteString
+ -> m ()
writeToSemanticCache hash bytes = do
_ <- Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall" hash
@@ -637,8 +648,9 @@
-- https://github.com/dhall-lang/dhall-haskell/issues/1098 for the reasoning
-- behind semi-semantic caching.
let semisemanticHash = computeSemisemanticHash (Core.denote resolvedExpr)
- mCached <- lift $ fetchFromSemisemanticCache semisemanticHash
+ mCached <- zoom cacheWarning (fetchFromSemisemanticCache semisemanticHash)
+
importSemantics <- case mCached of
Just bytesStrict -> do
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
@@ -670,7 +682,7 @@
let bytes = encodeExpression NoVersion betaNormal
- lift (writeToSemisemanticCache semisemanticHash bytes)
+ zoom cacheWarning (writeToSemisemanticCache semisemanticHash bytes)
return betaNormal
@@ -718,13 +730,20 @@
computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr
-- Fetch encoded normal form from "semi-semantic cache"
-fetchFromSemisemanticCache :: Dhall.Crypto.SHA256Digest -> IO (Maybe Data.ByteString.ByteString)
+fetchFromSemisemanticCache
+ :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
+ => Dhall.Crypto.SHA256Digest
+ -> m (Maybe Data.ByteString.ByteString)
fetchFromSemisemanticCache semisemanticHash = Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall-haskell" semisemanticHash
True <- liftIO (Directory.doesFileExist cacheFile)
liftIO (Data.ByteString.readFile cacheFile)
-writeToSemisemanticCache :: Dhall.Crypto.SHA256Digest -> Data.ByteString.ByteString -> IO ()
+writeToSemisemanticCache
+ :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
+ => Dhall.Crypto.SHA256Digest
+ -> Data.ByteString.ByteString
+ -> m ()
writeToSemisemanticCache semisemanticHash bytes = do
_ <- Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall-haskell" semisemanticHash
@@ -799,24 +818,28 @@
empty
getCacheFile
- :: (MonadCatch m, Alternative m, MonadIO m) => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
+ :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
+ => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
getCacheFile cacheName hash = do
- cacheDirectory <- getOrCreateCacheDirectory False cacheName
+ cacheDirectory <- getOrCreateCacheDirectory cacheName
let cacheFile = cacheDirectory ("1220" <> show hash)
return cacheFile
--- | Warn if no cache directory is available
-warnAboutMissingCaches :: (MonadCatch m, Alternative m, MonadIO m) => m ()
-warnAboutMissingCaches = warn <|> return ()
- where warn = Data.Foldable.traverse_ (getOrCreateCacheDirectory True) ["dhall", "dhall-haskell"]
-
-getOrCreateCacheDirectory :: (MonadCatch m, Alternative m, MonadIO m) => Bool -> FilePath -> m FilePath
-getOrCreateCacheDirectory showWarning cacheName = do
+getOrCreateCacheDirectory
+ :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
+ => FilePath -> m FilePath
+getOrCreateCacheDirectory cacheName = do
let warn message = do
- when showWarning (printWarning message)
+ cacheWarningStatus <- State.get
+ case cacheWarningStatus of
+ CacheWarned -> printWarning message
+ CacheNotWarned -> return ()
+
+ State.put CacheWarned
+
empty
let handler action dir (ioex :: IOException) = do
@@ -857,14 +880,19 @@
then
return ()
else do
+ let render f = if f permissions then "✓" else "✗"
let message =
"The directory:\n"
<> "\n"
<> "↳ " <> dir <> "\n"
<> "\n"
<> "... does not give you permission to read, write, or search files.\n\n"
+ <> "\n"
<> "The directory's current permissions are:\n"
- <> show permissions <> "\n"
+ <> "\n"
+ <> "• " <> render Directory.readable <> " readable\n"
+ <> "• " <> render Directory.writable <> " writable\n"
+ <> "• " <> render Directory.searchable <> " searchable\n"
warn message
@@ -908,7 +936,7 @@
setPermissions dir
- cacheBaseDirectory <- getCacheBaseDirectory showWarning
+ cacheBaseDirectory <- getCacheBaseDirectory
let directory = cacheBaseDirectory cacheName
@@ -926,8 +954,9 @@
return directory
-getCacheBaseDirectory :: (Alternative m, MonadIO m) => Bool -> m FilePath
-getCacheBaseDirectory showWarning = alternative₀ <|> alternative₁ <|> alternative₂
+getCacheBaseDirectory
+ :: (MonadState CacheWarning m, Alternative m, MonadIO m) => m FilePath
+getCacheBaseDirectory = alternative₀ <|> alternative₁ <|> alternative₂
where
alternative₀ = do
maybeXDGCacheHome <-
@@ -957,6 +986,8 @@
where isWindows = System.Info.os == "mingw32"
alternative₂ = do
+ cacheWarningStatus <- State.get
+
let message =
"\n"
<> "\ESC[1;33mWarning\ESC[0m: "
@@ -965,7 +996,13 @@
<> "You can provide a cache base directory by pointing the $XDG_CACHE_HOME\n"
<> "environment variable to a directory with read and write permissions.\n"
- when showWarning (liftIO (System.IO.hPutStrLn System.IO.stderr message))
+ case cacheWarningStatus of
+ CacheNotWarned ->
+ liftIO (System.IO.hPutStrLn System.IO.stderr message)
+ CacheWarned ->
+ return ()
+
+ State.put CacheWarned
empty
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
@@ -84,6 +84,10 @@
pure ()
#endif
+{-| Used internally to track whether or not we've already warned the user about
+ caching issues
+-}
+data CacheWarning = CacheNotWarned | CacheWarned
-- | State threaded throughout the import process
data Status = Status
@@ -114,6 +118,10 @@
, _startingContext :: Context (Expr Src Void)
, _semanticCacheMode :: SemanticCacheMode
+
+ , _cacheWarning :: CacheWarning
+ -- ^ Records whether or not we already warned the user about issues with
+ -- cache directory
}
-- | Initial `Status`, parameterised over the HTTP 'Manager' and the remote resolver,
@@ -137,6 +145,8 @@
_semanticCacheMode = UseSemanticCache
+ _cacheWarning = CacheNotWarned
+
prefix = if isRelative rootDirectory
then Here
else Absolute
@@ -173,8 +183,7 @@
-- | Lens from a `Status` to its `_substitutions` field
substitutions :: Functor f => LensLike' f Status (Dhall.Substitution.Substitutions Src Void)
-substitutions k s =
- fmap (\x -> s { _substitutions = x }) (k (_substitutions s))
+substitutions k s = fmap (\x -> s { _substitutions = x }) (k (_substitutions s))
-- | Lens from a `Status` to its `_normalizer` field
normalizer :: Functor f => LensLike' f Status (Maybe (ReifiedNormalizer Void))
@@ -184,6 +193,10 @@
startingContext :: Functor f => LensLike' f Status (Context (Expr Src Void))
startingContext k s =
fmap (\x -> s { _startingContext = x }) (k (_startingContext s))
+
+-- | Lens from a `Status` to its `_cacheWarning` field
+cacheWarning :: Functor f => LensLike' f Status CacheWarning
+cacheWarning k s = fmap (\x -> s { _cacheWarning = x }) (k (_cacheWarning s))
{-| This exception indicates that there was an internal error in Dhall's
import-related logic
diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs
--- a/src/Dhall/Main.hs
+++ b/src/Dhall/Main.hs
@@ -23,7 +23,6 @@
import Control.Applicative (optional, (<|>))
import Control.Exception (Handler (..), SomeException)
-import Control.Monad (when)
import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
@@ -120,12 +119,6 @@
, censor :: Censor
}
-ignoreSemanticCache :: Mode -> Bool
-ignoreSemanticCache Default {..} = semanticCacheMode == IgnoreSemanticCache
-ignoreSemanticCache Resolve {..} = semanticCacheMode == IgnoreSemanticCache
-ignoreSemanticCache Type {..} = semanticCacheMode == IgnoreSemanticCache
-ignoreSemanticCache _ = False
-
-- | The subcommands for the @dhall@ executable
data Mode
= Default
@@ -151,7 +144,7 @@
| Repl
| Format { possiblyTransitiveInput :: PossiblyTransitiveInput, outputMode :: OutputMode }
| Freeze { possiblyTransitiveInput :: PossiblyTransitiveInput, all_ :: Bool, cache :: Bool, outputMode :: OutputMode }
- | Hash { file :: Input }
+ | Hash { file :: Input, cache :: Bool }
| Diff { expr1 :: Text, expr2 :: Text }
| Lint { possiblyTransitiveInput :: PossiblyTransitiveInput, outputMode :: OutputMode }
| Tags
@@ -300,7 +293,7 @@
Miscellaneous
"hash"
"Compute semantic hashes for Dhall expressions"
- (Hash <$> parseFile)
+ (Hash <$> parseFile <*> parseCache)
<|> subcommand
Miscellaneous
"tags"
@@ -524,6 +517,12 @@
<> Options.Applicative.help "Print `Note` constructors"
)
+ parseCache =
+ Options.Applicative.switch
+ ( Options.Applicative.long "cache"
+ <> Options.Applicative.help "Cache the hashed expression"
+ )
+
-- | `ParserInfo` for the `Options` type
parserInfoOptions :: ParserInfo Options
parserInfoOptions =
@@ -625,8 +624,6 @@
AtomicWrite.LazyText.atomicWriteFile file (Pretty.Text.renderLazy stream)
- when (not $ ignoreSemanticCache mode) Dhall.Import.warnAboutMissingCaches
-
handle $ case mode of
Version ->
putStrLn dhallVersionString
@@ -789,6 +786,10 @@
let normalizedExpression =
Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression)
+
+ if cache
+ then Dhall.Import.writeExpressionToSemanticCache normalizedExpression
+ else return ()
Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression)
diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs
--- a/src/Dhall/Normalize.hs
+++ b/src/Dhall/Normalize.hs
@@ -46,7 +46,6 @@
import qualified Data.Text as Text
import qualified Dhall.Eval as Eval
import qualified Dhall.Map
-import qualified Dhall.Set
import qualified Dhall.Syntax as Syntax
import qualified Lens.Family as Lens
@@ -642,7 +641,7 @@
_ -> pure (Field r' k)
Project x (Left fields)-> do
x' <- loop x
- let fieldsSet = Dhall.Set.toSet fields
+ let fieldsSet = Data.Set.fromList fields
case x' of
RecordLit kvs ->
pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet))
@@ -650,17 +649,17 @@
loop (Project y (Left fields))
Prefer _ l (RecordLit rKvs) -> do
let rKs = Dhall.Map.keysSet rKvs
- let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs)))
+ let l' = Project l (Left (Data.Set.toList (Data.Set.difference fieldsSet rKs)))
let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet)
loop (Prefer PreferFromSource l' r')
_ | null fields -> pure (RecordLit mempty)
- | otherwise -> pure (Project x' (Left (Dhall.Set.sort fields)))
+ | otherwise -> pure (Project x' (Left (Data.Set.toList (Data.Set.fromList fields))))
Project r (Right e1) -> do
e2 <- loop e1
case e2 of
Record kts ->
- loop (Project r (Left (Dhall.Set.fromSet (Dhall.Map.keysSet kts))))
+ loop (Project r (Left (Data.Set.toList (Dhall.Map.keysSet kts))))
_ -> do
r' <- loop r
pure (Project r' (Right e2))
@@ -912,7 +911,7 @@
RecordLit _ -> False
Project _ _ -> False
Prefer _ _ (RecordLit _) -> False
- _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s
+ _ -> not (null s) && Data.Set.toList (Data.Set.fromList s) == s
Right e' -> case e' of
Record _ -> False
_ -> loop e'
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
@@ -17,7 +17,6 @@
, satisfy
, Dhall.Parser.Combinators.takeWhile
, takeWhile1
- , noDuplicates
, toMap
, toMapWith
) where
@@ -31,19 +30,16 @@
import Data.Text.Prettyprint.Doc (Pretty (..))
import Data.Void (Void)
import Dhall.Map (Map)
-import Dhall.Set (Set)
import Dhall.Src (Src (..))
import Text.Parser.Combinators (try, ())
import Text.Parser.Token (TokenParsing (..))
import qualified Control.Monad.Fail
import qualified Data.Char
-import qualified Data.Set
import qualified Data.Text
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
import qualified Dhall.Map
import qualified Dhall.Pretty
-import qualified Dhall.Set
import qualified Text.Megaparsec
import qualified Text.Megaparsec.Char
import qualified Text.Parser.Char
@@ -263,16 +259,6 @@
-- that match the given predicate. It fails when no character was consumed
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 predicate = Parser (Text.Megaparsec.takeWhile1P Nothing predicate)
-
--- | Construct a 'Set a' from a '[a]', failing if there was a duplicate element
-noDuplicates :: Ord a => [a] -> Parser (Set a)
-noDuplicates = go Dhall.Set.empty
- where
- go found [] = return found
- go found (x:xs) =
- if Data.Set.member x (Dhall.Set.toSet found)
- then fail "Duplicate key"
- else go (Dhall.Set.append x found) xs
-- | Creates a map with the given key-value pairs, failing if there was a
-- duplicate key.
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
@@ -437,29 +437,36 @@
selectorExpression = noted (do
a <- primitiveExpression
- let recordType = whitespace *> _openParens *> whitespace *> expression <* whitespace <* _closeParens
+ let recordType = _openParens *> whitespace *> expression <* whitespace <* _closeParens
let field x e = Field e x
let projectBySet xs e = Project e (Left xs)
let projectByExpression xs e = Project e (Right xs)
- let fieldSelection = do
+ let alternatives = do
src0 <- src whitespace
- l <- anyLabel
- pos <- Text.Megaparsec.getSourcePos
- -- FIXME: Suffix whitespace can't be parsed given our limitation
- -- about whitespace treatment, but for @dhall-docs@ this
- -- is enough
- let src1 = Src pos pos ""
- return (FieldSelection (Just src0) l (Just src1))
+ let fieldSelection = do
+ l <- anyLabel
- let alternatives =
- fmap field fieldSelection
- <|> fmap projectBySet (whitespace *> labels)
- <|> fmap projectByExpression recordType
+ pos <- Text.Megaparsec.getSourcePos
+ -- FIXME: Suffix whitespace can't be parsed given our limitation
+ -- about whitespace treatment, but for @dhall-docs@ this
+ -- is enough
+ let src1 = Src pos pos ""
+
+ return (FieldSelection (Just src0) l (Just src1))
+
+ let result =
+ fmap field fieldSelection
+ <|> fmap projectBySet labels
+ <|> fmap projectByExpression recordType
+
+ result
+
b <- Text.Megaparsec.many (try (whitespace *> _dot *> alternatives))
+
return (foldl' (\e k -> k e) a b) )
primitiveExpression =
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
@@ -116,7 +116,6 @@
import Data.Bits ((.&.))
import Data.Functor (void, ($>))
import Data.Text (Text)
-import Dhall.Set (Set)
import Dhall.Syntax
import Text.Parser.Combinators (choice, try, ())
@@ -128,7 +127,6 @@
import qualified Data.List.NonEmpty
import qualified Data.Scientific as Scientific
import qualified Data.Text
-import qualified Dhall.Set
import qualified Text.Megaparsec
import qualified Text.Megaparsec.Char.Lexer
import qualified Text.Parser.Char
@@ -443,22 +441,18 @@
This corresponds to the @labels@ rule in the official grammar
-}
-labels :: Parser (Set Text)
+labels :: Parser [Text]
labels = do
_openBrace
whitespace
- xs <- nonEmptyLabels <|> emptyLabels
-
- _ <- optional (_comma *> whitespace)
-
- return xs
+ nonEmptyLabels <|> emptyLabels
where
emptyLabels = do
try (optional (_comma *> whitespace) *> _closeBrace)
- pure Dhall.Set.empty
+ pure []
nonEmptyLabels = do
x <- try (optional (_comma *> whitespace) *> anyLabelOrSome)
@@ -471,7 +465,7 @@
_closeBrace
- noDuplicates (x : xs)
+ return (x : xs)
{-| Parse a label (e.g. a variable\/field\/alternative name)
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
@@ -70,7 +70,6 @@
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
import Dhall.Map (Map)
-import Dhall.Set (Set)
import Dhall.Src (Src (..))
import Dhall.Syntax
import Numeric.Natural (Natural)
@@ -80,14 +79,12 @@
import qualified Data.List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe
-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.String as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Dhall.Map as Map
-import qualified Dhall.Set
{-| Annotation type used to tag elements in a pretty-printed document for
syntax highlighting purposes
@@ -509,12 +506,10 @@
, renderSrcMaybe mSrc1
]
-prettyLabels :: Set Text -> Doc Ann
+prettyLabels :: [Text] -> Doc Ann
prettyLabels a
- | Data.Set.null (Dhall.Set.toSet a) =
- lbrace <> rbrace
- | otherwise =
- braces (map (duplicate . prettyAnyLabel) (Dhall.Set.toList a))
+ | null a = lbrace <> rbrace
+ | otherwise = braces (map (duplicate . prettyAnyLabel) a)
prettyNumber :: Integer -> Doc Ann
prettyNumber = literal . Pretty.pretty
@@ -697,7 +692,12 @@
where
MultiLet as b = multiLet a0 b0
- stripSpaces = Text.dropAround (\c -> c == ' ' || c == '\t')
+ isSpace c = c == ' ' || c == '\t'
+ stripSpaces =
+ Text.dropAround isSpace
+ . Text.intercalate "\n"
+ . map (Text.dropWhileEnd isSpace)
+ . Text.splitOn "\n"
-- Strip a single newline character. Needed to ensure idempotency in
-- cases where we add hard line breaks.
@@ -1497,7 +1497,7 @@
prettyMultilineText text = mconcat docs
where
- lines_ = Text.splitOn "\n" (escapeSingleQuotedText text)
+ lines_ = Text.splitOn "\n" text
-- Annotate only non-empty lines so trailing whitespace can be
-- removed on empty ones.
@@ -1526,8 +1526,10 @@
-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t"
multilineChunks :: Chunks s a -> Chunks s a
multilineChunks =
- escapeTrailingSingleQuote
+ escapeSingleQuotedText
+ . escapeTrailingSingleQuote
. escapeControlCharacters
+ . escapeSingleQuoteBeforeInterpolation
. escapeSharedWhitespacePrefix
-- | Escape any leading whitespace shared by all lines
@@ -1574,38 +1576,68 @@
-- >>> escapeControlCharacters (Chunks [] "\n\NUL\b\f\t")
-- Chunks [("\n",TextLit (Chunks [] "\NUL\b\f"))] "\t"
escapeControlCharacters :: Chunks s a -> Chunks s a
-escapeControlCharacters (Chunks as0 b0) = Chunks as1 b1
+escapeControlCharacters = splitWith (splitOnPredicate predicate)
where
- as1 = foldr f (map toChunk bs) as0
+ predicate c = Data.Char.isControl c && c /= ' ' && c /= '\t' && c /= '\n'
- (bs, b1) = splitOnPredicate predicate b0
+-- | Escape @'${@ correctly
+--
+-- See: https://github.com/dhall-lang/dhall-haskell/issues/2078
+escapeSingleQuoteBeforeInterpolation :: Chunks s a -> Chunks s a
+escapeSingleQuoteBeforeInterpolation = splitWith f
+ where
+ f text =
+ case Text.splitOn "'${" text of
+ -- `splitOn` should never return an empty list, but just in case…
+ [] -> mempty
+ t : ts -> loop t ts
- f (t0, e) chunks = map toChunk ts1 ++ (t1, e) : chunks
- where
- (ts1, t1) = splitOnPredicate predicate t0
+ loop head_ tail_ =
+ case tail_ of
+ [] ->
+ Chunks [] head_
+ newHead : newTail ->
+ Chunks [ (head_, TextLit (Chunks [] "'")) ] "${"
+ <> loop newHead newTail
- predicate c = Data.Char.isControl c && c /= ' ' && c /= '\t' && c /= '\n'
+{-| You can think of this as sort of like `concatMap` for `Chunks`
- toChunk (t0, t1) = (t0, TextLit (Chunks [] t1))
+ Given a function that splits plain text into interpolated chunks, apply
+ that function to each uninterpolated span to yield a new
+ possibly-interpolated span, and flatten the results.
+-}
+splitWith :: (Text -> Chunks s a) -> Chunks s a -> Chunks s a
+splitWith splitter (Chunks xys z) = mconcat (xys' ++ [ splitter z ])
+ where
+ xys' = do
+ (x, y) <- xys
--- | Split `Data.Text.Text` on a predicate, preserving all parts of the original
--- string.
+ [ splitter x, Chunks [ ("", y) ] "" ]
+
+-- | Split `Data.Text.Text` into interpolated chunks, where all characters
+-- matching the predicate are pushed into a string interpolation.
--
-- >>> splitOnPredicate (== 'x') ""
--- ([],"")
+-- Chunks [] ""
-- >>> splitOnPredicate (== 'x') " xx "
--- ([(" ","xx")]," ")
+-- Chunks [(" ",TextLit (Chunks [] "xx"))] " "
-- >>> splitOnPredicate (== 'x') "xx"
--- ([("","xx")],"")
+-- Chunks [("",TextLit (Chunks [] "xx"))] ""
--
--- prop> \(Fun _ p) s -> let {t = Text.pack s; (as, b) = splitOnPredicate p t} in foldMap (uncurry (<>)) as <> b == t
-splitOnPredicate :: (Char -> Bool) -> Text -> ([(Text, Text)], Text)
-splitOnPredicate p t = case Text.break p t of
- (a, "") -> ([], a)
- (a, b) -> case Text.span p b of
- (c, d) -> case splitOnPredicate p d of
- (e, f) -> ((a, c) : e, f)
+-- prop> \(Fun _ p) s -> let {t = Text.pack s; Chunks xys z = splitOnPredicate p t} in foldMap (\(x, TextLit (Chunks [] y)) -> x <> y) xys <> z == t
+splitOnPredicate :: (Char -> Bool) -> Text -> Chunks s a
+splitOnPredicate predicate text
+ | Text.null b =
+ Chunks [] a
+ | otherwise =
+ Chunks ((a, TextLit (Chunks [] c)) : e) f
+ where
+ (a, b) = Text.break predicate text
+ (c, d) = Text.span predicate b
+
+ Chunks e f = splitOnPredicate predicate d
+
-- | Escape a trailing single quote by moving it into a string interpolation
--
-- Otherwise the multiline-string would end with @'''@, which would be parsed
@@ -1656,12 +1688,13 @@
-- | Escape a `Data.Text.Text` literal using Dhall's escaping rules for
-- single-quoted @Text@
-escapeSingleQuotedText :: Text -> Text
-escapeSingleQuotedText inputText = outputText
+escapeSingleQuotedText :: Chunks s a -> Chunks s a
+escapeSingleQuotedText = splitWith f
where
- outputText = substitute "${" "''${" (substitute "''" "'''" inputText)
-
- substitute before after = Text.intercalate after . Text.splitOn before
+ f inputText = Chunks [] outputText
+ where
+ outputText =
+ Text.replace "${" "''${" (Text.replace "''" "'''" inputText)
{-| Escape a `Data.Text.Text` literal using Dhall's escaping rules
diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs
--- a/src/Dhall/Syntax.hs
+++ b/src/Dhall/Syntax.hs
@@ -100,7 +100,6 @@
import Data.Void (Void)
import Dhall.Map (Map)
import {-# SOURCE #-} Dhall.Pretty.Internal
-import Dhall.Set (Set)
import Dhall.Src (Src (..))
import GHC.Generics (Generic)
import Instances.TH.Lift ()
@@ -187,21 +186,20 @@
instance Pretty Var where
pretty = Pretty.unAnnotate . prettyVar
-{- | Record the binding part of a @let@ expression.
-
-For example,
-
-> let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x
-
-will be instantiated as follows:
-
-* @bindingSrc0@ corresponds to the @A@ comment.
-* @variable@ is @"x"@
-* @bindingSrc1@ corresponds to the @B@ comment.
-* @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@.
-* @bindingSrc2@ corresponds to the @D@ comment.
-* @value@ corresponds to @True@.
--}
+-- | Record the binding part of a @let@ expression.
+--
+-- For example,
+--
+-- > let {- A -} x {- B -} : {- C -} Bool = {- D -} True in x
+--
+-- … will be instantiated as follows:
+--
+-- * @bindingSrc0@ corresponds to the @A@ comment.
+-- * @variable@ is @"x"@
+-- * @bindingSrc1@ corresponds to the @B@ comment.
+-- * @annotation@ is 'Just' a pair, corresponding to the @C@ comment and @Bool@.
+-- * @bindingSrc2@ corresponds to the @D@ comment.
+-- * @value@ corresponds to @True@.
data Binding s a = Binding
{ bindingSrc0 :: Maybe s
, variable :: Text
@@ -288,62 +286,62 @@
second = fmap
-{-| Record the field of a record-type and record-literal expression.
- The reason why we use the same ADT for both of them is because they store
- the same information.
-
-For example,
-
-> { {- A -} x {- B -} : {- C -} T }
-
-... or
-
-> { {- A -} x {- B -} = {- C -} T }
-
-will be instantiated as follows:
-
-* @recordFieldSrc0@ corresponds to the @A@ comment.
-* @recordFieldValue@ is @"T"@
-* @recordFieldSrc1@ corresponds to the @B@ comment.
-* @recordFieldSrc2@ corresponds to the @C@ comment.
-
-Although the @A@ comment isn't annotating the @"T"@ Record Field,
-this is the best place to keep these comments.
-
-Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for
-a punned entry, because there is no @=@ sign. For example,
-
-> { {- A -} x {- B -} }
-
-will be instantiated as follows:
-
-* @recordFieldSrc0@ corresponds to the @A@ comment.
-* @recordFieldValue@ corresponds to @(Var "x")@
-* @recordFieldSrc1@ corresponds to the @B@ comment.
-* @recordFieldSrc2@ will be 'Nothing'
-
-The labels involved in a record using dot-syntax like in this example:
-
-> { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e }
-
-will be instantiated as follows:
-
-* For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing'
-* For the @a@ field:
- * @recordFieldSrc0@ corresponds to the @A@ comment
- * @recordFieldSrc1@ corresponds to the @B@ comment
-* For the @b@ field:
- * @recordFieldSrc0@ corresponds to the @C@ comment
- * @recordFieldSrc1@ corresponds to the @D@ comment
-* For the @c@ field:
- * @recordFieldSrc0@ corresponds to the @E@ comment
- * @recordFieldSrc1@ corresponds to the @F@ comment
- * @recordFieldSrc2@ corresponds to the @G@ comment
-
-That is, for every label except the last one the semantics of @recordFieldSrc0@
-and @recordFieldSrc1@ are the same from a regular record label but
-@recordFieldSrc2@ is always 'Nothing'. For the last keyword, all srcs are 'Just'
--}
+-- | Record the field of a record-type and record-literal expression.
+-- The reason why we use the same ADT for both of them is because they store
+-- the same information.
+--
+-- For example,
+--
+-- > { {- A -} x {- B -} : {- C -} T }
+--
+-- ... or
+--
+-- > { {- A -} x {- B -} = {- C -} T }
+--
+-- will be instantiated as follows:
+--
+-- * @recordFieldSrc0@ corresponds to the @A@ comment.
+-- * @recordFieldValue@ is @"T"@
+-- * @recordFieldSrc1@ corresponds to the @B@ comment.
+-- * @recordFieldSrc2@ corresponds to the @C@ comment.
+--
+-- Although the @A@ comment isn't annotating the @"T"@ Record Field,
+-- this is the best place to keep these comments.
+--
+-- Note that @recordFieldSrc2@ is always 'Nothing' when the 'RecordField' is for
+-- a punned entry, because there is no @=@ sign. For example,
+--
+-- > { {- A -} x {- B -} }
+--
+-- will be instantiated as follows:
+--
+-- * @recordFieldSrc0@ corresponds to the @A@ comment.
+-- * @recordFieldValue@ corresponds to @(Var "x")@
+-- * @recordFieldSrc1@ corresponds to the @B@ comment.
+-- * @recordFieldSrc2@ will be 'Nothing'
+--
+-- The labels involved in a record using dot-syntax like in this example:
+--
+-- > { {- A -} a {- B -} . {- C -} b {- D -} . {- E -} c {- F -} = {- G -} e }
+--
+-- will be instantiated as follows:
+--
+-- * For both the @a@ and @b@ field, @recordfieldSrc2@ is 'Nothing'
+-- * For the @a@ field:
+-- * @recordFieldSrc0@ corresponds to the @A@ comment
+-- * @recordFieldSrc1@ corresponds to the @B@ comment
+-- * For the @b@ field:
+-- * @recordFieldSrc0@ corresponds to the @C@ comment
+-- * @recordFieldSrc1@ corresponds to the @D@ comment
+-- * For the @c@ field:
+-- * @recordFieldSrc0@ corresponds to the @E@ comment
+-- * @recordFieldSrc1@ corresponds to the @F@ comment
+-- * @recordFieldSrc2@ corresponds to the @G@ comment
+--
+-- That is, for every label except the last one the semantics of
+-- @recordFieldSrc0@ and @recordFieldSrc1@ are the same from a regular record
+-- label but @recordFieldSrc2@ is always 'Nothing'. For the last keyword, all
+-- srcs are 'Just'
data RecordField s a = RecordField
{ recordFieldSrc0 :: Maybe s
, recordFieldValue :: Expr s a
@@ -392,22 +390,23 @@
second = fmap
-{-| Record the field on a selector-expression
-
-For example,
-
-> e . {- A -} x {- B -}
-
-will be instantiated as follows:
-* @fieldSelectionSrc0@ corresponds to the @A@ comment
-* @fieldSelectionLabel@ corresponds to @x@
-* @fieldSelectionSrc1@ corresponds to the @B@ comment
-
-Given our limitation that not all expressions recover their whitespaces, the
-purpose of @fieldSelectionSrc1@ is to save the 'Text.Megaparsec.SourcePos' where
-the @fieldSelectionLabel@ ends, but we /still/ use a 'Maybe Src' (@s = 'Src'@)
-to be consistent with similar data types such as 'Binding', for example.
--}
+-- | Record the field on a selector-expression
+--
+-- For example,
+--
+-- > e . {- A -} x {- B -}
+--
+-- … will be instantiated as follows:
+--
+-- * @fieldSelectionSrc0@ corresponds to the @A@ comment
+-- * @fieldSelectionLabel@ corresponds to @x@
+-- * @fieldSelectionSrc1@ corresponds to the @B@ comment
+--
+-- Given our limitation that not all expressions recover their whitespaces, the
+-- purpose of @fieldSelectionSrc1@ is to save the 'Text.Megaparsec.SourcePos'
+-- where the @fieldSelectionLabel@ ends, but we /still/ use a 'Maybe Src'
+-- (@s = 'Src'@) to be consistent with similar data types such as 'Binding', for
+-- example.
data FieldSelection s = FieldSelection
{ fieldSelectionSrc0 :: Maybe s
, fieldSelectionLabel :: !Text
@@ -609,7 +608,7 @@
| Field (Expr s a) (FieldSelection s)
-- | > Project e (Left xs) ~ e.{ xs }
-- > Project e (Right t) ~ e.(t)
- | Project (Expr s a) (Either (Set Text) (Expr s a))
+ | Project (Expr s a) (Either [Text] (Expr s a))
-- | > Assert e ~ assert : e
| Assert (Expr s a)
-- | > Equivalent x y ~ x ≡ y
diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs
--- a/src/Dhall/Tutorial.hs
+++ b/src/Dhall/Tutorial.hs
@@ -1980,8 +1980,8 @@
--
-- > -- example.dhall
-- >
--- > let Result = < Failure : Integer | Success Text >
--- > in Result.Failure 1
+-- > let Result = < Failure : Integer | Success : Text >
+-- > in Result.Failure +1
--
-- Right now it is quite easy to keep these two definitions (the one in Haskell source and the one in the Dhall file) synchronized:
-- If we implement a new feature in the Haskell source we update the corresponding type in the Dhall file.
@@ -1992,14 +1992,14 @@
-- > resultDecoder = Dhall.auto
-- >
-- > resultType :: Expr Src Void
--- > resultType = Dhall.expected resultDecoder
+-- > resultType = maximum $ Dhall.expected resultDecoder
-- >
-- > resultTypeString :: String
-- > resultTypeString = show $ pretty resultType
--
-- Now we just have to inject that type into the Dhall code and we are done. One common way to do that is to wrap the import of example.dhall in a let expression:
--
--- > Dhall.input (Dhall.auto :: Dhall.Decoder Result) ("let Result = " ++ Data.Text.pack resultTypeString ++ " in ./example.dhall")
+-- > Dhall.input (Dhall.auto :: Dhall.Decoder Result) ("let Result = " <> Data.Text.pack resultTypeString <> " in ./example.dhall")
--
-- Now we can omit the definition of Result in our example.dhall file. While this will work perfectly Dhall provides a cleaner solution for our \"injection problem\":
--
diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs
--- a/src/Dhall/TypeCheck.hs
+++ b/src/Dhall/TypeCheck.hs
@@ -79,7 +79,6 @@
import qualified Dhall.Map
import qualified Dhall.Pretty
import qualified Dhall.Pretty.Internal
-import qualified Dhall.Set
import qualified Dhall.Syntax as Syntax
import qualified Dhall.Util
import qualified Lens.Family
@@ -417,28 +416,14 @@
_R' <- loop ctx r
- tL' <- loop ctx (quote names _L')
+ _ <- loop ctx (quote names _L')
let _L'' = quote names _L'
- case tL' of
- VConst Type ->
- return ()
- _ -> do
- let tL'' = quote names tL'
- die (IfBranchMustBeTerm True l _L'' tL'')
-
- tR' <- loop ctx (quote names _R')
+ _ <- loop ctx (quote names _R')
let _R'' = quote names _R'
- case tR' of
- VConst Type ->
- return ()
- _ -> do
- let tR'' = quote names tR'
- die (IfBranchMustBeTerm True r _R'' tR'')
-
if Eval.conv values _L' _R'
then return ()
else die (IfBranchMismatch l r _L'' _R'')
@@ -1154,6 +1139,12 @@
die (CantAccess text e'' _E'')
Project e (Left xs) -> do
+ case duplicateElement xs of
+ Just x -> do
+ die (DuplicateProjectionLabel x)
+ Nothing -> do
+ return ()
+
_E' <- loop ctx e
let _E'' = quote names _E'
@@ -1167,7 +1158,7 @@
let adapt = VRecord . Dhall.Map.unorderedFromList
- fmap adapt (traverse process (Dhall.Set.toAscList xs))
+ fmap adapt (traverse process xs)
_ -> do
let text =
@@ -1332,7 +1323,6 @@
| 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)
| InvalidFieldType Text (Expr s a)
| InvalidAlternativeType Text (Expr s a)
| ListAppendMismatch (Expr s a) (Expr s a)
@@ -1365,6 +1355,7 @@
| CantAccess Text (Expr s a) (Expr s a)
| CantProject Text (Expr s a) (Expr s a)
| CantProjectByExpression (Expr s a)
+ | DuplicateProjectionLabel Text
| MissingField Text (Expr s a)
| MissingConstructor Text (Expr s a)
| ProjectionTypeMismatch Text (Expr s a) (Expr s a) (Expr s a) (Expr s a)
@@ -2148,93 +2139,6 @@
txt0 = insert expr0
txt1 = insert expr1
-prettyTypeMessage (IfBranchMustBeTerm b expr0 expr1 expr2) =
- ErrorMessages {..}
- where
- short = "❰if❱ branch is not a term"
-
- long =
- "Explanation: Every ❰if❱ expression has a ❰then❱ and ❰else❱ branch, each of which\n\
- \is an expression: \n\
- \ \n\
- \ \n\
- \ Expression for ❰then❱ branch \n\
- \ ⇩ \n\
- \ ┌────────────────────────────────┐ \n\
- \ │ if True then \"Hello, world!\" │ \n\
- \ │ else \"Goodbye, world!\" │ \n\
- \ └────────────────────────────────┘ \n\
- \ ⇧ \n\
- \ Expression for ❰else❱ branch \n\
- \ \n\
- \ \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\
- \ \n\
- \ \n\
- \ ┌────────────────────┐ \n\
- \ │ 1 : Natural : Type │ ❰1❱ is a term with a type (❰Natural❱) of kind ❰Type❱\n\
- \ └────────────────────┘ \n\
- \ ⇧ \n\
- \ term \n\
- \ \n\
- \ \n\
- \ ┌─────────────────────────────────────┐ \n\
- \ │ Natural/odd : Natural → Bool : Type │ ❰Natural/odd❱ is a term with a type\n\
- \ └─────────────────────────────────────┘ (❰Natural → Bool❱) of kind ❰Type❱ \n\
- \ ⇧ \n\
- \ term \n\
- \ \n\
- \ \n\
- \However, the following expressions are " <> _NOT <> " valid terms: \n\
- \ \n\
- \ \n\
- \ ┌────────────────────┐ \n\
- \ │ Text : Type : Kind │ ❰Text❱ has kind (❰Type❱) of sort ❰Kind❱ and is \n\
- \ └────────────────────┘ therefore not a term \n\
- \ ⇧ \n\
- \ type \n\
- \ \n\
- \ \n\
- \ ┌───────────────────────────┐ \n\
- \ │ List : Type → Type : Kind │ ❰List❱ has kind (❰Type → Type❱) of sort \n\
- \ └───────────────────────────┘ ❰Kind❱ and is therefore not a term \n\
- \ ⇧ \n\
- \ type-level function \n\
- \ \n\
- \ \n\
- \This means that you cannot define an ❰if❱ expression that returns a type. For \n\
- \example, the following ❰if❱ expression is " <> _NOT <> " valid: \n\
- \ \n\
- \ \n\
- \ ┌─────────────────────────────┐ \n\
- \ │ if True then Text else Bool │ Invalid ❰if❱ expression \n\
- \ └─────────────────────────────┘ \n\
- \ ⇧ ⇧ \n\
- \ type type \n\
- \ \n\
- \ \n\
- \Your ❰" <> txt0 <> "❱ branch of your ❰if❱ expression is: \n\
- \ \n\
- \" <> txt1 <> "\n\
- \ \n\
- \... which has kind: \n\
- \ \n\
- \" <> txt2 <> "\n\
- \ \n\
- \... of sort: \n\
- \ \n\
- \" <> txt3 <> "\n\
- \ \n\
- \... and is not a term. Therefore your ❰if❱ expression is not valid \n"
- where
- txt0 = if b then "then" else "else"
- txt1 = insert expr0
- txt2 = insert expr1
- txt3 = insert expr2
-
prettyTypeMessage (IfBranchMismatch expr0 expr1 expr2 expr3) =
ErrorMessages {..}
where
@@ -3953,6 +3857,36 @@
where
txt = insert expr
+prettyTypeMessage (DuplicateProjectionLabel k) = ErrorMessages {..}
+ where
+ short = "Duplicate projection label: " <> Dhall.Pretty.Internal.prettyLabel k
+
+ long =
+ "Explanation: You can only specify a label once when projecting a record's fields\n\
+ \by label. For example, this is valid: \n\
+ \ \n\
+ \ \n\
+ \ ┌─────────────────────────────────────────┐ \n\
+ \ │ { x = 1.1, y = 2.4, z = -0.3 }.{ x, y } │ \n\
+ \ └─────────────────────────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \... but this is not valid: \n\
+ \ \n\
+ \ \n\
+ \ ┌─────────────────────────────────────────┐ \n\
+ \ │ { x = 1.1, y = 2.4, z = -0.3 }.{ y, y } │ \n\
+ \ └─────────────────────────────────────────┘ \n\
+ \ ⇧ \n\
+ \ Invalid: the label ❰y❱ appears twice \n\
+ \ \n\
+ \ \n\
+ \You tried to project the following field twice: \n\
+ \ \n\
+ \" <> txt0 <> "\n"
+ where
+ txt0 = insert k
+
prettyTypeMessage (MissingField k expr0) = ErrorMessages {..}
where
short = "Missing record field: " <> Dhall.Pretty.Internal.prettyLabel k
@@ -4638,8 +4572,6 @@
InvalidPredicate <$> f a <*> f b
IfBranchMismatch a b c d ->
IfBranchMismatch <$> f a <*> f b <*> f c <*> f d
- IfBranchMustBeTerm a b c d ->
- IfBranchMustBeTerm <$> pure a <*> f b <*> f c <*> f d
InvalidFieldType a b ->
InvalidFieldType <$> pure a <*> f b
InvalidAlternativeType a b ->
@@ -4704,6 +4636,8 @@
CantProject <$> pure a <*> f b <*> f c
CantProjectByExpression a ->
CantProjectByExpression <$> f a
+ DuplicateProjectionLabel a ->
+ pure (DuplicateProjectionLabel a)
MissingField a b ->
MissingField <$> pure a <*> f b
MissingConstructor a b ->
@@ -4801,3 +4735,11 @@
toPath ks =
Text.intercalate "."
(Foldable.toList (fmap (Dhall.Pretty.Internal.escapeLabel True) ks))
+
+duplicateElement :: Ord a => [a] -> Maybe a
+duplicateElement = go Data.Set.empty
+ where
+ go _ [] = Nothing
+ go found (x : xs)
+ | Data.Set.member x found = Just x
+ | otherwise = go (Data.Set.insert x found) xs
diff --git a/tests/Dhall/Test/QuickCheck.hs b/tests/Dhall/Test/QuickCheck.hs
--- a/tests/Dhall/Test/QuickCheck.hs
+++ b/tests/Dhall/Test/QuickCheck.hs
@@ -308,7 +308,7 @@
:: ConstrGen "Lam" 0 (FunctionBinding s a)
:+ ConstrGen "Pi" 0 Text
:+ ConstrGen "Field" 1 (FieldSelection s)
- :+ ConstrGen "Project" 1 (Either (Set Text) (Expr s a))
+ :+ ConstrGen "Project" 1 (Either [Text] (Expr s a))
:+ Gen Integer -- Generates all Integer fields in Expr
:+ Gen Text -- Generates all Text fields in Expr
:+ ()
@@ -326,7 +326,7 @@
projection =
Test.QuickCheck.oneof
- [ fmap (Left . Dhall.Set.fromList) (Test.QuickCheck.listOf label)
+ [ fmap Left (Test.QuickCheck.listOf label)
, arbitrary
]
diff --git a/tests/Dhall/Test/Regression.hs b/tests/Dhall/Test/Regression.hs
--- a/tests/Dhall/Test/Regression.hs
+++ b/tests/Dhall/Test/Regression.hs
@@ -46,6 +46,8 @@
, issue1584
, issue1646
, issue1732
+ , issue1884
+ , issue2088
, parsing0
, typeChecking0
, typeChecking1
@@ -220,6 +222,13 @@
-- This test ensures that the parser allows a parenthesized application
-- expression as the first argument to a with expression
_ <- Util.code "./tests/regression/issue1884.dhall"
+ return () )
+
+issue2088 :: TestTree
+issue2088 = Test.Tasty.HUnit.testCase "Issue #2088" (do
+ -- This test ensures that the parser for projection by labels doesn't
+ -- accidentally swallow trailing commas OUTSIDE of the projection
+ _ <- Util.code "./tests/regression/issue2088.dhall"
return () )
parsing0 :: TestTree
diff --git a/tests/Dhall/Test/TypeInference.hs b/tests/Dhall/Test/TypeInference.hs
--- a/tests/Dhall/Test/TypeInference.hs
+++ b/tests/Dhall/Test/TypeInference.hs
@@ -103,8 +103,7 @@
[
-- Duplicate fields are incorrectly caught during parsing:
-- https://github.com/dhall-lang/dhall-haskell/issues/772
- typeInferenceDirectory "failure/unit/RecordProjectionDuplicateFields"
- , typeInferenceDirectory "failure/unit/RecordTypeDuplicateFields"
+ typeInferenceDirectory "failure/unit/RecordTypeDuplicateFields"
, typeInferenceDirectory "failure/unit/UnionTypeDuplicateVariants1"
, typeInferenceDirectory "failure/unit/UnionTypeDuplicateVariants2"
]
diff --git a/tests/format/issue2078A.dhall b/tests/format/issue2078A.dhall
new file mode 100644
--- /dev/null
+++ b/tests/format/issue2078A.dhall
@@ -0,0 +1,1 @@
+"'\${x}'\n"
diff --git a/tests/format/issue2078B.dhall b/tests/format/issue2078B.dhall
new file mode 100644
--- /dev/null
+++ b/tests/format/issue2078B.dhall
@@ -0,0 +1,3 @@
+''
+${"'"}''${x}'
+''
diff --git a/tests/regression/issue2088.dhall b/tests/regression/issue2088.dhall
new file mode 100644
--- /dev/null
+++ b/tests/regression/issue2088.dhall
@@ -0,0 +1,1 @@
+[ { x = 1 }.{ x }, { x = 1 } ]