diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,33 @@ +1.40.2 + +* [Supports standard version 21.1.0](https://github.com/dhall-lang/dhall-haskell/pull/2236) + * [The interpreter now supports customizing headers using a `headers.dhall` + configuration file](https://github.com/dhall-lang/dhall-haskell/pull/2236) + * [Generalize grammar for certain annotations](https://github.com/dhall-lang/dhall-haskell/pull/2320) + * [Add support for a trailing line comment without a newline](https://github.com/dhall-lang/dhall-haskell/pull/2309) +* [BUG FIX: `dhall repl` no longer ignores type annotations on `:let` commands](https://github.com/dhall-lang/dhall-haskell/pull/2297) + * Before this fix, `:let x : T = 3` would ignore the `: T` type annotation +* [BUG FIX: Don't accept a bar after an empty union](https://github.com/dhall-lang/dhall-haskell/pull/2338) + * Before this fix, the interpreter would accept something like `<>|`, which + is not valid according to the standard grammar +* New `FromDhall`/`ToDhall` instances for `Day`/`TimeOfDay`/`TimeZone` [#2294](https://github.com/dhall-lang/dhall-haskell/pull/2294) [#2300](https://github.com/dhall-lang/dhall-haskell/pull/2300) + * These types correspond to the recent temporal literals added to the + language +* [New `subExpressionsWith` `Traversal`](https://github.com/dhall-lang/dhall-haskell/pull/2302) +* [Add Template Haskell support for modifying field names in generated Haskell + types](https://github.com/dhall-lang/dhall-haskell/pull/2285) + * This adds a new `makeHaskellTypesWith` utility with takes a + `GenerateOptions` function argument for customizing the code-generation + logic + * This comes in handy when Dhall fields have names are reserved keywords in + Haskell code. You can now transform the Haskell field names to avoid + collisions +* [Support GHC 9.2](https://github.com/dhall-lang/dhall-haskell/pull/2328) +* Fixes and improvements to documentation + * [#2290](https://github.com/dhall-lang/dhall-haskell/pull/2290) +* Fixes and improvements to error messages + * [#2303](https://github.com/dhall-lang/dhall-haskell/pull/2303) + 1.40.1 * [BUG FIX: Fix equivalence check for `Date` / `Time` / `TimeZone`](https://github.com/dhall-lang/dhall-haskell/pull/2291) 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 @@ -2,7 +2,7 @@ module Main (main) where import Data.Void (Void) -import Gauge (defaultMain) +import Gauge (defaultMain) import qualified Data.Sequence as Seq import qualified Dhall.Core as Core 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 @@ -34,6 +34,10 @@ ./replicate.dhall sha256:1b398b1d464b3a6c7264a690ac3cacb443b5683b43348c859d68e7c2cb925c4f ? ./replicate.dhall +, shell-escape = + ./shell-escape.dhall + sha256:d53521b3f478cb18a7d63730bc0e3153c2124b70d6ac9a1f610ce7db67cfc7a2 + ? ./shell-escape.dhall , show = ./show.dhall sha256:c9dc5de3e5f32872dbda57166804865e5e80785abe358ff61f1d8ac45f1f4784 diff --git a/dhall-lang/Prelude/Text/shell-escape.dhall b/dhall-lang/Prelude/Text/shell-escape.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/Text/shell-escape.dhall @@ -0,0 +1,16 @@ +{-| +Escape a Text value such that it can be used safely in shells. +The escaping is done by replacing all `'` with `'"'"'` and wraps that string in +single quotes. + +This works for all POSIX-compliant shells and some other shells like csh. +-} +let shell-escape + : Text -> Text + = \(xs : Text) -> "'${Text/replace "'" "'\"'\"'" xs}'" + +let example0 = assert : shell-escape "foo" === "'foo'" + +let example1 = assert : shell-escape "foo'bar" === "'foo'\"'\"'bar'" + +in shell-escape diff --git a/dhall-lang/Prelude/XML/Type b/dhall-lang/Prelude/XML/Type --- a/dhall-lang/Prelude/XML/Type +++ b/dhall-lang/Prelude/XML/Type @@ -1,3 +1,3 @@ ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.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 @@ -15,6 +15,8 @@ → λ ( xml : { text : Text → XML + , rawText : + Text → XML , element : { attributes : List { mapKey : Text, mapValue : Text } @@ -49,6 +51,7 @@ = ∀(XML : Type) → ∀ ( xml : { text : Text → XML + , rawText : Text → XML , element : { attributes : List { mapKey : Text, mapValue : Text } , content : List XML diff --git a/dhall-lang/Prelude/XML/element b/dhall-lang/Prelude/XML/element --- a/dhall-lang/Prelude/XML/element +++ b/dhall-lang/Prelude/XML/element @@ -1,3 +1,3 @@ ./element.dhall - sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b + sha256:79266d604e147caf37e985581523b684f7bac66de0c93dd828841df3dfc445f9 ? ./element.dhall 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 @@ -20,7 +20,7 @@ -} let XML = ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.dhall let List/map = @@ -41,6 +41,7 @@ λ(XML : Type) → λ ( xml : { text : Text → XML + , rawText : Text → XML , element : { attributes : List { mapKey : Text, mapValue : Text } , content : List XML diff --git a/dhall-lang/Prelude/XML/leaf b/dhall-lang/Prelude/XML/leaf --- a/dhall-lang/Prelude/XML/leaf +++ b/dhall-lang/Prelude/XML/leaf @@ -1,3 +1,3 @@ ./leaf.dhall - sha256:4383e4fc4bf6a29ac2052776972eb59d5355a1cd067cded80d4ff32840969261 + sha256:5dcedf79a3664a362479f470220bb2f4932facde657c285fd8a3c24ab137c506 ? ./leaf.dhall 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 @@ -11,12 +11,12 @@ -} let XML = ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.dhall let element = ./element.dhall - sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b + sha256:79266d604e147caf37e985581523b684f7bac66de0c93dd828841df3dfc445f9 ? ./element.dhall let leaf 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 @@ -1,6 +1,6 @@ { Type = ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.dhall , attribute = ./attribute.dhall @@ -8,20 +8,24 @@ ? ./attribute.dhall , render = ./render.dhall - sha256:550c8900fe199b83d629181d53c646f2f9425d9c64670dabb30d28e95bfa4c75 + sha256:395c293702c85d99f6f2b461f3eee320f9fe5749c320c2e8b9ea799a7d210b66 ? ./render.dhall , element = ./element.dhall - sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b + sha256:79266d604e147caf37e985581523b684f7bac66de0c93dd828841df3dfc445f9 ? ./element.dhall , leaf = ./leaf.dhall - sha256:4383e4fc4bf6a29ac2052776972eb59d5355a1cd067cded80d4ff32840969261 + sha256:5dcedf79a3664a362479f470220bb2f4932facde657c285fd8a3c24ab137c506 ? ./leaf.dhall , text = ./text.dhall - sha256:c83cd721d32d7dc28c04ce429c0cb22812639e572637ec348578a58ffb68844f + sha256:a59670560a08bfc815893dee1f3eae21a5252400f8a619d1cd7bdd9f48eea2ab ? ./text.dhall +, rawText = + ./rawText.dhall + sha256:2af9d72c151677d4110039e361b7e9faaf2947e6c9d29aa72aea351ad797e05d + ? ./rawText.dhall , emptyAttributes = ./emptyAttributes.dhall sha256:11b86e2d3f3c75d47a1d580213d2a03fd2c36d64f3e9b6381de0ba23472f64d5 diff --git a/dhall-lang/Prelude/XML/rawText.dhall b/dhall-lang/Prelude/XML/rawText.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/XML/rawText.dhall @@ -0,0 +1,40 @@ +{-| +Create a Text value to be inserted into an XML element as content with no +character escaping. + +``` +let XML = ./package.dhall + +in XML.render + ( XML.element + { name = "location" + , attributes = XML.emptyAttributes + , content = [ XML.rawText "" ] + } + ) += "" +``` +-} +let XML = + ./Type.dhall + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 + ? ./Type.dhall + +let rawText + : Text → XML + = λ(d : Text) → + λ(XML : Type) → + λ ( xml + : { text : Text → XML + , rawText : Text → XML + , element : + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text + } → + XML + } + ) → + xml.rawText d + +in rawText 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,3 +1,3 @@ ./render.dhall - sha256:550c8900fe199b83d629181d53c646f2f9425d9c64670dabb30d28e95bfa4c75 + sha256:395c293702c85d99f6f2b461f3eee320f9fe5749c320c2e8b9ea799a7d210b66 ? ./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 @@ -8,7 +8,7 @@ let XML = ./package.dhall in XML.render - ( XML.node + ( XML.element { name = "foo" , attributes = [ XML.attribute "a" "x", XML.attribute "b" (Natural/show 2) ] , content = [ XML.leaf { name = "bar", attributes = XML.emptyAttributes } ] @@ -20,7 +20,7 @@ -} let XML = ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.dhall let Text/concatMap = @@ -35,12 +35,12 @@ let element = ./element.dhall - sha256:e0b948053c8cd8ccca9c39244d89e3f42db43d222531c18151551dfc75208b4b + sha256:79266d604e147caf37e985581523b684f7bac66de0c93dd828841df3dfc445f9 ? ./element.dhall let text = ./text.dhall - sha256:c83cd721d32d7dc28c04ce429c0cb22812639e572637ec348578a58ffb68844f + sha256:a59670560a08bfc815893dee1f3eae21a5252400f8a619d1cd7bdd9f48eea2ab ? ./text.dhall let emptyAttributes = @@ -76,6 +76,7 @@ x Text { text = escapeText + , rawText = λ(t : Text) → t , element = λ ( elem : { attributes : List { mapKey : Text, mapValue : Text } diff --git a/dhall-lang/Prelude/XML/text b/dhall-lang/Prelude/XML/text --- a/dhall-lang/Prelude/XML/text +++ b/dhall-lang/Prelude/XML/text @@ -1,3 +1,3 @@ ./text.dhall - sha256:c83cd721d32d7dc28c04ce429c0cb22812639e572637ec348578a58ffb68844f + sha256:a59670560a08bfc815893dee1f3eae21a5252400f8a619d1cd7bdd9f48eea2ab ? ./text.dhall 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 @@ -5,7 +5,7 @@ let XML = ./package.dhall in XML.render - ( XML.node + ( XML.element { name = "location" , attributes = XML.emptyAttributes , content = [ XML.text "/foo/bar" ] @@ -16,7 +16,7 @@ -} let XML = ./Type.dhall - sha256:461930f3aab769ba537d1a4fd71f411504b0c8d1c1a78d65177be8ded0df8a5c + sha256:ab91a0edaf0513e0083b1dfae5efa160adc99b0e589775a4a699ab77cce528a9 ? ./Type.dhall let text @@ -25,6 +25,7 @@ λ(XML : Type) → λ ( xml : { text : Text → XML + , rawText : Text → XML , element : { attributes : List { mapKey : Text, mapValue : Text } , content : List XML diff --git a/dhall-lang/Prelude/package.dhall b/dhall-lang/Prelude/package.dhall --- a/dhall-lang/Prelude/package.dhall +++ b/dhall-lang/Prelude/package.dhall @@ -52,10 +52,10 @@ ? ./JSON/package.dhall , Text = ./Text/package.dhall - sha256:17a0e0e881b05436d7e3ae94a658af9da5ba2a921fafa0d1d545890978853434 + sha256:79b671a70ac459b799a53bbb8a383cc8b81b40421745c54bf0fb1143168cbd6f ? ./Text/package.dhall , XML = ./XML/package.dhall - sha256:6a15ea2ab1918f97374ec2fe3b90c056fb807fb3a90c1c44ce9fb9233f59c0e5 + sha256:2e111f0952087d42072b059f0bf4c95861a46bffa67ad4c8c39086edf405f32e ? ./XML/package.dhall } diff --git a/dhall-lang/tests/import/data/userAgent.dhall b/dhall-lang/tests/import/data/userAgent.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/data/userAgent.dhall @@ -0,0 +1,1 @@ +"Dhall (from import)" diff --git a/dhall-lang/tests/import/failure/originHeadersFromRemote.dhall b/dhall-lang/tests/import/failure/originHeadersFromRemote.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/originHeadersFromRemote.dhall @@ -0,0 +1,1 @@ +https://httpbin.org/user-agent as Text diff --git a/dhall-lang/tests/import/failure/originHeadersFromRemoteENV.dhall b/dhall-lang/tests/import/failure/originHeadersFromRemoteENV.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/failure/originHeadersFromRemoteENV.dhall @@ -0,0 +1,11 @@ +-- Use of a remote import causes Cyclic Import on env:DHALL_HEADERS +toMap + { DHALL_HEADERS = + '' + toMap { + `httpbin.org:443` = toMap { + `User-Agent` = http://example.com as Text + } + } + '' + } diff --git a/dhall-lang/tests/import/success/originHeadersA.dhall b/dhall-lang/tests/import/success/originHeadersA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersA.dhall @@ -0,0 +1,1 @@ +https://httpbin.org/user-agent as Text diff --git a/dhall-lang/tests/import/success/originHeadersB.dhall b/dhall-lang/tests/import/success/originHeadersB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersB.dhall @@ -0,0 +1,5 @@ +'' +{ + "user-agent": "Dhall" +} +'' diff --git a/dhall-lang/tests/import/success/originHeadersENV.dhall b/dhall-lang/tests/import/success/originHeadersENV.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersENV.dhall @@ -0,0 +1,10 @@ +toMap + { DHALL_HEADERS = + '' + toMap { + `httpbin.org:443` = toMap { + `User-Agent` = "Dhall" + } + } + '' + } diff --git a/dhall-lang/tests/import/success/originHeadersImportA.dhall b/dhall-lang/tests/import/success/originHeadersImportA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportA.dhall @@ -0,0 +1,1 @@ +https://httpbin.org/user-agent as Text diff --git a/dhall-lang/tests/import/success/originHeadersImportB.dhall b/dhall-lang/tests/import/success/originHeadersImportB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportB.dhall @@ -0,0 +1,5 @@ +'' +{ + "user-agent": "Dhall (from import)" +} +'' diff --git a/dhall-lang/tests/import/success/originHeadersImportENV.dhall b/dhall-lang/tests/import/success/originHeadersImportENV.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportENV.dhall @@ -0,0 +1,10 @@ +toMap + { DHALL_HEADERS = + '' + toMap { + `httpbin.org:443` = toMap { + `User-Agent` = ./dhall-lang/tests/import/data/userAgent.dhall + } + } + '' + } diff --git a/dhall-lang/tests/import/success/originHeadersImportFromEnvA.dhall b/dhall-lang/tests/import/success/originHeadersImportFromEnvA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportFromEnvA.dhall @@ -0,0 +1,1 @@ +https://httpbin.org/user-agent as Text diff --git a/dhall-lang/tests/import/success/originHeadersImportFromEnvB.dhall b/dhall-lang/tests/import/success/originHeadersImportFromEnvB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportFromEnvB.dhall @@ -0,0 +1,5 @@ +'' +{ + "user-agent": "Dhall (from env)" +} +'' diff --git a/dhall-lang/tests/import/success/originHeadersImportFromEnvENV.dhall b/dhall-lang/tests/import/success/originHeadersImportFromEnvENV.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersImportFromEnvENV.dhall @@ -0,0 +1,11 @@ +toMap + { DHALL_HEADERS = + '' + toMap { + `httpbin.org:443` = toMap { + `User-Agent` = env:USER_AGENT as Text + } + } + '' + , USER_AGENT = "Dhall (from env)" + } diff --git a/dhall-lang/tests/import/success/originHeadersOverrideA.dhall b/dhall-lang/tests/import/success/originHeadersOverrideA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersOverrideA.dhall @@ -0,0 +1,3 @@ +https://httpbin.org/user-agent + using [ { mapKey = "User-Agent", mapValue = "inline-header" } ] + as Text diff --git a/dhall-lang/tests/import/success/originHeadersOverrideB.dhall b/dhall-lang/tests/import/success/originHeadersOverrideB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersOverrideB.dhall @@ -0,0 +1,5 @@ +'' +{ + "user-agent": "user-header" +} +'' diff --git a/dhall-lang/tests/import/success/originHeadersOverrideENV.dhall b/dhall-lang/tests/import/success/originHeadersOverrideENV.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/import/success/originHeadersOverrideENV.dhall @@ -0,0 +1,10 @@ +toMap + { DHALL_HEADERS = + '' + toMap { + `httpbin.org:443` = toMap { + `User-Agent` = "user-header" + } + } + '' + } diff --git a/dhall-lang/tests/import/success/userHeadersA.dhall b/dhall-lang/tests/import/success/userHeadersA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -https://httpbin.org/user-agent as Text diff --git a/dhall-lang/tests/import/success/userHeadersB.dhall b/dhall-lang/tests/import/success/userHeadersB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersB.dhall +++ /dev/null @@ -1,5 +0,0 @@ -'' -{ - "user-agent": "Dhall" -} -'' diff --git a/dhall-lang/tests/import/success/userHeadersENV.dhall b/dhall-lang/tests/import/success/userHeadersENV.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersENV.dhall +++ /dev/null @@ -1,10 +0,0 @@ -toMap - { DHALL_HEADERS = - '' - toMap { - `httpbin.org:443` = toMap { - `User-Agent` = "Dhall" - } - } - '' - } diff --git a/dhall-lang/tests/import/success/userHeadersOverrideA.dhall b/dhall-lang/tests/import/success/userHeadersOverrideA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersOverrideA.dhall +++ /dev/null @@ -1,3 +0,0 @@ -https://httpbin.org/user-agent - using [ { mapKey = "User-Agent", mapValue = "inline-header" } ] - as Text diff --git a/dhall-lang/tests/import/success/userHeadersOverrideB.dhall b/dhall-lang/tests/import/success/userHeadersOverrideB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersOverrideB.dhall +++ /dev/null @@ -1,5 +0,0 @@ -'' -{ - "user-agent": "user-header" -} -'' diff --git a/dhall-lang/tests/import/success/userHeadersOverrideENV.dhall b/dhall-lang/tests/import/success/userHeadersOverrideENV.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/userHeadersOverrideENV.dhall +++ /dev/null @@ -1,10 +0,0 @@ -toMap - { DHALL_HEADERS = - '' - toMap { - `httpbin.org:443` = toMap { - `User-Agent` = "user-header" - } - } - '' - } diff --git a/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineA.dhall b/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineA.dhall @@ -0,0 +1,2 @@ +-- This test verifies that a trailing line comment does not require a newline +1-- diff --git a/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineB.dhallb b/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/TrailingLineCommentWithoutNewlineB.dhallb @@ -0,0 +1,1 @@ +‚ 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 @@ -588,6 +588,7 @@ , replace : ∀(needle : Text) → ∀(replacement : Text) → ∀(haystack : Text) → Text , replicate : ∀(num : Natural) → ∀(text : Text) → Text + , shell-escape : ∀(xs : Text) → Text , show : Text → Text , spaces : ∀(a : Natural) → Text , upperASCII : ∀(nil : Text) → Text @@ -610,6 +611,7 @@ , name : Text } → XML + , rawText : Text → XML , text : Text → XML } ) → @@ -626,6 +628,7 @@ , name : Text } → XML + , rawText : Text → XML , text : Text → XML } ) → @@ -645,10 +648,26 @@ , name : Text } → XML + , rawText : Text → XML , text : Text → XML } ) → XML + , rawText : + ∀(d : Text) → + ∀(XML : Type) → + ∀ ( xml + : { element : + { attributes : List { mapKey : Text, mapValue : Text } + , content : List XML + , name : Text + } → + XML + , rawText : Text → XML + , text : Text → XML + } + ) → + XML , render : ∀ ( x : ∀(XML : Type) → @@ -659,6 +678,7 @@ , name : Text } → XML + , rawText : Text → XML , text : Text → XML } ) → @@ -675,6 +695,7 @@ , name : Text } → XML + , rawText : Text → XML , text : Text → XML } ) → diff --git a/dhall-lang/tests/type-inference/success/unit/ConstructorShiftA.dhall b/dhall-lang/tests/type-inference/success/unit/ConstructorShiftA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/ConstructorShiftA.dhall @@ -0,0 +1,1 @@ +λ(t : Type) → < t : t >.t diff --git a/dhall-lang/tests/type-inference/success/unit/ConstructorShiftB.dhall b/dhall-lang/tests/type-inference/success/unit/ConstructorShiftB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/ConstructorShiftB.dhall @@ -0,0 +1,1 @@ +∀(t : Type) → ∀(t : t) → < t : t@1 > diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,5 +1,5 @@ Name: dhall -Version: 1.40.1 +Version: 1.40.2 Cabal-Version: 2.0 Build-Type: Simple License: BSD3 @@ -473,10 +473,11 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.11.0.0 && < 5 , - aeson >= 1.0.0.0 && < 1.6 , + aeson >= 1.0.0.0 && < 2.1 , aeson-pretty < 0.9 , ansi-terminal >= 0.6.3.1 && < 0.12, atomic-write >= 0.2.0.7 && < 0.3 , + base16-bytestring >= 1.0.0.0 , bytestring < 0.12, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , @@ -493,24 +494,24 @@ filepath >= 1.4 && < 1.5 , half >= 0.2.2.3 && < 0.4 , haskeline >= 0.7.2.1 && < 0.9 , - hashable >= 1.2 && < 1.4 , + hashable >= 1.2 && < 1.5 , lens-family-core >= 1.0.0 && < 2.2 , - megaparsec >= 7 && < 9.2 , - memory >= 0.14 && < 0.17, + -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 + megaparsec >= 8 && < 10 , mmorph < 1.3 , mtl >= 2.2.1 && < 2.3 , network-uri >= 2.6 && < 2.7 , optparse-applicative >= 0.14.0.0 && < 0.17, parsers >= 0.12.4 && < 0.13, parser-combinators , - prettyprinter >= 1.5.1 && < 1.8 , + prettyprinter >= 1.7.0 && < 1.8 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , pretty-simple < 4.1 , profunctors >= 3.1.2 && < 5.7 , repline >= 0.4.0.0 && < 0.5 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell >= 2.13.0.0 && < 2.18, + template-haskell >= 2.13.0.0 && < 2.19, text >= 0.11.1.0 && < 1.3 , text-manipulate >= 0.2.0.1 && < 0.4 , th-lift-instances >= 0.1.13 && < 0.2 , @@ -533,7 +534,7 @@ else Hs-Source-Dirs: ghc-src Build-Depends: - cryptonite >= 0.23 && < 0.30 + cryptohash-sha256 if flag(with-http) Build-Depends: http-types >= 0.7.0 && < 0.13, @@ -610,6 +611,7 @@ Other-Modules: Dhall.Eval Dhall.Import.Types + Dhall.Import.Headers Dhall.Marshal.Internal Dhall.Normalize Dhall.Parser.Combinators @@ -676,17 +678,18 @@ lens-family-core , megaparsec , prettyprinter , - QuickCheck >= 2.10 && < 2.15, + QuickCheck >= 2.14 && < 2.15, quickcheck-instances >= 0.3.12 && < 0.4 , scientific , serialise , special-values < 0.2 , spoon < 0.4 , + system-filepath , tasty >= 0.11.2 && < 1.5 , tasty-expected-failure < 0.13, tasty-hunit >= 0.10 && < 0.11, tasty-quickcheck >= 0.9.2 && < 0.11, - tasty-silver < 3.3 , + tasty-silver < 3.4 , template-haskell , temporary >= 1.2.1 && < 1.4 , text >= 0.11.1.0 && < 1.3 , @@ -710,7 +713,7 @@ directory , filepath < 1.5 , mockery < 0.4 , - doctest >= 0.7.0 && < 0.19 + doctest >= 0.7.0 if os(windows) -- https://github.com/dhall-lang/dhall-haskell/issues/2237 Buildable: False diff --git a/ghc-src/Dhall/Crypto.hs b/ghc-src/Dhall/Crypto.hs --- a/ghc-src/Dhall/Crypto.hs +++ b/ghc-src/Dhall/Crypto.hs @@ -13,18 +13,17 @@ ) where import Control.DeepSeq (NFData) -import Crypto.Hash (SHA256) -import Data.ByteArray (ByteArrayAccess, convert) -import Data.ByteArray.Encoding (Base (Base16), convertToBase) import Data.ByteString (ByteString) import GHC.Generics (Generic) -import qualified Crypto.Hash -import qualified Data.ByteString.Char8 as ByteString.Char8 +import qualified Crypto.Hash.SHA256 +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as ByteString.Char8 -- | A SHA256 digest newtype SHA256Digest = SHA256Digest { unSHA256Digest :: ByteString } - deriving (Eq, Generic, Ord, NFData, ByteArrayAccess) + deriving (Eq, Generic, Ord, NFData) instance Show SHA256Digest where show = toString @@ -33,16 +32,14 @@ `Nothing` if the conversion fails -} sha256DigestFromByteString :: ByteString -> Maybe SHA256Digest -sha256DigestFromByteString bytes = SHA256Digest . convert <$> mh - where - mh = Crypto.Hash.digestFromByteString bytes :: Maybe (Crypto.Hash.Digest SHA256) +sha256DigestFromByteString bytes + | ByteString.length bytes == 32 = Just (SHA256Digest bytes) + | otherwise = Nothing -- | Hash a `ByteString` and return the hash as a `SHA256Digest` sha256Hash :: ByteString -> SHA256Digest -sha256Hash bytes = SHA256Digest $ convert h - where - h = Crypto.Hash.hash bytes :: Crypto.Hash.Digest SHA256 +sha256Hash = SHA256Digest . Crypto.Hash.SHA256.hash -- | 'String' representation of a 'SHA256Digest' toString :: SHA256Digest -> String -toString (SHA256Digest bytes) = ByteString.Char8.unpack $ convertToBase Base16 bytes +toString (SHA256Digest bytes) = ByteString.Char8.unpack $ Base16.encode bytes 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 @@ -1,8 +1,10 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Dhall.Import.HTTP ( fetchFromHttpUrl + , originHeadersFileExpr ) where import Control.Exception (Exception) @@ -11,25 +13,32 @@ import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Data.Dynamic (toDyn) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text.Encoding (decodeUtf8) import Dhall.Core - ( Import (..) + ( Expr (..) + , Directory (..) + , File (..) + , FilePrefix (..) + , Import (..) , ImportHashed (..) + , ImportMode (..) , ImportType (..) , Scheme (..) , URL (..) ) import Dhall.Import.Types +import Dhall.Parser (Src) import Dhall.URL (renderURL) +import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) +import System.FilePath (splitDirectories) -import Network.HTTP.Client - ( HttpException (..) - , HttpExceptionContent (..) - ) +import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) import qualified Control.Exception import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text import qualified Data.Text.Encoding import qualified Data.Text.Lazy @@ -241,20 +250,35 @@ Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () -type HTTPHeader = Network.HTTP.Types.Header +addHeaders :: OriginHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request +addHeaders originHeaders urlHeaders request = + request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> perOriginHeaders } + where + origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) + + perOriginHeaders = HashMap.lookupDefault [] origin originHeaders + filterHeaders = foldMap (filter (not . overridden)) + + overridden :: HTTPHeader -> Bool + overridden (key, _value) = any (matchesKey key) perOriginHeaders + + matchesKey :: CI ByteString -> HTTPHeader -> Bool + matchesKey key (candidate, _value) = key == candidate + fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do + Status { _loadOriginHeaders } <- State.get + + originHeaders <- _loadOriginHeaders + manager <- newManager let childURLString = Text.unpack (renderURL childURL) - request <- liftIO (HTTP.parseUrlThrow childURLString) + baseRequest <- liftIO (HTTP.parseUrlThrow childURLString) - let requestWithHeaders = - case mheaders of - Nothing -> request - Just headers -> request { HTTP.requestHeaders = headers } + let requestWithHeaders = addHeaders originHeaders mheaders baseRequest let io = HTTP.httpLbs requestWithHeaders manager @@ -281,3 +305,11 @@ case Data.Text.Lazy.Encoding.decodeUtf8' bytes of Left err -> liftIO (Control.Exception.throwIO err) Right text -> return (Data.Text.Lazy.toStrict text) + +originHeadersFileExpr :: IO (Expr Src Import) +originHeadersFileExpr = do + directoryStr <- getXdgDirectory XdgConfig "dhall" + let components = map Text.pack (splitDirectories directoryStr) + let directory = Directory (reverse components) + let file = (File directory "headers.dhall") + return (Embed (Import (ImportHashed Nothing (Local Absolute file)) Code)) diff --git a/ghc-src/Dhall/Import/Manager.hs b/ghc-src/Dhall/Import/Manager.hs --- a/ghc-src/Dhall/Import/Manager.hs +++ b/ghc-src/Dhall/Import/Manager.hs @@ -16,7 +16,7 @@ , defaultNewManager ) where -import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client (Manager, newManager) import qualified Network.HTTP.Client as HTTP #ifdef USE_HTTP_CLIENT_TLS diff --git a/ghcjs-src/Dhall/Crypto.hs b/ghcjs-src/Dhall/Crypto.hs --- a/ghcjs-src/Dhall/Crypto.hs +++ b/ghcjs-src/Dhall/Crypto.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE JavaScriptFFI #-} {-| This module provides implementations of cryptographic utilities that only work for GHCJS @@ -12,32 +12,31 @@ , sha256Hash ) where -import Control.DeepSeq (NFData) -import Data.ByteArray (ByteArrayAccess) -import Data.ByteArray.Encoding (Base(Base16), convertToBase) -import Data.ByteString (ByteString) -import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import GHC.Generics (Generic) import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as ByteString.Char8 import qualified GHCJS.Buffer as Buffer -- | A SHA256 digest newtype SHA256Digest = SHA256Digest { unSHA256Digest :: ByteString } - deriving (Eq, Generic, Ord, NFData, ByteArrayAccess) + deriving (Eq, Generic, Ord, NFData) instance Show SHA256Digest where - show (SHA256Digest bytes) = ByteString.Char8.unpack $ convertToBase Base16 bytes + show (SHA256Digest bytes) = ByteString.Char8.unpack $ Base16.encode bytes {-| Attempt to interpret a `ByteString` as a `SHA256Digest`, returning `Nothing` if the conversion fails -} sha256DigestFromByteString :: ByteString -> Maybe SHA256Digest sha256DigestFromByteString bytes - | ByteString.length bytes == 32 = Just $ SHA256Digest bytes - | otherwise = Nothing + | ByteString.length bytes == 32 = Just (SHA256Digest bytes) + | otherwise = Nothing -- Use NodeJS' crypto module if there's a 'process' module, e.g. we're running -- inside GHCJS' THRunner. If we're running in the browser, use the WebCrypto diff --git a/ghcjs-src/Dhall/Import/HTTP.hs b/ghcjs-src/Dhall/Import/HTTP.hs --- a/ghcjs-src/Dhall/Import/HTTP.hs +++ b/ghcjs-src/Dhall/Import/HTTP.hs @@ -2,14 +2,16 @@ module Dhall.Import.HTTP ( fetchFromHttpUrl + , originHeadersFileExpr ) where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Dhall.Core (URL (..)) -import Dhall.Import.Types (Status) +import Dhall.Core (URL (..), Expr (..)) +import Dhall.Import.Types (Import, Status) +import Dhall.Parser (Src) import Dhall.URL (renderURL) import qualified Data.Text as Text @@ -35,3 +37,6 @@ return body fetchFromHttpUrl _ _ = fail "Dhall does not yet support custom headers when built using GHCJS" + +originHeadersFileExpr :: IO (Expr Src Import) +originHeadersFileExpr = return Missing diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -54,14 +54,13 @@ import Data.Void (Void, absurd) import GHC.Float (double2Float, float2Double) import Numeric.Half (fromHalf, toHalf) -import Prelude hiding (exponent) +import Prelude hiding (exponent) import qualified Codec.CBOR.ByteArray import qualified Codec.CBOR.Decoding as Decoding import qualified Codec.CBOR.Encoding as Encoding import qualified Codec.CBOR.Read as Read import qualified Codec.Serialise as Serialise -import qualified Data.ByteArray import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.ByteString.Short @@ -1271,7 +1270,7 @@ Encoding.encodeNull Just digest -> - Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) + Encoding.encodeBytes ("\x12\x20" <> Dhall.Crypto.unSHA256Digest digest) m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;) diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -56,6 +56,7 @@ -- * Optics , subExpressions + , subExpressionsWith , chunkExprs , bindingExprs , recordFieldExprs @@ -78,16 +79,16 @@ , Syntax.desugarWith ) where -import Control.Exception (Exception) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) +import Control.Exception (Exception) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Text (Text) import Dhall.Normalize import Dhall.Pretty.Internal -import Dhall.Src (Src (..)) +import Dhall.Src (Src (..)) import Dhall.Syntax -import Instances.TH.Lift () -import Lens.Family (over) +import Instances.TH.Lift () +import Lens.Family (over) +import Prettyprinter (Pretty) import qualified Control.Exception import qualified Data.Text diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-| This module provides functionality for concisely displaying the difference between two expressions @@ -17,16 +17,15 @@ , diff ) where -import Data.Foldable (fold, toList) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid (Any (..)) -import Data.Sequence (Seq) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Data.Void (Void) -import Dhall.Map (Map) -import Dhall.Pretty.Internal (Ann) +import Data.Foldable (fold, toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Any (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Map (Map) +import Dhall.Pretty.Internal (Ann) import Dhall.Syntax ( Binding (..) , Chunks (..) @@ -37,18 +36,19 @@ , RecordField (..) , Var (..) ) -import Numeric.Natural (Natural) +import Numeric.Natural (Natural) +import Prettyprinter (Doc, Pretty) -import qualified Data.Algorithm.Diff as Algo.Diff +import qualified Data.Algorithm.Diff as Algo.Diff import qualified Data.List.NonEmpty import qualified Data.Set import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Time as Time +import qualified Data.Time as Time import qualified Dhall.Map -import qualified Dhall.Normalize as Normalize -import qualified Dhall.Pretty.Internal as Internal -import qualified Dhall.Syntax as Syntax +import qualified Dhall.Normalize as Normalize +import qualified Dhall.Pretty.Internal as Internal +import qualified Dhall.Syntax as Syntax +import qualified Prettyprinter as Pretty {-| This type is a `Doc` enriched with a `same` flag to efficiently track if any difference was detected diff --git a/src/Dhall/DirectoryTree.hs b/src/Dhall/DirectoryTree.hs --- a/src/Dhall/DirectoryTree.hs +++ b/src/Dhall/DirectoryTree.hs @@ -16,16 +16,16 @@ import Dhall.Syntax (Chunks (..), Expr (..), RecordField (..)) import System.FilePath (()) -import qualified Control.Exception as Exception -import qualified Data.Foldable as Foldable -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty -import qualified Dhall.Map as Map +import qualified Control.Exception as Exception +import qualified Data.Foldable as Foldable +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Map as Map import qualified Dhall.Pretty -import qualified Dhall.Util as Util -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath +import qualified Dhall.Util as Util +import qualified Prettyprinter.Render.String as Pretty +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath {-| Attempt to transform a Dhall record into a directory tree where: diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -52,7 +52,7 @@ import Data.Bifunctor (first) import Data.Foldable (foldr', toList) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Sequence (Seq, ViewL (..), ViewR (..)) import Data.Text (Text) import Data.Void (Void) diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -14,11 +14,7 @@ import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) -import Dhall.Pretty - ( CharacterSet - , annToAnsiStyle - , detectCharacterSet - ) +import Dhall.Pretty (CharacterSet, annToAnsiStyle, detectCharacterSet) import Dhall.Util ( Censor , CheckFailed (..) @@ -30,13 +26,13 @@ ) import qualified Data.Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Import import qualified Dhall.Pretty import qualified Dhall.Util -import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty.Terminal +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.FilePath import qualified System.IO diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -42,19 +42,19 @@ ) import System.Console.ANSI (hSupportsANSI) -import qualified Control.Exception as Exception -import qualified Control.Monad.Trans.State.Strict as State -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text -import qualified Dhall.Core as Core +import qualified Control.Exception as Exception +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core import qualified Dhall.Import import qualified Dhall.Optics import qualified Dhall.Pretty import qualified Dhall.TypeCheck -import qualified Dhall.Util as Util -import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText +import qualified Dhall.Util as Util +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.FilePath import qualified System.IO diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -108,7 +108,7 @@ load , loadWithManager , loadRelativeTo - , loadRelativeToWithManager + , loadWithStatus , loadWith , localToPath , hashExpression @@ -126,8 +126,11 @@ , chainedChangeMode , emptyStatus , emptyStatusWithManager + , envOriginHeaders + , makeEmptyStatus , remoteStatus , remoteStatusWithManager + , fetchRemote , stack , cache , Depends(..) @@ -152,24 +155,24 @@ , HashMismatch(..) ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception ( Exception , IOException , SomeException , toException ) -import Control.Monad.Catch (MonadCatch (catch), handle, throwM) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Morph (hoist) -import Control.Monad.State.Strict (MonadState, StateT) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) -import Data.Typeable (Typeable) -import Data.Void (Void, absurd) -import Dhall.TypeCheck (TypeError) +import Control.Monad.Catch (MonadCatch (catch), handle, throwM) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Morph (hoist) +import Control.Monad.State.Strict (MonadState, StateT) +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Void (Void, absurd) +import Dhall.TypeCheck (TypeError) import Dhall.Syntax ( Chunks (..) @@ -188,10 +191,17 @@ ) import System.FilePath (()) +import Text.Megaparsec (SourcePos (SourcePos), mkPos) #ifdef WITH_HTTP import Dhall.Import.HTTP #endif +import Dhall.Import.Headers + ( normalizeHeaders + , originHeadersTypeExpr + , toHeaders + , toOriginHeaders + ) import Dhall.Import.Types import Dhall.Parser @@ -209,12 +219,9 @@ import qualified Control.Monad.Trans.Maybe as Maybe import qualified Data.ByteString import qualified Data.ByteString.Lazy -import qualified Data.CaseInsensitive -import qualified Data.Foldable import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe import qualified Data.Text as Text -import qualified Data.Text.Encoding import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core as Core @@ -229,8 +236,8 @@ import qualified System.Directory as Directory import qualified System.Environment import qualified System.FilePath as FilePath -import qualified System.Info import qualified System.IO +import qualified System.Info import qualified Text.Megaparsec import qualified Text.Parser.Combinators import qualified Text.Parser.Token @@ -286,7 +293,7 @@ instance Show ReferentiallyOpaque where show (ReferentiallyOpaque import_) = - "\nReferentially opaque import: " ++ Dhall.Pretty.Internal.prettyToString import_ + "\nLocal imports are not permitted from remote imports: " ++ Dhall.Pretty.Internal.prettyToString import_ -- | Extend another exception with the current import stack data Imported e = Imported @@ -355,9 +362,6 @@ throwMissingImport :: (MonadCatch m, Exception e) => e -> m a throwMissingImport e = throwM (MissingImports [toException e]) --- | HTTP headers -type HTTPHeader = (CI ByteString, ByteString) - -- | Exception thrown when a HTTP url is imported but dhall was built without -- the @with-http@ Cabal flag. data CannotImportHTTPURL = @@ -501,7 +505,7 @@ -- | Chain imports, also typecheck and normalize headers if applicable. chainImport :: Chained -> Import -> StateT Status IO Chained chainImport (Chained parent) child@(Import importHashed@(ImportHashed _ (Remote url)) _) = do - url' <- normalizeHeaders url + url' <- normalizeHeadersIn url let child' = child { importHashed = importHashed { importType = Remote url' } } return (Chained (canonicalize (parent <> child'))) @@ -786,7 +790,7 @@ fetchFresh Missing = throwM (MissingImports []) - +-- | Fetch the text contents of a URL fetchRemote :: URL -> StateT Status IO Data.Text.Text #ifndef WITH_HTTP fetchRemote (url@URL { headers = maybeHeadersExpression }) = do @@ -805,29 +809,6 @@ fetchFromHttpUrl url' maybeHeaders #endif --- | Given a well-typed (of type `List { header : Text, value Text }` or --- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form --- construct the corresponding binary http headers; otherwise return the empty --- list. -toHeaders :: Expr s a -> [HTTPHeader] -toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders) - where - maybeHeaders = mapM toHeader hs -toHeaders _ = [] - -toHeader :: Expr s a -> Maybe HTTPHeader -toHeader (RecordLit m) = do - (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> TextLit (Chunks [] valueText)) - <- lookupHeader <|> lookupMapKey - let keyBytes = Data.Text.Encoding.encodeUtf8 keyText - let valueBytes = Data.Text.Encoding.encodeUtf8 valueText - return (Data.CaseInsensitive.mk keyBytes, valueBytes) - where - lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m) - lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) -toHeader _ = - empty - getCacheFile :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m) => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath @@ -1019,62 +1000,102 @@ -- If the URL contains headers typecheck them and replace them with their normal -- forms. -normalizeHeaders :: URL -> StateT Status IO URL -normalizeHeaders url@URL { headers = Just headersExpression } = do +normalizeHeadersIn :: URL -> StateT Status IO URL +normalizeHeadersIn url@URL { headers = Just headersExpression } = do Status { _stack } <- State.get loadedExpr <- loadWith headersExpression + let handler (e :: SomeException) = throwMissingImport (Imported _stack e) + normalized <- liftIO $ handle handler (normalizeHeaders loadedExpr) + return url { headers = Just (fmap absurd normalized) } - let go key₀ key₁ = do - let expected :: Expr Src Void - expected = - App List - ( Record $ Core.makeRecordField <$> - Dhall.Map.fromList - [ (key₀, Text) - , (key₁, Text) - ] - ) +normalizeHeadersIn url = return url - let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected - let annot = case loadedExpr of - Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot loadedExpr expected) - where - bytes' = bytes <> " : " <> suffix_ - _ -> - Annot loadedExpr expected +-- | Empty origin headers used for remote contexts +-- (and fallback when nothing is set in env or config file) +emptyOriginHeaders :: Expr Src Import +emptyOriginHeaders = ListLit (Just (fmap absurd originHeadersTypeExpr)) mempty - _ <- case (Dhall.TypeCheck.typeOf annot) of - Left err -> throwMissingImport (Imported _stack err) - Right _ -> return () +-- | A fake Src to annotate headers expressions with. +-- We need to wrap headers expressions in a Note for nice error reporting, +-- and because ImportAlt handling only catches SourcedExceptions +headersSrc :: Src +headersSrc = Src { + srcStart = SourcePos { + sourceName = fakeSrcName, + sourceLine = mkPos 1, + sourceColumn = mkPos 1 + }, + srcEnd = SourcePos { + sourceName = fakeSrcName, + sourceLine = mkPos 1, + sourceColumn = mkPos (Text.length fakeSrcText) + }, + srcText = fakeSrcText + } + where + fakeSrcText = "«Origin Header Configuration»" + fakeSrcName = "[builtin]" - return (Core.normalize loadedExpr) +-- | Load headers only from the environment (used in tests) +envOriginHeaders :: Expr Src Import +envOriginHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) Code)) - let handler₀ (e :: SomeException) = do - {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields - and fall back to @header@/@value@ if that fails. However, if - @header@/@value@ still fails then re-throw the original exception - for @mapKey@ / @mapValue@. -} - let handler₁ (_ :: SomeException) = - throwMissingImport (Imported _stack e) +-- | Load headers in env, falling back to config file +defaultOriginHeaders :: IO (Expr Src Import) +#ifndef WITH_HTTP +defaultOriginHeaders = return emptyOriginHeaders +#else +defaultOriginHeaders = do + fromFile <- originHeadersFileExpr + return (Note headersSrc (ImportAlt envOriginHeaders (Note headersSrc fromFile))) +#endif - handle handler₁ (go "header" "value") +-- | Given a headers expression, return an origin headers loader +originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders +originHeadersLoader headersExpr = do - headersExpression' <- - handle handler₀ (go "mapKey" "mapValue") + -- Load the headers using the parent stack, which should always be a local + -- import (we only load headers for the first remote import) - return url { headers = Just (fmap absurd headersExpression') } + status <- State.get -normalizeHeaders url = return url + let parentStack = fromMaybe abortEmptyStack (nonEmpty (NonEmpty.tail (_stack status))) + let headerLoadStatus = status { _stack = parentStack } + + (headers, _) <- liftIO (State.runStateT doLoad headerLoadStatus) + + -- return cached headers next time + _ <- State.modify (\state -> state { _loadOriginHeaders = return headers }) + + return headers + where + abortEmptyStack = Core.internalError "Origin headers loaded with an empty stack" + + doLoad = do + partialExpr <- liftIO headersExpr + loaded <- loadWith (Note headersSrc (ImportAlt partialExpr emptyOriginHeaders)) + liftIO (toOriginHeaders loaded) + -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = emptyStatusWithManager defaultNewManager +emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders +-- | See 'emptyStatus' +emptyStatusWithManager + :: IO Manager + -> FilePath + -> Status +emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders + -- | See 'emptyStatus'. -emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager rootDirectory = - emptyStatusWith newManager fetchRemote rootImport +makeEmptyStatus + :: IO Manager + -> IO (Expr Src Import) + -> FilePath + -> Status +makeEmptyStatus newManager headersExpr rootDirectory = + emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1107,7 +1128,7 @@ -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager fetchRemote rootImport + emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) fetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1205,7 +1226,10 @@ -- | See 'load'. loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) -loadWithManager newManager = loadRelativeToWithManager newManager "." UseSemanticCache +loadWithManager newManager = + loadWithStatus + (makeEmptyStatus newManager defaultOriginHeaders ".") + UseSemanticCache printWarning :: (MonadIO m) => String -> m () printWarning message = do @@ -1219,19 +1243,19 @@ -- | Resolve all imports within an expression, importing relative to the given -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeTo = loadRelativeToWithManager defaultNewManager +loadRelativeTo parentDirectory = loadWithStatus + (makeEmptyStatus defaultNewManager defaultOriginHeaders parentDirectory) -- | See 'loadRelativeTo'. -loadRelativeToWithManager - :: IO Manager - -> FilePath +loadWithStatus + :: Status -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeToWithManager newManager rootDirectory semanticCacheMode expression = +loadWithStatus status semanticCacheMode expression = State.evalStateT (loadWith expression) - (emptyStatusWithManager newManager rootDirectory) { _semanticCacheMode = semanticCacheMode } + status { _semanticCacheMode = semanticCacheMode } encodeExpression :: Expr Void Void -> Data.ByteString.ByteString encodeExpression expression = bytesStrict diff --git a/src/Dhall/Import/Headers.hs b/src/Dhall/Import/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Import/Headers.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Dhall.Import.Headers + ( normalizeHeaders + , originHeadersTypeExpr + , toHeaders + , toOriginHeaders + ) where + +import Control.Applicative (Alternative (..), liftA2) +import Control.Exception (SomeException) +import Control.Monad.Catch (handle, throwM) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core + ( Chunks (..) + , Expr (..) + ) +import Dhall.Import.Types (HTTPHeader , OriginHeaders) +import Dhall.Parser (Src (..)) + +import qualified Data.CaseInsensitive +import qualified Data.Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.Encoding +import qualified Dhall.Core as Core +import qualified Dhall.Map +import qualified Dhall.TypeCheck +import qualified Dhall.Pretty.Internal + +-- | Given a well-typed (of type `List { header : Text, value Text }` or +-- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form +-- construct the corresponding binary http headers; otherwise return the empty +-- list. +toHeaders :: Expr s a -> [HTTPHeader] +toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders) + where + maybeHeaders = mapM toHeader hs +toHeaders _ = [] + +toHeader :: Expr s a -> Maybe HTTPHeader +toHeader (RecordLit m) = do + (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> TextLit (Chunks [] valueText)) + <- lookupHeader <|> lookupMapKey + let keyBytes = Data.Text.Encoding.encodeUtf8 keyText + let valueBytes = Data.Text.Encoding.encodeUtf8 valueText + return (Data.CaseInsensitive.mk keyBytes, valueBytes) + where + lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m) + lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) +toHeader _ = + empty + +-- | Normalize, typecheck and return OriginHeaders from a given expression. +toOriginHeaders :: Expr Src Void -> IO OriginHeaders +toOriginHeaders expr = fmap convert (normalizeOriginHeaders expr) + where + convert :: Expr s a -> OriginHeaders + convert (ListLit _ hs) = HashMap.fromList (originPairs hs) + convert _ = mempty + + originPairs hs = Data.Foldable.toList (Data.Foldable.fold (mapM toOriginPair hs)) + + toOriginPair :: Expr s a -> Maybe (Text, [HTTPHeader]) + toOriginPair (RecordLit m) = do + (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> value) + <- lookupMapKey + return (keyText, toHeaders value) + where + lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) + toOriginPair _ = Nothing + +makeHeadersTypeExpr :: Text -> Text -> Expr Src Void +makeHeadersTypeExpr keyKey valueKey = + App List + ( Record $ Core.makeRecordField <$> + Dhall.Map.fromList + [ (keyKey, Text) + , (valueKey, Text) + ] + ) + +headersTypeExpr :: Expr Src Void +headersTypeExpr = makeHeadersTypeExpr "mapKey" "mapValue" + +leagacyHeadersTypeExpr :: Expr Src Void +leagacyHeadersTypeExpr = makeHeadersTypeExpr "header" "value" + +originHeadersTypeExpr :: Expr Src Void +originHeadersTypeExpr = + App List + ( Record $ Core.makeRecordField <$> + Dhall.Map.fromList + [ ("mapKey", Text) + , ("mapValue", headersTypeExpr) + ] + ) + +typecheck :: Expr Src Void -> Expr Src Void -> IO (Expr Src Void) +typecheck expected expr = do + let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected + let annot = case expr of + Note (Src begin end bytes) _ -> + Note (Src begin end bytes') (Annot expr expected) + where + bytes' = bytes <> " : " <> suffix_ + _ -> + Annot expr expected + + _ <- case (Dhall.TypeCheck.typeOf annot) of + Left err -> throwM err + Right _ -> return () + + return (Core.normalize expr) + +normalizeHeaders :: Expr Src Void -> IO (Expr Src Void) +normalizeHeaders headersExpr = do + let handler₀ (e :: SomeException) = do + {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields + and fall back to @header@/@value@ if that fails. However, if + @header@/@value@ still fails then re-throw the original exception + for @mapKey@ / @mapValue@. -} + let handler₁ (_ :: SomeException) = throwM e + handle handler₁ (typecheck leagacyHeadersTypeExpr headersExpr) + + handle handler₀ (typecheck headersTypeExpr headersExpr) + +normalizeOriginHeaders :: Expr Src Void -> IO (Expr Src Void) +normalizeOriginHeaders = typecheck originHeadersTypeExpr 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 @@ -8,9 +8,11 @@ import Control.Exception (Exception) import Control.Monad.Trans.State.Strict (StateT) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) import Data.Dynamic +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty) -import Data.Text.Prettyprint.Doc (Pretty (..)) import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core @@ -22,6 +24,7 @@ import Dhall.Map (Map) import Dhall.Parser (Src) import Lens.Family (LensLike') +import Prettyprinter (Pretty (..)) #ifdef WITH_HTTP import qualified Dhall.Import.Manager @@ -77,6 +80,12 @@ pure () #endif +-- | HTTP headers +type HTTPHeader = (CI ByteString, ByteString) + +-- | A map of site origin -> HTTP headers +type OriginHeaders = HashMap Data.Text.Text [HTTPHeader] + {-| Used internally to track whether or not we've already warned the user about caching issues -} @@ -101,6 +110,10 @@ -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests + , _loadOriginHeaders :: StateT Status IO OriginHeaders + -- ^ Load the origin headers from environment or configuration file. + -- After loading once, further evaluations return the cached version. + , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. @@ -117,14 +130,16 @@ -- cache directory } --- | Initial `Status`, parameterised over the HTTP 'Manager' and the remote --- resolver, importing relative to the given root import. +-- | Initial `Status`, parameterised over the HTTP 'Manager', +-- the origin headers and the remote resolver, +-- importing relative to the given root import. emptyStatusWith :: IO Manager + -> StateT Status IO OriginHeaders -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status -emptyStatusWith _newManager _remote rootImport = Status {..} +emptyStatusWith _newManager _loadOriginHeaders _remote rootImport = Status {..} where _stack = pure (Chained rootImport) diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -19,7 +19,7 @@ ) where import Control.Applicative ((<|>)) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty (..)) import Dhall.Syntax ( Binding (..) diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -21,35 +21,36 @@ , main ) where -import Control.Applicative (optional, (<|>)) -import Control.Exception (Handler (..), SomeException) -import Control.Monad (when) -import Data.Foldable (for_) -import Data.Maybe (fromMaybe) -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Data.Void (Void) -import Dhall.Freeze (Intent (..), Scope (..)) +import Control.Applicative (optional, (<|>)) +import Control.Exception (Handler (..), SomeException) +import Control.Monad (when) +import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Freeze (Intent (..), Scope (..)) import Dhall.Import ( Depends (..) , Imported (..) , SemanticCacheMode (..) , _semanticCacheMode ) -import Dhall.Parser (Src) -import Dhall.Pretty (Ann, CharacterSet (..), annToAnsiStyle, detectCharacterSet) -import Dhall.Schemas (Schemas (..)) -import Dhall.TypeCheck - ( Censored (..) - , DetailedTypeError (..) - , TypeError +import Dhall.Parser (Src) +import Dhall.Pretty + ( Ann + , CharacterSet (..) + , annToAnsiStyle + , detectCharacterSet ) -import Dhall.Version (dhallVersionString) -import Options.Applicative (Parser, ParserInfo) -import System.Exit (ExitCode, exitFailure) -import System.IO (Handle) -import Text.Dot ((.->.)) +import Dhall.Schemas (Schemas (..)) +import Dhall.TypeCheck (Censored (..), DetailedTypeError (..), TypeError) +import Dhall.Version (dhallVersionString) +import Options.Applicative (Parser, ParserInfo) +import Prettyprinter (Doc, Pretty) +import System.Exit (ExitCode, exitFailure) +import System.IO (Handle) +import Text.Dot ((.->.)) import Dhall.Core ( Expr (Annot) @@ -74,7 +75,7 @@ import qualified Codec.CBOR.Read import qualified Codec.CBOR.Write import qualified Control.Exception -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.State.Strict as State import qualified Data.Aeson import qualified Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy @@ -82,14 +83,11 @@ import qualified Data.Map import qualified Data.Text import qualified Data.Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall import qualified Dhall.Binary import qualified Dhall.Core import qualified Dhall.Diff -import qualified Dhall.DirectoryTree as DirectoryTree +import qualified Dhall.DirectoryTree as DirectoryTree import qualified Dhall.Format import qualified Dhall.Freeze import qualified Dhall.Import @@ -104,9 +102,12 @@ import qualified Dhall.Util import qualified GHC.IO.Encoding import qualified Options.Applicative -import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI -import qualified System.Exit as Exit +import qualified System.Exit as Exit import qualified System.FilePath import qualified System.IO import qualified Text.Dot diff --git a/src/Dhall/Marshal/Decode.hs b/src/Dhall/Marshal/Decode.hs --- a/src/Dhall/Marshal/Decode.hs +++ b/src/Dhall/Marshal/Decode.hs @@ -56,6 +56,13 @@ , string , lazyText , strictText + -- ** Time + , timeOfDay + , day + , timeZone + , localTime + , zonedTime + , utcTime -- ** Containers , maybe , pair @@ -86,6 +93,7 @@ , GenericFromDhallUnion(..) , genericAuto , genericAutoWith + , genericAutoWithInputNormalizer -- * Decoding errors , DhallErrors(..) @@ -132,11 +140,14 @@ , eitherToValidation , validationToEither ) -import Data.Functor.Contravariant (Op(..), Predicate(..), Equivalence(..)) +import Data.Functor.Contravariant + ( Equivalence (..) + , Op (..) + , Predicate (..) + ) import Data.Hashable (Hashable) import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text.Prettyprint.Doc (Pretty) import Data.Typeable (Proxy (..), Typeable) import Dhall.Parser (Src (..)) import Dhall.Syntax @@ -148,6 +159,7 @@ ) import GHC.Generics import Prelude hiding (maybe, sequence) +import Prettyprinter (Pretty) import qualified Control.Applicative import qualified Data.Foldable @@ -164,6 +176,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Lazy +import qualified Data.Time as Time import qualified Data.Vector import qualified Dhall.Core as Core import qualified Dhall.Map @@ -212,8 +225,8 @@ implement `Generic`. This does not auto-generate an instance for recursive types. - The default instance can be tweaked using 'genericAutoWith' and custom - 'InterpretOptions', or using + The default instance can be tweaked using 'genericAutoWith'/'genericAutoWithInputNormalizer' + and custom 'InterpretOptions', or using [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} @@ -308,6 +321,24 @@ instance FromDhall a => FromDhall (Vector a) where autoWith opts = vector (autoWith opts) +instance FromDhall Time.TimeOfDay where + autoWith _ = timeOfDay + +instance FromDhall Time.Day where + autoWith _ = day + +instance FromDhall Time.TimeZone where + autoWith _ = timeZone + +instance FromDhall Time.LocalTime where + autoWith _ = localTime + +instance FromDhall Time.ZonedTime where + autoWith _ = zonedTime + +instance FromDhall Time.UTCTime where + autoWith _ = utcTime + {-| Note that this instance will throw errors in the presence of duplicates in the list. To ignore duplicates, use `setIgnoringDuplicates`. -} @@ -669,7 +700,13 @@ {-| `genericAutoWith` is a configurable version of `genericAuto`. -} genericAutoWith :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> Decoder a -genericAutoWith options = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p defaultInputNormalizer options) 1)) +genericAutoWith options = genericAutoWithInputNormalizer options defaultInputNormalizer + +{-| `genericAutoWithInputNormalizer` is like `genericAutoWith`, but instead of + using the `defaultInputNormalizer` it expects an custom `InputNormalizer`. +-} +genericAutoWithInputNormalizer :: (Generic a, GenericFromDhall a (Rep a)) => InterpretOptions -> InputNormalizer -> Decoder a +genericAutoWithInputNormalizer options inputNormalizer = withProxy (\p -> fmap to (evalState (genericAutoWithNormalizer p inputNormalizer options) 1)) where withProxy :: (Proxy a -> Decoder a) -> Decoder a withProxy f = f Proxy @@ -892,6 +929,78 @@ extract expr = typeError expected expr expected = pure Text + +{-| Decode `Time.TimeOfDay` + +>>> input timeOfDay "00:00:00" +00:00:00 +-} +timeOfDay :: Decoder Time.TimeOfDay +timeOfDay = Decoder {..} + where + extract (TimeLiteral t _) = pure t + extract expr = typeError expected expr + + expected = pure Time + +{-| Decode `Time.Day` + +>>> input day "2000-01-01" +2000-01-01 +-} +day :: Decoder Time.Day +day = Decoder {..} + where + extract (DateLiteral d) = pure d + extract expr = typeError expected expr + + expected = pure Date + +{-| Decode `Time.TimeZone` + +>>> input timeZone "+00:00" ++0000 +-} +timeZone :: Decoder Time.TimeZone +timeZone = Decoder {..} + where + extract (TimeZoneLiteral z) = pure z + extract expr = typeError expected expr + + expected = pure TimeZone + +{-| Decode `Time.LocalTime` + +>>> input localTime "2020-01-01T12:34:56" +2020-01-01 12:34:56 +-} +localTime :: Decoder Time.LocalTime +localTime = record $ + Time.LocalTime + <$> field "date" day + <*> field "time" timeOfDay + +{-| Decode `Time.ZonedTime` + +>>> input zonedTime "2020-01-01T12:34:56+02:00" +2020-01-01 12:34:56 +0200 +-} +zonedTime :: Decoder Time.ZonedTime +zonedTime = record $ + adapt + <$> field "date" day + <*> field "time" timeOfDay + <*> field "timeZone" timeZone + where + adapt date time = Time.ZonedTime (Time.LocalTime date time) + +{-| Decode `Time.UTCTime` + +>>> input utcTime "2020-01-01T12:34:56+02:00" +2020-01-01 10:34:56 UTC +-} +utcTime :: Decoder Time.UTCTime +utcTime = Time.zonedTimeToUTC <$> zonedTime {-| Decode a `Maybe`. diff --git a/src/Dhall/Marshal/Encode.hs b/src/Dhall/Marshal/Encode.hs --- a/src/Dhall/Marshal/Encode.hs +++ b/src/Dhall/Marshal/Encode.hs @@ -41,6 +41,7 @@ , GenericToDhall(..) , genericToDhall , genericToDhallWith + , genericToDhallWithInputNormalizer , InterpretOptions(..) , SingletonConstructors(..) , defaultInterpretOptions @@ -82,6 +83,7 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Lazy +import qualified Data.Time as Time import qualified Data.Vector import qualified Data.Void import qualified Dhall.Core as Core @@ -126,8 +128,8 @@ implement `Generic`. This does not auto-generate an instance for recursive types. - The default instance can be tweaked using 'genericToDhallWith' and custom - 'InterpretOptions', or using + The default instance can be tweaked using 'genericToDhallWith'/'genericToDhallWithInputNormalizer' + and custom 'InterpretOptions', or using [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} @@ -311,6 +313,47 @@ instance ToDhall a => ToDhall (Vector a) where injectWith = fmap (contramap Data.Vector.toList) injectWith +instance ToDhall Time.TimeOfDay where + injectWith _ = Encoder {..} + where + embed timeOfDay = TimeLiteral timeOfDay 12 + + declared = Time + +instance ToDhall Time.Day where + injectWith _ = Encoder {..} + where + embed = DateLiteral + + declared = Date + +instance ToDhall Time.TimeZone where + injectWith _ = Encoder {..} + where + embed = TimeZoneLiteral + + declared = TimeZone + +instance ToDhall Time.LocalTime where + injectWith _ = recordEncoder $ + adapt + >$< encodeField "date" + >*< encodeField "time" + where + adapt (Time.LocalTime date time) = (date, time) + +instance ToDhall Time.ZonedTime where + injectWith _ = recordEncoder $ + adapt + >$< encodeField "date" + >*< encodeField "time" + >*< encodeField "timeZone" + where + adapt (Time.ZonedTime (Time.LocalTime date time) timeZone) = (date, (time, timeZone)) + +instance ToDhall Time.UTCTime where + injectWith = contramap (Time.utcToZonedTime Time.utc) . injectWith + {-| Note that the output list will be sorted. >>> let x = Data.Set.fromList ["mom", "hi" :: Text] @@ -703,8 +746,16 @@ -} genericToDhallWith :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a -genericToDhallWith options - = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer defaultInputNormalizer options) 1) +genericToDhallWith options = genericToDhallWithInputNormalizer options defaultInputNormalizer + +{-| `genericToDhallWithInputNormalizer` is like `genericToDhallWith`, but + instead of using the `defaultInputNormalizer` it expects an custom + `InputNormalizer`. +-} +genericToDhallWithInputNormalizer + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> InputNormalizer -> Encoder a +genericToDhallWithInputNormalizer options inputNormalizer + = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer inputNormalizer options) 1) diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -23,7 +23,7 @@ import Control.Applicative (empty) import Data.Foldable import Data.Functor.Identity (Identity (..)) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Sequence (ViewL (..), ViewR (..)) import Data.Traversable import Instances.TH.Lift () diff --git a/src/Dhall/Optics.hs b/src/Dhall/Optics.hs --- a/src/Dhall/Optics.hs +++ b/src/Dhall/Optics.hs @@ -20,7 +20,7 @@ import Control.Applicative (Const (..), WrappedMonad (..)) import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Profunctor (Profunctor (dimap)) -import Data.Profunctor.Unsafe (( #. )) +import Data.Profunctor.Unsafe ((#.)) import Lens.Family (ASetter, LensLike, LensLike', over) -- | Identical to @"Control.Lens".`Control.Lens.rewriteOf`@ diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | This module contains Dhall's parsing logic 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 @@ -23,24 +23,24 @@ ) where -import Control.Applicative (Alternative (..), liftA2) -import Control.Exception (Exception) -import Control.Monad (MonadPlus (..)) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty (..)) -import Data.Void (Void) -import Dhall.Map (Map) -import Dhall.Src (Src (..)) -import Text.Parser.Combinators (try, ()) -import Text.Parser.Token (TokenParsing (..)) +import Control.Applicative (Alternative (..), liftA2) +import Control.Exception (Exception) +import Control.Monad (MonadPlus (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Map (Map) +import Dhall.Src (Src (..)) +import Prettyprinter (Pretty (..)) +import Text.Parser.Combinators (try, ()) +import Text.Parser.Token (TokenParsing (..)) import qualified Control.Monad.Fail -import qualified Data.Char as Char +import qualified Data.Char as Char import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty import qualified Dhall.Map import qualified Dhall.Pretty +import qualified Prettyprinter.Render.String as Pretty import qualified Text.Megaparsec import qualified Text.Megaparsec.Char import qualified Text.Parser.Char @@ -136,13 +136,7 @@ -- {-# INLINE mplus #-} instance Text.Megaparsec.MonadParsec Void Text Parser where -#if MIN_VERSION_megaparsec(8, 0, 0) parseError e = Parser (Text.Megaparsec.parseError e) -#else - failure u e = Parser (Text.Megaparsec.failure u e) - - fancyFailure e = Parser (Text.Megaparsec.fancyFailure e) -#endif label l (Parser p) = Parser (Text.Megaparsec.label l p) 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 @@ -8,7 +8,6 @@ module Dhall.Parser.Expression where import Control.Applicative (Alternative (..), liftA2, optional) -import Data.ByteArray.Encoding (Base (..)) import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) @@ -19,8 +18,7 @@ import qualified Control.Monad import qualified Control.Monad.Combinators as Combinators import qualified Control.Monad.Combinators.NonEmpty as Combinators.NonEmpty -import qualified Data.ByteArray.Encoding -import qualified Data.ByteString +import qualified Data.ByteString.Base16 as Base16 import qualified Data.Char as Char import qualified Data.List import qualified Data.List.NonEmpty as NonEmpty @@ -107,6 +105,7 @@ data Parsers a = Parsers { completeExpression_ :: Parser (Expr Src a) , importExpression_ :: Parser (Expr Src a) + , letBinding :: Parser (Binding Src a) } {-| Parse a numeric `TimeZone` @@ -237,10 +236,14 @@ -- | Given a parser for imports, parsers :: forall a. Parser a -> Parsers a -parsers embedded = Parsers {..} +parsers embedded = Parsers{..} where completeExpression_ = - many shebang *> whitespace *> expression <* whitespace + many shebang + *> whitespace + *> expression + <* whitespace + <* optional lineCommentPrefix shebang = do _ <- text "#!" @@ -251,6 +254,34 @@ endOfLine + letBinding = do + src0 <- try (_let *> src nonemptyWhitespace) + + c <- label + + src1 <- src whitespace + + d <- optional (do + _colon + + src2 <- src nonemptyWhitespace + + e <- expression + + whitespace + + return (Just src2, e) ) + + _equal + + src3 <- src whitespace + + f <- expression + + whitespace + + return (Binding (Just src0) c (Just src1) d (Just src3) f) + expression = noted ( choice @@ -293,35 +324,7 @@ return (BoolIf a b c) alternative2 = do - let binding = do - src0 <- try (_let *> src nonemptyWhitespace) - - c <- label - - src1 <- src whitespace - - d <- optional (do - _colon - - src2 <- src nonemptyWhitespace - - e <- expression - - whitespace - - return (Just src2, e) ) - - _equal - - src3 <- src whitespace - - f <- expression - - whitespace - - return (Binding (Just src0) c (Just src1) d (Just src3) f) - - as <- NonEmpty.some1 binding + as <- NonEmpty.some1 letBinding try (_in *> nonemptyWhitespace) @@ -413,15 +416,15 @@ nonemptyWhitespace case (shallowDenote a, a0Info) of (ListLit Nothing [], _) -> do - b <- applicationExpression + b <- expression return (ListLit (Just b) []) (Merge c d Nothing, NakedMergeOrSomeOrToMap) -> do - b <- applicationExpression + b <- expression return (Merge c d (Just b)) (ToMap c Nothing, NakedMergeOrSomeOrToMap) -> do - b <- applicationExpression + b <- expression return (ToMap c (Just b)) _ -> do @@ -1063,8 +1066,6 @@ let emptyUnionType = do try (optional (_bar *> whitespace) *> _closeAngle) - _ <- optional (_bar *> whitespace) - return (Union mempty) nonEmptyUnionType <|> emptyUnionType ) "literal" @@ -1197,9 +1198,9 @@ _ <- text "sha256:" t <- count 64 (satisfy hexdig "hex digit") let strictBytes16 = Data.Text.Encoding.encodeUtf8 t - strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of + strictBytes <- case Base16.decode strictBytes16 of Left string -> fail string - Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) + Right strictBytes -> return strictBytes case Dhall.Crypto.sha256DigestFromByteString strictBytes of Nothing -> fail "Invalid sha256 hash" Just h -> pure h 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 @@ -8,6 +8,7 @@ validCodepoint, whitespace, lineComment, + lineCommentPrefix, blockComment, nonemptyWhitespace, bashEnvironmentVariable, @@ -464,19 +465,22 @@ where predicate c = 'a' <= c && c <= 'f' --- | Parse a Dhall's single-line comment, starting from `--` and until the --- last character of the line /before/ the end-of-line character -lineComment :: Parser Text -lineComment = do +-- | Same as `lineComment` except that this doesn't parse the end-of-line +-- character +lineCommentPrefix :: Parser Text +lineCommentPrefix = do _ <- text "--" let predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' commentText <- Dhall.Parser.Combinators.takeWhile predicate - _ <- endOfLine - return ("--" <> commentText) + +-- | Parse a Dhall's single-line comment, starting from `--` and until the +-- last character of the line /before/ the end-of-line character +lineComment :: Parser Text +lineComment = try (lineCommentPrefix <* endOfLine) -- | Parsed text doesn't include opening braces blockComment :: Parser Text 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 @@ -79,7 +79,6 @@ import Data.Foldable import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty, space) import Dhall.Map (Map) import Dhall.Optics (cosmosOf, foldOf, to) import Dhall.Src (Src (..)) @@ -87,20 +86,21 @@ import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Lift) import Numeric.Natural (Natural) +import Prettyprinter (Doc, Pretty, space) import qualified Data.Char import qualified Data.HashSet -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe -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 Data.Time as Time -import qualified Dhall.Map as Map -import qualified Text.Printf as Printf +import qualified Data.Text as Text +import qualified Data.Time as Time +import qualified Dhall.Map as Map +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.String as Pretty +import qualified Prettyprinter.Render.Terminal as Terminal +import qualified Prettyprinter.Render.Text as Pretty +import qualified Text.Printf as Printf {-| Annotation type used to tag elements in a pretty-printed document for syntax highlighting purposes @@ -861,7 +861,7 @@ <> Pretty.indent 2 (prettyImportExpression_ b) <> Pretty.hardline <> colon <> space - <> prettyApplicationExpression c + <> prettyExpression c ) short = keyword "merge" <> space @@ -869,7 +869,7 @@ <> " " <> prettyImportExpression_ b <> space <> colon <> space - <> prettyApplicationExpression c + <> prettyExpression c prettyAnnotatedExpression (ToMap a (Just b)) = Pretty.group (Pretty.flatAlt long short) where @@ -880,13 +880,13 @@ <> Pretty.indent 2 (prettyImportExpression_ a) <> Pretty.hardline <> colon <> space - <> prettyApplicationExpression b + <> prettyExpression b ) short = keyword "toMap" <> space <> prettyImportExpression_ a <> space <> colon <> space - <> prettyApplicationExpression b + <> prettyExpression b prettyAnnotatedExpression a0@(Annot _ _) = enclose' "" @@ -906,7 +906,7 @@ prettyAnnotatedExpression (ListLit (Just a) b) = list (map prettyExpression (Data.Foldable.toList b)) <> " : " - <> prettyApplicationExpression a + <> prettyExpression a prettyAnnotatedExpression a | Just doc <- preserveSource a = doc diff --git a/src/Dhall/Pretty/Internal.hs-boot b/src/Dhall/Pretty/Internal.hs-boot --- a/src/Dhall/Pretty/Internal.hs-boot +++ b/src/Dhall/Pretty/Internal.hs-boot @@ -3,7 +3,7 @@ import Control.DeepSeq (NFData) import Data.Data (Data) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty, Doc) +import Prettyprinter (Pretty, Doc) import Dhall.Src (Src) import Language.Haskell.TH.Syntax (Lift) diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -18,9 +18,9 @@ , displayException , throwIO ) -import Control.Monad (forM_) +import Control.Monad (forM_) #if !(MIN_VERSION_base(4,13,0)) -import Control.Monad.Fail (MonadFail) +import Control.Monad.Fail (MonadFail) #endif import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Class (MonadState, get, modify) @@ -45,35 +45,36 @@ import System.Directory (getDirectoryContents) import System.Environment (getEnvironment) -import qualified Control.Monad.Fail as Fail -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Fail as Fail +import qualified Control.Monad.Trans.State.Strict as State import qualified Data.HashSet -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty (renderIO) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified Dhall import qualified Dhall.Context import qualified Dhall.Core -import qualified Dhall.Core as Dhall +import qualified Dhall.Core as Dhall ( Expr , Var (V) , normalize ) -import qualified Dhall.Core as Expr (Expr (..)) -import qualified Dhall.Import as Dhall -import qualified Dhall.Map as Map -import qualified Dhall.Parser as Dhall -import qualified Dhall.Parser.Token as Parser.Token +import qualified Dhall.Core as Expr (Expr (..)) +import qualified Dhall.Import as Dhall +import qualified Dhall.Map as Map +import qualified Dhall.Parser as Dhall +import qualified Dhall.Parser.Expression as Parser.Expression import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal -import qualified Dhall.TypeCheck as Dhall -import qualified Dhall.Version as Meta +import qualified Dhall.Syntax as Syntax +import qualified Dhall.TypeCheck as Dhall +import qualified Dhall.Version as Meta +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty (renderIO) import qualified System.Console.ANSI -import qualified System.Console.Haskeline.Completion as Haskeline -import qualified System.Console.Repline as Repline +import qualified System.Console.Haskeline.Completion as Haskeline +import qualified System.Console.Repline as Repline import qualified System.IO -import qualified Text.Megaparsec as Megaparsec +import qualified Text.Megaparsec as Megaparsec #if MIN_VERSION_haskeline(0,8,0) import qualified Control.Monad.Catch @@ -234,31 +235,51 @@ | otherwise = Left (trim str) -addBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => Either String (String, String) -> m () -addBinding (Right (k, src)) = do - varName <- case Megaparsec.parse (unParser Parser.Token.label) "(input)" (Text.pack k) of - Left _ -> Fail.fail "Invalid variable name" - Right varName -> return varName +addBinding :: ( MonadFail m, MonadIO m, MonadState Env m ) => String -> m () +addBinding string = do + let parseBinding = + Parser.Expression.letBinding + (Parser.Expression.parsers + (Megaparsec.try Parser.Expression.import_) + ) - loaded <- parseAndLoad src + let input = "let " <> Text.pack string - t <- typeCheck loaded + Syntax.Binding{ variable, annotation, value } <- case Megaparsec.parse (unParser parseBinding) "(input)" input of + Left _ -> Fail.fail ":let should be of the form `:let x [: T] = y`" + Right binding -> return binding - expr <- normalize loaded + (resolved, bindingType) <- case annotation of + Just (_, unresolvedType) -> do + let annotated = Syntax.Annot value unresolvedType + resolved <- liftIO (Dhall.load annotated) + + _ <- typeCheck resolved + + bindingType <- liftIO (Dhall.load unresolvedType) + + return (resolved, bindingType) + _ -> do + resolved <- liftIO (Dhall.load value) + + bindingType <- typeCheck resolved + + return (resolved, bindingType) + + bindingExpr <- normalize resolved + modify ( \e -> e { envBindings = Dhall.Context.insert - varName - Binding { bindingType = t, bindingExpr = expr } + variable + Binding{ bindingType, bindingExpr } ( envBindings e ) } ) - output ( Expr.Annot ( Expr.Var ( Dhall.V varName 0 ) ) t ) - -addBinding _ = Fail.fail ":let should be of the form `:let x = y`" + output (Expr.Annot (Expr.Var (Dhall.V variable 0)) bindingType) clearBindings :: (MonadFail m, MonadState Env m) => String -> m () clearBindings _ = modify adapt @@ -476,7 +497,7 @@ "let" "IDENTIFIER = EXPRESSION" "Assign an expression to a variable" - (dontCrash . addBinding . parseAssignment) + (dontCrash . addBinding) , HelpOption "clear" "" diff --git a/src/Dhall/Schemas.hs b/src/Dhall/Schemas.hs --- a/src/Dhall/Schemas.hs +++ b/src/Dhall/Schemas.hs @@ -27,34 +27,34 @@ import Dhall.Syntax (Expr (..), Import, Var (..)) import Dhall.Util ( Censor (..) - , MultipleCheckFailed (..) , Header (..) , Input (..) + , MultipleCheckFailed (..) , OutputMode (..) ) -import qualified Control.Exception as Exception +import qualified Control.Exception as Exception import qualified Data.Map -import qualified Data.Maybe as Maybe -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text -import qualified Data.Void as Void -import qualified Dhall.Core as Core -import qualified Dhall.Import as Import -import qualified Dhall.Map as Map -import qualified Dhall.Normalize as Normalize -import qualified Dhall.Optics as Optics -import qualified Dhall.Parser as Parser +import qualified Data.Maybe as Maybe +import qualified Data.Text.IO as Text.IO +import qualified Data.Void as Void +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.Map as Map +import qualified Dhall.Normalize as Normalize +import qualified Dhall.Optics as Optics +import qualified Dhall.Parser as Parser import qualified Dhall.Pretty -import qualified Dhall.Substitution as Substitution -import qualified Dhall.Syntax as Syntax -import qualified Dhall.TypeCheck as TypeCheck -import qualified Dhall.Util as Util -import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite -import qualified System.Console.ANSI as ANSI -import qualified System.IO as IO +import qualified Dhall.Substitution as Substitution +import qualified Dhall.Syntax as Syntax +import qualified Dhall.TypeCheck as TypeCheck +import qualified Dhall.Util as Util +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty.Terminal +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite +import qualified System.Console.ANSI as ANSI +import qualified System.IO as IO -- | Arguments to the @rewrite-with-schemas@ subcommand data Schemas = Schemas diff --git a/src/Dhall/Src.hs b/src/Dhall/Src.hs --- a/src/Dhall/Src.hs +++ b/src/Dhall/Src.hs @@ -15,10 +15,10 @@ import Control.DeepSeq (NFData) import Data.Data (Data) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty (..)) import GHC.Generics (Generic) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..)) +import Prettyprinter (Pretty (..)) import Text.Megaparsec (SourcePos (SourcePos), mkPos, unPos) import {-# SOURCE #-} qualified Dhall.Util diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -46,6 +46,7 @@ -- ** Optics , subExpressions + , subExpressionsWith , unsafeSubExpressions , chunkExprs , bindingExprs @@ -89,39 +90,39 @@ , shift ) where -import Control.DeepSeq (NFData) -import Data.Bifunctor (Bifunctor (..)) -import Data.Bits (xor) -import Data.Data (Data) -import Data.Foldable -import Data.HashSet (HashSet) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Sequence (Seq) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Data.Traversable () -import Data.Void (Void) -import Dhall.Map (Map) +import Control.DeepSeq (NFData) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bits (xor) +import Data.Data (Data) +import Data.Foldable +import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Traversable () +import Data.Void (Void) +import Dhall.Map (Map) import {-# SOURCE #-} Dhall.Pretty.Internal -import Dhall.Src (Src (..)) -import GHC.Generics (Generic) -import Instances.TH.Lift () -import Language.Haskell.TH.Syntax (Lift) -import Numeric.Natural (Natural) -import Unsafe.Coerce (unsafeCoerce) +import Dhall.Src (Src (..)) +import GHC.Generics (Generic) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift) +import Numeric.Natural (Natural) +import Prettyprinter (Doc, Pretty) +import Unsafe.Coerce (unsafeCoerce) import qualified Control.Monad -import qualified Data.Fixed as Fixed +import qualified Data.Fixed as Fixed import qualified Data.HashSet -import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Time as Time +import qualified Data.Time as Time import qualified Dhall.Crypto -import qualified Dhall.Optics as Optics -import qualified Lens.Family as Lens -import qualified Network.URI as URI +import qualified Dhall.Optics as Optics +import qualified Lens.Family as Lens +import qualified Network.URI as URI +import qualified Prettyprinter as Pretty deriving instance Lift Time.Day deriving instance Lift Time.TimeOfDay @@ -371,19 +372,19 @@ RecordField (k <$> s0) (first k value) (k <$> s1) (k <$> s2) second = fmap -{-| Record the label of a function or a function-type expression - -For example, - -> λ({- A -} a {- B -} : {- C -} T) -> e - -will be instantiated as follows: -* @functionBindingSrc0@ corresponds to the @A@ comment -* @functionBindingVariable@ is @a@ -* @functionBindingSrc1@ corresponds to the @B@ comment -* @functionBindingSrc2@ corresponds to the @C@ comment -* @functionBindingAnnotation@ is @T@ --} +-- | Record the label of a function or a function-type expression +-- +-- For example, +-- +-- > λ({- A -} a {- B -} : {- C -} T) -> e +-- +-- … will be instantiated as follows: +-- +-- * @functionBindingSrc0@ corresponds to the @A@ comment +-- * @functionBindingVariable@ is @a@ +-- * @functionBindingSrc1@ corresponds to the @B@ comment +-- * @functionBindingSrc2@ corresponds to the @C@ comment +-- * @functionBindingAnnotation@ is @T@ data FunctionBinding s a = FunctionBinding { functionBindingSrc0 :: Maybe s , functionBindingVariable :: Text @@ -782,15 +783,23 @@ -- | A traversal over the immediate sub-expressions of an expression. subExpressions :: Applicative f => (Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a) -subExpressions _ (Embed a) = pure (Embed a) -subExpressions f (Note a b) = Note a <$> f b -subExpressions f (Let a b) = Let <$> bindingExprs f a <*> f b -subExpressions f (Record a) = Record <$> traverse (recordFieldExprs f) a -subExpressions f (RecordLit a) = RecordLit <$> traverse (recordFieldExprs f) a -subExpressions f (Lam cs fb e) = Lam cs <$> functionBindingExprs f fb <*> f e -subExpressions f (Field a b) = Field <$> f a <*> pure b -subExpressions f expression = unsafeSubExpressions f expression +subExpressions = subExpressionsWith (pure . Embed) {-# INLINABLE subExpressions #-} + +{-| A traversal over the immediate sub-expressions of an expression which + allows mapping embedded values +-} +subExpressionsWith + :: Applicative f => (a -> f (Expr s b)) -> (Expr s a -> f (Expr s b)) -> Expr s a -> f (Expr s b) +subExpressionsWith h _ (Embed a) = h a +subExpressionsWith _ f (Note a b) = Note a <$> f b +subExpressionsWith _ f (Let a b) = Let <$> bindingExprs f a <*> f b +subExpressionsWith _ f (Record a) = Record <$> traverse (recordFieldExprs f) a +subExpressionsWith _ f (RecordLit a) = RecordLit <$> traverse (recordFieldExprs f) a +subExpressionsWith _ f (Lam cs fb e) = Lam cs <$> functionBindingExprs f fb <*> f e +subExpressionsWith _ f (Field a b) = Field <$> f a <*> pure b +subExpressionsWith _ f expression = unsafeSubExpressions f expression +{-# INLINABLE subExpressionsWith #-} {-| An internal utility used to implement transformations that require changing one of the type variables of the `Expr` type diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -6,26 +6,33 @@ -- | Template Haskell utilities module Dhall.TH - ( -- * Template Haskell + ( -- * Embedding Dhall in Haskell staticDhallExpression , dhall + -- * Generating Haskell from Dhall expressions , makeHaskellTypeFromUnion , makeHaskellTypes + , makeHaskellTypesWith , HaskellType(..) + , GenerateOptions(..) + , defaultGenerateOptions ) where import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) import Dhall (FromDhall, ToDhall) import Dhall.Syntax (Expr (..)) import GHC.Generics (Generic) import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) +import Prettyprinter (Pretty) import Language.Haskell.TH.Syntax ( Bang (..) + , Body (..) , Con (..) , Dec (..) , Exp (..) + , Match (..) + , Pat (..) , Q , SourceStrictness (..) , SourceUnpackedness (..) @@ -34,18 +41,19 @@ import Language.Haskell.TH.Syntax (DerivClause (..), DerivStrategy (..)) -import qualified Data.List as List -import qualified Data.Text as Text -import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty -import qualified Data.Typeable as Typeable +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Typeable as Typeable import qualified Dhall -import qualified Dhall.Core as Core +import qualified Dhall.Core as Core import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Util import qualified GHC.IO.Encoding -import qualified Language.Haskell.TH.Syntax as Syntax +import qualified Language.Haskell.TH.Syntax as Syntax import qualified Numeric.Natural +import qualified Prettyprinter.Render.String as Pretty import qualified System.IO {-| This fully resolves, type checks, and normalizes the expression, so the @@ -179,27 +187,54 @@ predicate haskellType = Core.judgmentallyEqual (code haskellType) dhallType -derivingClauses :: [DerivClause] -derivingClauses = - [ DerivClause (Just StockStrategy) [ ConT ''Generic ] - , DerivClause (Just AnyclassStrategy) [ ConT ''FromDhall, ConT ''ToDhall ] - ] +-- | A deriving clause for `Generic`. +derivingGenericClause :: DerivClause +derivingGenericClause = DerivClause (Just StockStrategy) [ ConT ''Generic ] +-- | Generates a `FromDhall` instances. +fromDhallInstance + :: Syntax.Name -- ^ The name of the type the instances is for + -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` + -> Q [Dec] +fromDhallInstance n interpretOptions = [d| + instance FromDhall $(pure $ ConT n) where + autoWith = Dhall.genericAutoWithInputNormalizer $(interpretOptions) + |] + +-- | Generates a `ToDhall` instances. +toDhallInstance + :: Syntax.Name -- ^ The name of the type the instances is for + -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` + -> Q [Dec] +toDhallInstance n interpretOptions = [d| + instance ToDhall $(pure $ ConT n) where + injectWith = Dhall.genericToDhallWithInputNormalizer $(interpretOptions) + |] + -- | Convert a Dhall type to the corresponding Haskell datatype declaration toDeclaration :: (Eq a, Pretty a) - => [HaskellType (Expr s a)] + => GenerateOptions + -> [HaskellType (Expr s a)] -> HaskellType (Expr s a) - -> Q Dec -toDeclaration haskellTypes MultipleConstructors{..} = + -> Q [Dec] +toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ@MultipleConstructors{..} = case code of Union kts -> do let name = Syntax.mkName (Text.unpack typeName) - constructors <- traverse (toConstructor haskellTypes typeName) (Dhall.Map.toList kts ) + let derivingClauses = + [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] - return (DataD [] name [] Nothing constructors derivingClauses) + constructors <- traverse (toConstructor generateOptions haskellTypes typeName) (Dhall.Map.toList kts) + let interpretOptions = generateToInterpretOptions generateOptions typ + + fmap concat . sequence $ + [pure [DataD [] name [] Nothing constructors derivingClauses]] <> + [ fromDhallInstance name interpretOptions | generateFromDhallInstance ] <> + [ toDhallInstance name interpretOptions | generateToDhallInstance ] + _ -> do let document = mconcat @@ -242,24 +277,33 @@ let message = Pretty.renderString (Dhall.Pretty.layout document) fail message -toDeclaration haskellTypes SingleConstructor{..} = do +toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ@SingleConstructor{..} = do let name = Syntax.mkName (Text.unpack typeName) - constructor <- toConstructor haskellTypes typeName (constructorName, Just code) + let derivingClauses = + [ derivingGenericClause | generateFromDhallInstance || generateToDhallInstance ] - return (DataD [] name [] Nothing [constructor] derivingClauses) + let interpretOptions = generateToInterpretOptions generateOptions typ + constructor <- toConstructor generateOptions haskellTypes typeName (constructorName, Just code) + + fmap concat . sequence $ + [pure [DataD [] name [] Nothing [constructor] derivingClauses]] <> + [ fromDhallInstance name interpretOptions | generateFromDhallInstance ] <> + [ toDhallInstance name interpretOptions | generateToDhallInstance ] + -- | Convert a Dhall type to the corresponding Haskell constructor toConstructor :: (Eq a, Pretty a) - => [HaskellType (Expr s a)] + => GenerateOptions + -> [HaskellType (Expr s a)] -> Text -- ^ typeName -> (Text, Maybe (Expr s a)) -- ^ @(constructorName, fieldType)@ -> Q Con -toConstructor haskellTypes outerTypeName (constructorName, maybeAlternativeType) = do - let name = Syntax.mkName (Text.unpack constructorName) +toConstructor GenerateOptions{..} haskellTypes outerTypeName (constructorName, maybeAlternativeType) = do + let name = Syntax.mkName (Text.unpack $ constructorModifier constructorName) let bang = Bang NoSourceUnpackedness NoSourceStrictness @@ -278,7 +322,7 @@ let process (key, dhallFieldType) = do haskellFieldType <- toNestedHaskellType haskellTypes dhallFieldType - return (Syntax.mkName (Text.unpack key), bang, haskellFieldType) + return (Syntax.mkName (Text.unpack $ fieldModifier key), bang, haskellFieldType) varBangTypes <- traverse process (Dhall.Map.toList $ Core.recordFieldValue <$> kts) @@ -316,17 +360,18 @@ makeHaskellTypeFromUnion typeName code = makeHaskellTypes [ MultipleConstructors{..} ] --- | Used by `makeHaskellTypes` to specify how to generate Haskell types +-- | Used by `makeHaskellTypes` and `makeHaskellTypesWith` to specify how to +-- generate Haskell types. data HaskellType code -- | Generate a Haskell type with more than one constructor from a Dhall - -- union type + -- union type. = MultipleConstructors { typeName :: Text -- ^ Name of the generated Haskell type , code :: code -- ^ Dhall code that evaluates to a union type } - -- | Generate a Haskell type with one constructor from any Dhall type + -- | Generate a Haskell type with one constructor from any Dhall type. -- -- To generate a constructor with multiple named fields, supply a Dhall -- record type. This does not support more than one anonymous field. @@ -340,8 +385,82 @@ } deriving (Functor, Foldable, Traversable) +-- | This data type holds various options that let you control several aspects +-- how Haskell code is generated. In particular you can +-- +-- * disable the generation of `FromDhall`/`ToDhall` instances. +-- * modify how a Dhall union field translates to a Haskell data constructor. +data GenerateOptions = GenerateOptions + { constructorModifier :: Text -> Text + -- ^ How to map a Dhall union field name to a Haskell constructor. + -- Note: The `constructorName` of `SingleConstructor` will be passed to this function, too. + , fieldModifier :: Text -> Text + -- ^ How to map a Dhall record field names to a Haskell record field names. + , generateFromDhallInstance :: Bool + -- ^ Generate a `FromDhall` instance for the Haskell type + , generateToDhallInstance :: Bool + -- ^ Generate a `ToDhall` instance for the Haskell type + } + +-- | A default set of options used by `makeHaskellTypes`. That means: +-- +-- * Constructors and fields are passed unmodified. +-- * Both `FromDhall` and `ToDhall` instances are generated. +defaultGenerateOptions :: GenerateOptions +defaultGenerateOptions = GenerateOptions + { constructorModifier = id + , fieldModifier = id + , generateFromDhallInstance = True + , generateToDhallInstance = True + } + +-- | This function generates `Dhall.InterpretOptions` that can be used for the +-- marshalling of the Haskell type generated according to the `GenerateOptions`. +-- I.e. those `Dhall.InterpretOptions` reflect the mapping done by +-- `constructorModifier` and `fieldModifier` on the value level. +generateToInterpretOptions :: GenerateOptions -> HaskellType (Expr s a) -> Q Exp +generateToInterpretOptions GenerateOptions{..} haskellType = [| Dhall.InterpretOptions + { Dhall.fieldModifier = \ $(pure nameP) -> + $(toCases fieldModifier $ fields haskellType) + , Dhall.constructorModifier = \ $(pure nameP) -> + $(toCases constructorModifier $ constructors haskellType) + , Dhall.singletonConstructors = Dhall.singletonConstructors Dhall.defaultInterpretOptions + }|] + where + constructors :: HaskellType (Expr s a) -> [Text] + constructors SingleConstructor{..} = [constructorName] + constructors MultipleConstructors{..} | Union kts <- code = Dhall.Map.keys kts + constructors _ = [] + + fields :: HaskellType (Expr s a) -> [Text] + fields SingleConstructor{..} | Record kts <- code = Dhall.Map.keys kts + fields MultipleConstructors{..} | Union kts <- code = Set.toList $ mconcat + [ Dhall.Map.keysSet kts' + | (_, Just (Record kts')) <- Dhall.Map.toList kts + ] + fields _ = [] + + toCases :: (Text -> Text) -> [Text] -> Q Exp + toCases f xs = do + err <- [| Core.internalError $ "Unmatched " <> Text.pack (show $(pure nameE)) |] + pure $ CaseE nameE $ map mkMatch xs <> [Match WildP (NormalB err) []] + where + mkMatch n = Match (textToPat $ f n) (NormalB $ textToExp n) [] + + nameE :: Exp + nameE = Syntax.VarE $ Syntax.mkName "n" + + nameP :: Pat + nameP = Syntax.VarP $ Syntax.mkName "n" + + textToExp :: Text -> Exp + textToExp = Syntax.LitE . Syntax.StringL . Text.unpack + + textToPat :: Text -> Pat + textToPat = Syntax.LitP . Syntax.StringL . Text.unpack + -- | Generate a Haskell datatype declaration with one constructor from a Dhall --- type +-- type. -- -- This comes in handy if you need to keep Dhall types and Haskell types in -- sync. You make the Dhall types the source of truth and use Template Haskell @@ -416,9 +535,18 @@ -- > deriving instance Ord Employee -- > deriving instance Show Employee makeHaskellTypes :: [HaskellType Text] -> Q [Dec] -makeHaskellTypes haskellTypes = do +makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions + +-- | Like `makeHaskellTypes`, but with the ability to customize the generated +-- Haskell code by passing `GenerateOptions`. +-- +-- For instance, `makeHaskellTypes` is implemented using this function: +-- +-- > makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions +makeHaskellTypesWith :: GenerateOptions -> [HaskellType Text] -> Q [Dec] +makeHaskellTypesWith generateOptions haskellTypes = do Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) haskellTypes' <- traverse (traverse (Syntax.runIO . Dhall.inputExpr)) haskellTypes - traverse (toDeclaration haskellTypes') haskellTypes' + concat <$> traverse (toDeclaration generateOptions haskellTypes') haskellTypes' diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -38,7 +38,6 @@ import Data.Sequence (Seq, ViewL (..)) import Data.Set (Set) import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty (..), vsep) import Data.Typeable (Typeable) import Data.Void (Void, absurd) import Dhall.Context (Context) @@ -51,6 +50,7 @@ import Dhall.Pretty (Ann) import Dhall.Src (Src) import Lens.Family (over) +import Prettyprinter (Doc, Pretty (..), vsep) import Dhall.Syntax ( Binding (..) @@ -63,25 +63,25 @@ , Var (..) ) -import qualified Data.Foldable as Foldable -import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Foldable as Foldable +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map import qualified Data.Sequence 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 as Text import qualified Data.Traversable import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Diff -import qualified Dhall.Eval as Eval +import qualified Dhall.Eval as Eval import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal -import qualified Dhall.Syntax as Syntax +import qualified Dhall.Syntax as Syntax import qualified Dhall.Util import qualified Lens.Family +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.String as Pretty {-| A type synonym for `Void` diff --git a/src/Dhall/URL.hs b/src/Dhall/URL.hs --- a/src/Dhall/URL.hs +++ b/src/Dhall/URL.hs @@ -3,7 +3,7 @@ module Dhall.URL where -import Data.Text (Text) +import Data.Text (Text) import Dhall.Syntax (Directory (..), File (..), Scheme (..), URL (..)) diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -25,30 +25,30 @@ , renderExpression ) where -import Control.Exception (Exception (..)) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Bifunctor (first) -import Data.Either (lefts) -import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.String (IsString) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Dhall.Parser (Header (..), ParseError) -import Dhall.Pretty (Ann, CharacterSet) -import Dhall.Src (Src) -import Dhall.Syntax (Expr, Import) +import Control.Exception (Exception (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (first) +import Data.Either (lefts) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.String (IsString) +import Data.Text (Text) +import Dhall.Parser (Header (..), ParseError) +import Dhall.Pretty (Ann, CharacterSet) +import Dhall.Src (Src) +import Dhall.Syntax (Expr, Import) +import Prettyprinter (Doc, Pretty) import qualified Control.Exception import qualified Data.Text import qualified Data.Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Parser import qualified Dhall.Pretty -import qualified System.Console.ANSI as ANSI -import qualified System.IO as IO +import qualified Prettyprinter as Pretty +import qualified Prettyprinter.Render.Terminal as Pretty.Terminal +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified System.Console.ANSI as ANSI +import qualified System.IO as IO -- | Utility function to cut out the interior of a large text block snip :: Text -> Text diff --git a/tests/Dhall/Test/Dhall.hs b/tests/Dhall/Test/Dhall.hs --- a/tests/Dhall/Test/Dhall.hs +++ b/tests/Dhall/Test/Dhall.hs @@ -16,7 +16,7 @@ import Control.Exception (SomeException, throwIO, try) import Data.Either.Validation (validationToEither) import Data.Fix (Fix (..)) -import Data.Functor.Classes (Eq1(..), Show1(..)) +import Data.Functor.Classes (Eq1 (..), Show1 (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) import Data.Scientific (Scientific) diff --git a/tests/Dhall/Test/Diff.hs b/tests/Dhall/Test/Diff.hs --- a/tests/Dhall/Test/Diff.hs +++ b/tests/Dhall/Test/Diff.hs @@ -2,21 +2,21 @@ module Dhall.Test.Diff where -import Data.Text (Text) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath) +import Data.Text (Text) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text -import qualified Dhall.Core as Core -import qualified Dhall.Diff as Diff -import qualified Dhall.Parser as Parser +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Diff as Diff +import qualified Dhall.Parser as Parser import qualified Dhall.Pretty -import qualified Dhall.Test.Util as Test.Util -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Dhall.Test.Util as Test.Util +import qualified Prettyprinter.Render.Text as Pretty.Text +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Turtle diffDirectory :: FilePath diff --git a/tests/Dhall/Test/Format.hs b/tests/Dhall/Test/Format.hs --- a/tests/Dhall/Test/Format.hs +++ b/tests/Dhall/Test/Format.hs @@ -7,17 +7,17 @@ import Dhall.Pretty (CharacterSet (..)) import Test.Tasty (TestTree) -import qualified Control.Monad as Monad -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Doc -import qualified Data.Text.Prettyprint.Doc.Render.Text as Doc.Render.Text -import qualified Dhall.Core as Core -import qualified Dhall.Parser as Parser -import qualified Dhall.Pretty as Pretty -import qualified Dhall.Test.Util as Test.Util -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.Silver as Tasty.Silver +import qualified Control.Monad as Monad +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty as Pretty +import qualified Dhall.Test.Util as Test.Util +import qualified Prettyprinter as Doc +import qualified Prettyprinter.Render.Text as Doc.Render.Text +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Silver as Tasty.Silver import qualified Turtle getTests :: IO TestTree diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -3,12 +3,14 @@ module Dhall.Test.Import where -import Control.Exception (SomeException) -import Data.Text (Text) -import Data.Void (Void) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath, ()) +import Control.Exception (SomeException) +import Data.Foldable (fold) +import Data.Text (Text, isSuffixOf) +import Data.Void (Void) +import Filesystem.Path.CurrentOS (toText) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) import qualified Control.Exception as Exception import qualified Control.Monad as Monad @@ -54,7 +56,7 @@ return path ) - failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest (do + failureTests <- Test.Util.discover (Turtle.chars <* ".dhall") failureTest (do path <- Turtle.lstree (importDirectory "failure") let expectedSuccesses = @@ -62,7 +64,8 @@ , importDirectory "failure/unit/DontRecoverTypeError.dhall" ] - Monad.guard (path `notElem` expectedSuccesses) + _ <- Monad.guard (path `notElem` expectedSuccesses) + _ <- Monad.guard (not ("ENV.dhall" `isSuffixOf` (fold (toText path)))) return path ) let testTree = @@ -87,8 +90,6 @@ , importDirectory "success/unit/cors/AllowedAll" , importDirectory "success/unit/cors/SelfImportRelative" , importDirectory "success/unit/cors/OnlyGithub" - , importDirectory "success/userHeaders" - , importDirectory "success/userHeadersOverride" ] Test.Util.testCase prefix expectedFailures (do @@ -107,10 +108,17 @@ HTTP.newManager HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) } + + let status = + Import.makeEmptyStatus + httpManager + (pure Import.envOriginHeaders) + directoryString + let load = State.evalStateT (Test.Util.loadWith actualExpr) - (Import.emptyStatusWithManager httpManager directoryString) + status let usesCache = [ "hashFromCache" , "unit/asLocation/Hash" @@ -168,18 +176,22 @@ Tasty.HUnit.assertEqual message expected actual) failureTest :: Text -> TestTree -failureTest path = do +failureTest prefix = do + let path = prefix <> ".dhall" + let pathString = Text.unpack path Tasty.HUnit.testCase pathString (do actualExpr <- do Core.throws (Parser.exprFromText mempty (Test.Util.toDhallPath path)) - succeeded <- Exception.catch @SomeException - (do _ <- Test.Util.load actualExpr - return True - ) - (\_ -> return False) + let setup = Test.Util.managedTestEnvironment prefix + + let run = Exception.catch @SomeException + (Test.Util.load actualExpr >> return True) + (\_ -> return False) + + succeeded <- Turtle.with setup (const run) if succeeded then fail "Import should have failed, but it succeeds" diff --git a/tests/Dhall/Test/Lint.hs b/tests/Dhall/Test/Lint.hs --- a/tests/Dhall/Test/Lint.hs +++ b/tests/Dhall/Test/Lint.hs @@ -8,17 +8,17 @@ import Test.Tasty (TestTree) import Turtle (FilePath) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Doc -import qualified Data.Text.Prettyprint.Doc.Render.Text as Doc.Render.Text -import qualified Dhall.Core as Core -import qualified Dhall.Lint as Lint -import qualified Dhall.Parser as Parser -import qualified Dhall.Pretty as Pretty -import qualified Dhall.Test.Util as Test.Util -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Lint as Lint +import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty as Pretty +import qualified Dhall.Test.Util as Test.Util +import qualified Prettyprinter as Doc +import qualified Prettyprinter.Render.Text as Doc.Render.Text +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Turtle lintDirectory :: FilePath diff --git a/tests/Dhall/Test/Main.hs b/tests/Dhall/Test/Main.hs --- a/tests/Dhall/Test/Main.hs +++ b/tests/Dhall/Test/Main.hs @@ -15,8 +15,8 @@ import qualified Dhall.Test.Regression import qualified Dhall.Test.Schemas import qualified Dhall.Test.SemanticHash -import qualified Dhall.Test.Tags import qualified Dhall.Test.TH +import qualified Dhall.Test.Tags import qualified Dhall.Test.Tutorial import qualified Dhall.Test.TypeInference import qualified GHC.IO.Encoding diff --git a/tests/Dhall/Test/Normalization.hs b/tests/Dhall/Test/Normalization.hs --- a/tests/Dhall/Test/Normalization.hs +++ b/tests/Dhall/Test/Normalization.hs @@ -2,12 +2,12 @@ module Dhall.Test.Normalization where -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Core (Expr (..), Var (..), throws) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath, ()) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Expr (..), Var (..), throws) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO diff --git a/tests/Dhall/Test/Parser.hs b/tests/Dhall/Test/Parser.hs --- a/tests/Dhall/Test/Parser.hs +++ b/tests/Dhall/Test/Parser.hs @@ -2,12 +2,12 @@ module Dhall.Test.Parser where -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Core (Binding (..), Expr (..), Import, Var (..)) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath, ()) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Binding (..), Expr (..), Import, Var (..)) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) import qualified Control.Monad as Monad import qualified Data.Bifunctor as Bifunctor 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 @@ -62,7 +62,7 @@ import Dhall.Src (Src (..)) import Dhall.Test.Format (format) import Dhall.TypeCheck (TypeError, Typer) -import Generic.Random ((:+) (..), ConstrGen (..), W, Weights, (%)) +import Generic.Random (ConstrGen (..), W, Weights, (%), (:+) (..)) import Test.QuickCheck ( Arbitrary (..) , Gen @@ -453,12 +453,7 @@ True chooseCharacter :: (Char, Char) -> Gen Char -chooseCharacter = -#if MIN_VERSION_QuickCheck(2,14,0) - Test.QuickCheck.chooseEnum -#else - Test.QuickCheck.choose -#endif +chooseCharacter = Test.QuickCheck.chooseEnum instance Arbitrary File where arbitrary = lift2 File 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 @@ -16,16 +16,16 @@ import qualified Control.Exception import qualified Data.Text.IO 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.Test.Util as Util +import qualified Dhall.Test.Util as Util import qualified Dhall.TypeCheck +import qualified Prettyprinter +import qualified Prettyprinter.Render.Text import qualified System.Timeout import qualified Test.Tasty import qualified Test.Tasty.HUnit @@ -162,9 +162,9 @@ -- Verify that pretty-printing preserves string interpolation source <- Data.Text.IO.readFile "./tests/regression/issue216b.dhall" e <- Util.code source - let doc = Data.Text.Prettyprint.Doc.pretty e + let doc = Prettyprinter.pretty e let docStream = Dhall.Pretty.layout doc - let text0 = Data.Text.Prettyprint.Doc.Render.Text.renderLazy docStream + let text0 = Prettyprinter.Render.Text.renderLazy docStream text1 <- Data.Text.Lazy.IO.readFile "./tests/regression/issue216b.dhall" diff --git a/tests/Dhall/Test/Schemas.hs b/tests/Dhall/Test/Schemas.hs --- a/tests/Dhall/Test/Schemas.hs +++ b/tests/Dhall/Test/Schemas.hs @@ -8,17 +8,17 @@ import Test.Tasty (TestTree) import Turtle (FilePath) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Doc -import qualified Data.Text.Prettyprint.Doc.Render.Text as Doc.Render.Text -import qualified Dhall.Core as Core -import qualified Dhall.Parser as Parser -import qualified Dhall.Pretty as Pretty -import qualified Dhall.Schemas as Schemas -import qualified Dhall.Test.Util as Test.Util -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty as Pretty +import qualified Dhall.Schemas as Schemas +import qualified Dhall.Test.Util as Test.Util +import qualified Prettyprinter as Doc +import qualified Prettyprinter.Render.Text as Doc.Render.Text +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Turtle schemasDirectory :: FilePath diff --git a/tests/Dhall/Test/SemanticHash.hs b/tests/Dhall/Test/SemanticHash.hs --- a/tests/Dhall/Test/SemanticHash.hs +++ b/tests/Dhall/Test/SemanticHash.hs @@ -2,10 +2,10 @@ module Dhall.Test.SemanticHash where -import Data.Text (Text) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath) +import Data.Text (Text) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO diff --git a/tests/Dhall/Test/TH.hs b/tests/Dhall/Test/TH.hs --- a/tests/Dhall/Test/TH.hs +++ b/tests/Dhall/Test/TH.hs @@ -7,9 +7,12 @@ module Dhall.Test.TH where +import Control.Exception (throwIO) +import Data.Either.Validation (Validation(..)) import Dhall.TH (HaskellType (..)) import Test.Tasty (TestTree) +import qualified Data.Text import qualified Dhall import qualified Dhall.TH import qualified Test.Tasty as Tasty @@ -70,3 +73,83 @@ qux <- Dhall.input Dhall.auto "let T = ./tests/th/issue2066.dhall in T.Qux.Foo { foo = +2, bar = { baz = +3 } }" Tasty.HUnit.assertEqual "" qux (Foo MakeFoo{ foo = 2, bar = MakeBar{ baz = 3 } }) + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("My" <>) + , Dhall.TH.fieldModifier = ("my" <>) . Data.Text.toTitle + }) + [ MultipleConstructors "MyT" "./tests/th/example.dhall" + , MultipleConstructors "MyDepartment" "./tests/th/Department.dhall" + , SingleConstructor "MyEmployee" "Employee" "./tests/th/Employee.dhall" + ] + +deriving instance Eq MyT +deriving instance Eq MyDepartment +deriving instance Eq MyEmployee +deriving instance Show MyT +deriving instance Show MyDepartment +deriving instance Show MyEmployee + +testMakeHaskellTypesWith :: TestTree +testMakeHaskellTypesWith = Tasty.HUnit.testCase "makeHaskellTypesWith" $ do + let text0 = "let T = ./tests/th/example.dhall in T.A { x = True, y = [] : List Text }" + ref0 = MyA{ myX = True, myY = [] } + myTest text0 ref0 + + let text1 = "let T = ./tests/th/example.dhall in T.B (None (List Natural))" + ref1 = MyB Nothing + myTest text1 ref1 + + let text2 = "let T = ./tests/th/example.dhall in T.C" + ref2 = MyC + myTest text2 ref2 + + let textDepartment = "let T = ./tests/th/Department.dhall in T.Sales" + refDepartment = MySales + myTest textDepartment refDepartment + + let textEmployee = "let T = ./tests/th/Department.dhall in T.Sales" + refEmployee = MyEmployee{ myName = "", myDepartment = MySales } + myTest textEmployee refEmployee + where + myTest text ref = do + expr <- Dhall.inputExpr text + t <- case Dhall.extract Dhall.auto expr of + Failure e -> throwIO e + Success t -> return t + + Tasty.HUnit.assertEqual "" t ref + Tasty.HUnit.assertEqual "" expr $ Dhall.embed Dhall.inject ref + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoFromDhall" <>) + , Dhall.TH.fieldModifier = ("noFromDhall" <>) . Data.Text.toTitle + , Dhall.TH.generateFromDhallInstance = False + }) + [ MultipleConstructors "NoFromDhallT" "./tests/th/example.dhall" + ] + +instance Dhall.FromDhall NoFromDhallT + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoToDhall" <>) + , Dhall.TH.fieldModifier = ("noToDhall" <>) . Data.Text.toTitle + , Dhall.TH.generateToDhallInstance = False + }) + [ MultipleConstructors "NoToDhallT" "./tests/th/example.dhall" + ] + +instance Dhall.ToDhall NoToDhallT + +Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions + { Dhall.TH.constructorModifier = ("NoInstances" <>) + , Dhall.TH.fieldModifier = ("noInstances" <>) . Data.Text.toTitle + , Dhall.TH.generateFromDhallInstance = False + , Dhall.TH.generateToDhallInstance = False + }) + [ MultipleConstructors "NoInstancesT" "./tests/th/example.dhall" + ] + +deriving instance Dhall.Generic NoInstancesT +instance Dhall.FromDhall NoInstancesT +instance Dhall.ToDhall NoInstancesT diff --git a/tests/Dhall/Test/Tags.hs b/tests/Dhall/Test/Tags.hs --- a/tests/Dhall/Test/Tags.hs +++ b/tests/Dhall/Test/Tags.hs @@ -2,11 +2,11 @@ module Dhall.Test.Tags where -import Data.Text (Text) -import Dhall.Util (Input (..)) -import Prelude hiding (FilePath) -import Test.Tasty (TestTree) -import Turtle (FilePath) +import Data.Text (Text) +import Dhall.Util (Input (..)) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO diff --git a/tests/Dhall/Test/Util.hs b/tests/Dhall/Test/Util.hs --- a/tests/Dhall/Test/Util.hs +++ b/tests/Dhall/Test/Util.hs @@ -23,17 +23,17 @@ , managedTestEnvironment ) where +import Control.Applicative (liftA2, (<|>)) +import Control.Exception (tryJust) +import Control.Monad (guard) import Control.Monad.Trans.State.Strict (StateT) -import Control.Applicative ((<|>), liftA2) -import Control.Exception (tryJust) -import Control.Monad (guard) import Data.Bifunctor (first) import Data.Text (Text) import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core - ( Chunks(..) - , Expr(..) + ( Chunks (..) + , Expr (..) , Import , Normalizer , ReifiedNormalizer (..) diff --git a/tests/format/letAnnotatedShortA.dhall b/tests/format/letAnnotatedShortA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/letAnnotatedShortA.dhall @@ -0,0 +1,1 @@ +let empty : ∀(a : Type) → List a = λ(a : Type) → [] : List a in empty diff --git a/tests/format/letAnnotatedShortB.dhall b/tests/format/letAnnotatedShortB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/letAnnotatedShortB.dhall @@ -0,0 +1,5 @@ +let empty + : ∀(a : Type) → List a + = λ(a : Type) → [] : List a + +in empty