diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,44 @@ +1.30.0 + +* [Supports version 14.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v14.0.0) +* BREAKING CHANGE TO THE API: [Add `--check` flag to `dhall {lint,freeze}`](https://github.com/dhall-lang/dhall-haskell/pull/1636) + * You can now use the `--check` flag to verify that a file has already been + linted or frozen + * This is a breaking change to the types used by the `Dhall.Format` module +* BREAKING CHANGE TO THE LANGUAGE: [Disallow `Natural` literals with leading zeros](https://github.com/dhall-lang/dhall-haskell/pull/1658) + * Now a literal like `042` is no longer valid + * See the [changelog for standard version 14.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v14.0.0) for more details +* BUG FIX: [Fix parsing of `Double` literal trailing whitespace](https://github.com/dhall-lang/dhall-haskell/pull/1647) + * Certain expressions using `Double` literals would fail to parse, which this + change fixes +* BUG FIX: [Use `DeriveLift` instead of GHC Generics to derive `Lift` ](https://github.com/dhall-lang/dhall-haskell/pull/1640) + * This fixes a build failure on GHC 8.10 +* [Drop support for GHC 7.10.3](https://github.com/dhall-lang/dhall-haskell/pull/1649) + * GHC 8.0.2 is now the earliest supported version +* [Add support for dotted field syntax](https://github.com/dhall-lang/dhall-haskell/pull/1651) + * `{ x.y.z = 1 }` now legal syntax for nested fields + * See the [changelog for standard version 14.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v14.0.0) for more details +* [Add support for duplicate record fields](https://github.com/dhall-lang/dhall-haskell/pull/1643) + * This combines with the previous feature to let you write + `{ x.y = 1, x.z = True }`, which is equivalent to + `{ x = { y = 1, z = True } }` + * See the [changelog for standard version 14.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v14.0.0) for more details +* [Add `dhall lint` support for deprecating `Optional/{fold,build}`](https://github.com/dhall-lang/dhall-haskell/pull/1628) + * The `Optional/{fold,build}` built-ins are deprecated and can be implemented + in terms of other language features + * `Optional/fold` can be implemented in terms of `merge` (which now works on + `Optional` values) + * `Optional/build` could always be implemented using `Some`/`None` + * `dhall lint` now transforms the deprecated built-ins to use their + equivalent built-in-free versions +* [Support Template Haskell for multiple datatypes](https://github.com/dhall-lang/dhall-haskell/pull/1664) + * This extends the Template Haskell support added in the previous release to + work for datatypes that refer to one another +* [Add support for custom substitutions](https://github.com/dhall-lang/dhall-haskell/pull/1650) + * You can now add custom substitutions, which are like `let` bindings that + propagate to transitive imports +* [Small formatting fixes](https://github.com/dhall-lang/dhall-haskell/pull/1652) + 1.29.0 * [Supports version 13.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v13.0.0) diff --git a/dhall-lang/Prelude/JSON/package.dhall b/dhall-lang/Prelude/JSON/package.dhall --- a/dhall-lang/Prelude/JSON/package.dhall +++ b/dhall-lang/Prelude/JSON/package.dhall @@ -2,7 +2,7 @@ ./render sha256:f7c372fcc954bfbbc7f83deec2006608a48efa2b08e8753bfdf73dc0aa7b4faf ? ./render , renderYAML = - ./renderYAML sha256:0949b834275fb231023ea80831d830352e0b89a15f4081f043cb83e745fdb6e8 + ./renderYAML sha256:b3a9d9b0349c90af9a4985c615c60ac4a85031a7bf9de78f2883126481d35aa0 ? ./renderYAML , omitNullFields = ./omitNullFields sha256:e6850e70094540b75edeb46f4d6038324a62def8d63544a1e9541f79739db6f0 diff --git a/dhall-lang/Prelude/JSON/renderYAML b/dhall-lang/Prelude/JSON/renderYAML --- a/dhall-lang/Prelude/JSON/renderYAML +++ b/dhall-lang/Prelude/JSON/renderYAML @@ -33,7 +33,7 @@ ? ../List/concatMap let Optional/map = - ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ../Optional/map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa ? ../Optional/map let NonEmpty @@ -81,12 +81,9 @@ : Block → List Block → Block = λ(ifEmpty : Block) → λ(blocks : List Block) - → Optional/fold - (NonEmpty Block) + → merge + { Some = concatNonEmpty Text, None = ifEmpty } (uncons Block blocks) - Block - (concatNonEmpty Text) - ifEmpty let singleLine : Text → Block diff --git a/dhall-lang/Prelude/List/default b/dhall-lang/Prelude/List/default --- a/dhall-lang/Prelude/List/default +++ b/dhall-lang/Prelude/List/default @@ -6,7 +6,7 @@ : ∀(a : Type) → Optional (List a) → List a = λ(a : Type) → λ(o : Optional (List a)) - → Optional/fold (List a) o (List a) (λ(l : List a) → l) ([] : List a) + → merge { Some = λ(l : List a) → l, None = [] : List a } o let example0 = assert : default Bool (None (List Bool)) ≡ ([] : List Bool) diff --git a/dhall-lang/Prelude/List/package.dhall b/dhall-lang/Prelude/List/package.dhall --- a/dhall-lang/Prelude/List/package.dhall +++ b/dhall-lang/Prelude/List/package.dhall @@ -14,7 +14,7 @@ ./concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 ? ./concatMap , default = - ./default sha256:0ed2a04df6c1d55c08bcdbad82b30980af9ac40d2df7a1628f3663e3e8b4fe01 + ./default sha256:fd77809e497227403f42848ffcda05a3efab442d961027c34f3e31d5d24e6379 ? ./default , drop = ./drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf diff --git a/dhall-lang/Prelude/Natural/listMax b/dhall-lang/Prelude/Natural/listMax --- a/dhall-lang/Prelude/Natural/listMax +++ b/dhall-lang/Prelude/Natural/listMax @@ -7,7 +7,7 @@ ? ./max let Optional/map = - ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ../Optional/map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa ? ../Optional/map let listMax diff --git a/dhall-lang/Prelude/Natural/listMin b/dhall-lang/Prelude/Natural/listMin --- a/dhall-lang/Prelude/Natural/listMin +++ b/dhall-lang/Prelude/Natural/listMin @@ -7,7 +7,7 @@ ? ./min let Optional/map = - ../Optional/map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ../Optional/map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa ? ../Optional/map let listMin diff --git a/dhall-lang/Prelude/Natural/package.dhall b/dhall-lang/Prelude/Natural/package.dhall --- a/dhall-lang/Prelude/Natural/package.dhall +++ b/dhall-lang/Prelude/Natural/package.dhall @@ -53,13 +53,13 @@ ./max sha256:1f3b18da330223ab039fad11693da72c7e68d516f50502c73f41a89a097b62f7 ? ./max , listMin = - ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc + ./listMin sha256:ee70b0d010bbca6012162e8ae1f6e9d9bd10a152675509b0f23145b98b5d43c6 ? ./listMin , listMax = - ./listMax sha256:30917e8ca230ea6044c6d8ea6e72bcf6f76437aaecc347f790e8a5946c6aa0e5 + ./listMax sha256:20906ffcc9970f740106d4516cb7868b43d75ff8c9f00ff8a9680ae68c48a472 ? ./listMax , sort = - ./sort sha256:ed2eb5a33c5c96ac9227b0b4c77bdbf8911026d721c603ac897ae84b2bfb5dcd + ./sort sha256:36ce8b3e5538454763987ca904d8d7c5ba34c2147434a19eddd51f684432b260 ? ./sort , subtract = ./subtract sha256:b9277ac637d09142a3a3ac79137ef5955c42f8b33b6746d59db2c9d75ccdd745 diff --git a/dhall-lang/Prelude/Natural/sort b/dhall-lang/Prelude/Natural/sort --- a/dhall-lang/Prelude/Natural/sort +++ b/dhall-lang/Prelude/Natural/sort @@ -6,7 +6,7 @@ ? ./greaterThanEqual let listMin = - ./listMin sha256:89e0d9c23750efd8a8a2a6945579f21e46bd503b0655d4bfdd0e0e51e39c37cc + ./listMin sha256:ee70b0d010bbca6012162e8ae1f6e9d9bd10a152675509b0f23145b98b5d43c6 ? ./listMin let List/partition = @@ -17,12 +17,12 @@ let partitionMinima = λ(xs : List Natural) - → Optional/fold - Natural + → merge + { Some = + λ(m : Natural) → List/partition Natural (greaterThanEqual m) xs + , None = { true = [] : List Natural, false = [] : List Natural } + } (listMin xs) - { true : List Natural, false : List Natural } - (λ(m : Natural) → List/partition Natural (greaterThanEqual m) xs) - { true = [] : List Natural, false = [] : List Natural } let test0 = assert diff --git a/dhall-lang/Prelude/Optional/all b/dhall-lang/Prelude/Optional/all --- a/dhall-lang/Prelude/Optional/all +++ b/dhall-lang/Prelude/Optional/all @@ -7,7 +7,7 @@ = λ(a : Type) → λ(f : a → Bool) → λ(xs : Optional a) - → Optional/fold a xs Bool f True + → merge { Some = f, None = True } xs let example0 = assert : all Natural Natural/even (Some 3) ≡ False diff --git a/dhall-lang/Prelude/Optional/any b/dhall-lang/Prelude/Optional/any --- a/dhall-lang/Prelude/Optional/any +++ b/dhall-lang/Prelude/Optional/any @@ -7,7 +7,7 @@ = λ(a : Type) → λ(f : a → Bool) → λ(xs : Optional a) - → Optional/fold a xs Bool f False + → merge { Some = f, None = False } xs let example0 = assert : any Natural Natural/even (Some 2) ≡ True diff --git a/dhall-lang/Prelude/Optional/build b/dhall-lang/Prelude/Optional/build --- a/dhall-lang/Prelude/Optional/build +++ b/dhall-lang/Prelude/Optional/build @@ -9,7 +9,14 @@ → optional ) → Optional a - = Optional/build + = λ(a : Type) + → λ ( build + : ∀(optional : Type) + → ∀(some : a → optional) + → ∀(none : optional) + → optional + ) + → build (Optional a) (λ(x : a) → Some x) (None a) let example0 = assert diff --git a/dhall-lang/Prelude/Optional/concat b/dhall-lang/Prelude/Optional/concat --- a/dhall-lang/Prelude/Optional/concat +++ b/dhall-lang/Prelude/Optional/concat @@ -5,12 +5,7 @@ : ∀(a : Type) → Optional (Optional a) → Optional a = λ(a : Type) → λ(x : Optional (Optional a)) - → Optional/fold - (Optional a) - x - (Optional a) - (λ(y : Optional a) → y) - (None a) + → merge { Some = λ(y : Optional a) → y, None = None a } x let example0 = assert : concat Natural (Some (Some 1)) ≡ Some 1 diff --git a/dhall-lang/Prelude/Optional/default b/dhall-lang/Prelude/Optional/default --- a/dhall-lang/Prelude/Optional/default +++ b/dhall-lang/Prelude/Optional/default @@ -6,7 +6,7 @@ = λ(a : Type) → λ(default : a) → λ(o : Optional a) - → Optional/fold a o a (λ(x : a) → x) default + → merge { Some = λ(x : a) → x, None = default } o let example0 = assert : default Bool False (None Bool) ≡ False diff --git a/dhall-lang/Prelude/Optional/filter b/dhall-lang/Prelude/Optional/filter --- a/dhall-lang/Prelude/Optional/filter +++ b/dhall-lang/Prelude/Optional/filter @@ -6,17 +6,22 @@ = λ(a : Type) → λ(f : a → Bool) → λ(xs : Optional a) - → Optional/build + → ( λ(a : Type) + → λ ( build + : ∀(optional : Type) + → ∀(some : a → optional) + → ∀(none : optional) + → optional + ) + → build (Optional a) (λ(x : a) → Some x) (None a) + ) a ( λ(optional : Type) → λ(some : a → optional) → λ(none : optional) - → Optional/fold - a + → merge + { Some = λ(x : a) → if f x then some x else none, None = none } xs - optional - (λ(x : a) → if f x then some x else none) - none ) let example0 = assert : filter Natural Natural/even (Some 2) ≡ Some 2 diff --git a/dhall-lang/Prelude/Optional/fold b/dhall-lang/Prelude/Optional/fold --- a/dhall-lang/Prelude/Optional/fold +++ b/dhall-lang/Prelude/Optional/fold @@ -8,7 +8,12 @@ → ∀(some : a → optional) → ∀(none : optional) → optional - = Optional/fold + = λ(a : Type) + → λ(o : Optional a) + → λ(optional : Type) + → λ(some : a → optional) + → λ(none : optional) + → merge { Some = some, None = none } o let example0 = assert : fold Natural (Some 2) Natural (λ(x : Natural) → x) 0 ≡ 2 diff --git a/dhall-lang/Prelude/Optional/head b/dhall-lang/Prelude/Optional/head --- a/dhall-lang/Prelude/Optional/head +++ b/dhall-lang/Prelude/Optional/head @@ -11,7 +11,7 @@ (Optional a) ( λ(l : Optional a) → λ(r : Optional a) - → Optional/fold a l (Optional a) (λ(x : a) → Some x) r + → merge { Some = λ(x : a) → Some x, None = r } l ) (None a) diff --git a/dhall-lang/Prelude/Optional/last b/dhall-lang/Prelude/Optional/last --- a/dhall-lang/Prelude/Optional/last +++ b/dhall-lang/Prelude/Optional/last @@ -11,7 +11,7 @@ (Optional a) ( λ(l : Optional a) → λ(r : Optional a) - → Optional/fold a r (Optional a) (λ(x : a) → Some x) l + → merge { Some = λ(x : a) → Some x, None = l } r ) (None a) diff --git a/dhall-lang/Prelude/Optional/length b/dhall-lang/Prelude/Optional/length --- a/dhall-lang/Prelude/Optional/length +++ b/dhall-lang/Prelude/Optional/length @@ -5,7 +5,7 @@ : ∀(a : Type) → Optional a → Natural = λ(a : Type) → λ(xs : Optional a) - → Optional/fold a xs Natural (λ(_ : a) → 1) 0 + → merge { Some = λ(_ : a) → 1, None = 0 } xs let example0 = assert : length Natural (Some 2) ≡ 1 diff --git a/dhall-lang/Prelude/Optional/map b/dhall-lang/Prelude/Optional/map --- a/dhall-lang/Prelude/Optional/map +++ b/dhall-lang/Prelude/Optional/map @@ -7,7 +7,7 @@ → λ(b : Type) → λ(f : a → b) → λ(o : Optional a) - → Optional/fold a o (Optional b) (λ(x : a) → Some (f x)) (None b) + → merge { Some = λ(x : a) → Some (f x), None = None b } o let example0 = assert : map Natural Bool Natural/even (Some 3) ≡ Some False diff --git a/dhall-lang/Prelude/Optional/null b/dhall-lang/Prelude/Optional/null --- a/dhall-lang/Prelude/Optional/null +++ b/dhall-lang/Prelude/Optional/null @@ -5,7 +5,7 @@ : ∀(a : Type) → Optional a → Bool = λ(a : Type) → λ(xs : Optional a) - → Optional/fold a xs Bool (λ(_ : a) → False) True + → merge { Some = λ(_ : a) → False, None = True } xs let example0 = assert : null Natural (Some 2) ≡ False diff --git a/dhall-lang/Prelude/Optional/package.dhall b/dhall-lang/Prelude/Optional/package.dhall --- a/dhall-lang/Prelude/Optional/package.dhall +++ b/dhall-lang/Prelude/Optional/package.dhall @@ -1,43 +1,43 @@ { all = - ./all sha256:b9b015fe8be14da940901aa1510ee1d5e205df37ee651c32ac975a799782c410 + ./all sha256:a303004b6def0a2a05bf5f0a8d54e84dd45d8bef581789186ac04924956a1695 ? ./all , any = - ./any sha256:0a637c0f2cc7d30b8f0bca021d2ee1ad1213fb9d9712c669b29feab66a590eaf + ./any sha256:96a5cf4f31b3c598b09161dd3082f0a09f4328a4cefda6a7e09894b37b17b435 ? ./any , build = - ./build sha256:f331299d1279cfb88dd25a5acfdd64130900991b6154239ad343a2883f6eb50c + ./build sha256:28e61294bf2dd59dc57cf74f719d1568e60b5ba46c28eac586bc937eff4a2af1 ? ./build , concat = - ./concat sha256:b49a3b7dc49eb83d150977caa5ae347be1cbbe14e3b6d0e07349bd2e5f707d69 + ./concat sha256:b7736bd3ebeab14c3912dfb534d0c970a025b001d06c2d5461d4b0e289e3cb7a ? ./concat , default = - ./default sha256:8f802473931b605422b545d7b81de20dbecb38f2ae63950c13f5381865a7f012 + ./default sha256:5bd665b0d6605c374b3c4a7e2e2bd3b9c1e39323d41441149ed5e30d86e889ad ? ./default , filter = - ./filter sha256:b3d5e19a6cec592a76c12167a9e5e1e76649e776229d70a11c77b76cd29f617e + ./filter sha256:54f0a487d578801819613fe000050c038c632edf1f9ccc57677e98ae0ef56b83 ? ./filter , fold = - ./fold sha256:62139ff410ca84302acebe763a8a1794420dd472d907384c7fb80df2a2180302 + ./fold sha256:c5b9d72f6f62bdaa0e196ac1c742cc175cd67a717b880fb8aec1333a5a4132cf ? ./fold , head = - ./head sha256:b0b5d257294515f1de35f24fa83e54d7f1d5ebca9c3c1fc903a80ab40e19b3a6 + ./head sha256:4f256c9338b60a1933f41f2a8fafd861930a1e41770a644cdbac0622676fa34c ? ./head , last = - ./last sha256:f839221a8a04adae6c501458eb264e7f4e375a1facb294cb80caacfd012a6765 + ./last sha256:50400771ae19e9b75efa6581feec318ae1ade0b6a60e215df428c66c4b052707 ? ./last , length = - ./length sha256:722a3754a411c053f006a32c506a6d1b14869c2ab799169df9cdac346edf07d3 + ./length sha256:f168337c5244ded68c05ecf32ce068b6b87158881d07e87b8cb6853fc6982a85 ? ./length , map = - ./map sha256:e7f44219250b89b094fbf9996e04b5daafc0902d864113420072ae60706ac73d + ./map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa ? ./map , null = - ./null sha256:efc43103e49b56c5bf089db8e0365bbfc455b8a2f0dc6ee5727a3586f85969fd + ./null sha256:3871180b87ecaba8b53fffb2a8b52d3fce98098fab09a6f759358b9e8042eedc ? ./null , toList = - ./toList sha256:390fe99619e9a25e71a253a2b33011f9e5fa26a7d990795205543d1edd72ce5b + ./toList sha256:d78f160c619119ef12389e48a629ce293d69f7624c8d016b7a4767ab400344c4 ? ./toList , unzip = - ./unzip sha256:7b517bc2a8a4dbec044c6bea5e059cafde5a0cb1d3a5e7d13d346c9327a00f30 + ./unzip sha256:d016c01ba91657a2f35609aa29087963d0f506bab0f41d5e8b7cd289dff39708 ? ./unzip } diff --git a/dhall-lang/Prelude/Optional/toList b/dhall-lang/Prelude/Optional/toList --- a/dhall-lang/Prelude/Optional/toList +++ b/dhall-lang/Prelude/Optional/toList @@ -5,7 +5,7 @@ : ∀(a : Type) → Optional a → List a = λ(a : Type) → λ(o : Optional a) - → Optional/fold a o (List a) (λ(x : a) → [ x ] : List a) ([] : List a) + → merge { Some = λ(x : a) → [ x ] : List a, None = [] : List a } o let example0 = assert : toList Natural (Some 1) ≡ [ 1 ] diff --git a/dhall-lang/Prelude/Optional/unzip b/dhall-lang/Prelude/Optional/unzip --- a/dhall-lang/Prelude/Optional/unzip +++ b/dhall-lang/Prelude/Optional/unzip @@ -10,19 +10,13 @@ → λ(b : Type) → λ(xs : Optional { _1 : a, _2 : b }) → { _1 = - Optional/fold - { _1 : a, _2 : b } + merge + { Some = λ(x : { _1 : a, _2 : b }) → Some x._1, None = None a } xs - (Optional a) - (λ(x : { _1 : a, _2 : b }) → Some x._1) - (None a) , _2 = - Optional/fold - { _1 : a, _2 : b } + merge + { Some = λ(x : { _1 : a, _2 : b }) → Some x._2, None = None b } xs - (Optional b) - (λ(x : { _1 : a, _2 : b }) → Some x._2) - (None b) } let example0 = diff --git a/dhall-lang/Prelude/Text/default b/dhall-lang/Prelude/Text/default --- a/dhall-lang/Prelude/Text/default +++ b/dhall-lang/Prelude/Text/default @@ -3,7 +3,7 @@ -} let default : Optional Text → Text - = λ(o : Optional Text) → Optional/fold Text o Text (λ(t : Text) → t) "" + = λ(o : Optional Text) → merge { Some = λ(t : Text) → t, None = "" } o let example0 = assert : default (Some "ABC") ≡ "ABC" diff --git a/dhall-lang/Prelude/Text/defaultMap b/dhall-lang/Prelude/Text/defaultMap --- a/dhall-lang/Prelude/Text/defaultMap +++ b/dhall-lang/Prelude/Text/defaultMap @@ -6,7 +6,7 @@ = λ(a : Type) → λ(f : a → Text) → λ(o : Optional a) - → Optional/fold a o Text f "" + → merge { Some = f, None = "" } o let example0 = assert : defaultMap Natural Natural/show (Some 0) ≡ "0" 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 @@ -11,10 +11,10 @@ ./concatSep sha256:e4401d69918c61b92a4c0288f7d60a6560ca99726138ed8ebc58dca2cd205e58 ? ./concatSep , default = - ./default sha256:e26d120fe57a4b61259d1149d938a66d335e1eb263196c30311c117073e4f92f + ./default sha256:f532c8891b1e427d90a6cc07cf7e793a4c84b0765e1bfe69f186ee2ec91c1edf ? ./default , defaultMap = - ./defaultMap sha256:a35c0e1db25e9223223b0beba0fcefeba7cd06a0edfa3994ccc9f82f6b86ff79 + ./defaultMap sha256:3a3fa1264f6198800c27483cb144de2c5366484876d60b9c739a710ce0288588 ? ./defaultMap , show = ./show sha256:c9dc5de3e5f32872dbda57166804865e5e80785abe358ff61f1d8ac45f1f4784 diff --git a/dhall-lang/Prelude/package.dhall b/dhall-lang/Prelude/package.dhall --- a/dhall-lang/Prelude/package.dhall +++ b/dhall-lang/Prelude/package.dhall @@ -11,7 +11,7 @@ ./Integer/package.dhall sha256:d1a572ca3a764781496847e4921d7d9a881c18ffcfac6ae28d0e5299066938a0 ? ./Integer/package.dhall , List = - ./List/package.dhall sha256:f0fdab7ab30415c128d89424589c42a15c835338be116fa14484086e4ba118d7 + ./List/package.dhall sha256:67899380860ce07a2d5d9530dc502800f2c11c73c2d64e8c827f4920b5473887 ? ./List/package.dhall , Location = ./Location/package.dhall sha256:0eb4e4a60814018009c720f6820aaa13cf9491eb1b09afb7b832039c6ee4d470 @@ -23,16 +23,16 @@ ./Monoid sha256:26fafa098600ef7a54ef9dba5ada416bbbdd21df1af306c052420c61553ad4af ? ./Monoid , Natural = - ./Natural/package.dhall sha256:e230d4ee318826ab9517ae5d6f38d1a9359d7cff815cc32912cc6b991656bb1a + ./Natural/package.dhall sha256:ee9ed2b28a417ed4e9a0c284801b928bf91b3fbdc1a68616347678c1821f1ddf ? ./Natural/package.dhall , Optional = - ./Optional/package.dhall sha256:7608f2d38dabee8bfe6865b4adc11289059984220f422d2b023b15b3908f7a4c + ./Optional/package.dhall sha256:4324b2bf84ded40f67485f14355e4cb7b237a8f173e713c791ec44cebebc552c ? ./Optional/package.dhall , JSON = - ./JSON/package.dhall sha256:7533c6c457353bde410a57a5c1d82c6097c8d4dbf9f55a0d926ab56f4ffce77c + ./JSON/package.dhall sha256:88c358783defee9bbd65aea224cdac56c7666ba367b0dd5f7f6d56de73911292 ? ./JSON/package.dhall , Text = - ./Text/package.dhall sha256:0a0ad9f649aed94c2680491efb384925b5b2bb5b353f1b8a7eb134955c1ffe45 + ./Text/package.dhall sha256:3a5e3acde76fe5f90bd296e6c9d2e43e6ae81c56f804029b39352d2f1664b769 ? ./Text/package.dhall , XML = ./XML/package.dhall sha256:137e7b106b2e9743970e5d37b21a165f2e40f56ab593a4dd10605c9acd686fc6 diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsA.dhall @@ -0,0 +1,1 @@ +{ x.y.z = True } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitDottedFieldsB.dhall @@ -0,0 +1,1 @@ +{ x = { y = { z = True } } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall @@ -0,0 +1,9 @@ +{- This expression desugars to: + + { x = { y = 0 } ∧ { z = 0 } } + + ... which then β-normalizes to: + + { x = { y = 0, z = 0 } } +-} +{ x = { y = 0 }, x = { z = 0 } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall @@ -0,0 +1,1 @@ +{ x = { y = 0, z = 0 } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeA.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeA.dhall @@ -0,0 +1,4 @@ +{- The purpose of this test is to verify that the Nix-like idiom of setting + multiple overlapping dotted fields works correctly +-} +{ x.y = 1, x.z = True } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeB.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitNixLikeB.dhall @@ -0,0 +1,1 @@ +{ x = { y = 1, z = True } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsA.dhall @@ -0,0 +1,7 @@ +{- This test ensures that an implementation handles more than one duplicate + field correctly and combines them with the correct order and associativity +-} + λ(a : { x : Natural }) +→ λ(b : { y : Natural }) +→ λ(c : { z : Natural }) +→ { k = a, k = b, k = c } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitTriplicateFieldsB.dhall @@ -0,0 +1,4 @@ + λ(a : { x : Natural }) +→ λ(b : { y : Natural }) +→ λ(c : { z : Natural }) +→ { k = a ∧ b ∧ c } diff --git a/dhall-lang/tests/parser/success/naturalA.dhall b/dhall-lang/tests/parser/success/naturalA.dhall --- a/dhall-lang/tests/parser/success/naturalA.dhall +++ b/dhall-lang/tests/parser/success/naturalA.dhall @@ -1,1 +1,1 @@ -[ 0, 1, 01, 10 ] +[ 0, 1, 10 ] diff --git a/dhall-lang/tests/parser/success/naturalB.dhallb b/dhall-lang/tests/parser/success/naturalB.dhallb Binary files a/dhall-lang/tests/parser/success/naturalB.dhallb and b/dhall-lang/tests/parser/success/naturalB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDottedA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitDottedA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDottedA.dhall @@ -0,0 +1,7 @@ +{- The purpose of this test is to illustrate that dotted fields are syntactic + sugar that does not survive the parsing stage. The underlying expression is + actually represented and encoded as: + + { x = { y = { z = 1 } } } +-} +{ x.y.z = 1 } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDottedB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitDottedB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDottedB.dhallb @@ -0,0 +1,1 @@ +‚¡ax‚¡ay‚¡az‚ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeA.dhall @@ -0,0 +1,1 @@ +{ `x.y`.z = 1 } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDottedEscapeB.dhallb @@ -0,0 +1,1 @@ +‚¡cx.y‚¡az‚ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesA.dhall @@ -0,0 +1,7 @@ +{- The purpose of this test is to illustrate that duplicate fields are + syntactic sugar that does not survive the parsing stage. The underlying + expression is actually represented and encoded as: + + { x = { y = 1 } ∧ { z = 1 } } +-} +{ x = { y = 1 }, x = { z = 1 } } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitDuplicatesB.dhallb @@ -0,0 +1,1 @@ +‚¡ax„‚¡ay‚‚¡az‚ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitNixLikeA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitNixLikeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitNixLikeA.dhall @@ -0,0 +1,5 @@ +{- The purpose of this test is to verify that the combination of the dotted + field notation and the duplicate record fields desugar to the desired syntax + tree +-} +{ x.y = 1, x.z = True } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitNixLikeB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitNixLikeB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitNixLikeB.dhallb @@ -0,0 +1,1 @@ +‚¡ax„‚¡ay‚‚¡azõ 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 @@ -402,21 +402,22 @@ , any : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Bool , build : ∀(a : Type) - → ( ∀(optional : Type) - → ∀(just : a → optional) - → ∀(nothing : optional) - → optional - ) + → ∀ ( build + : ∀(optional : Type) + → ∀(some : a → optional) + → ∀(none : optional) + → optional + ) → Optional a , concat : ∀(a : Type) → ∀(x : Optional (Optional a)) → Optional a , default : ∀(a : Type) → ∀(default : a) → ∀(o : Optional a) → a , filter : ∀(a : Type) → ∀(f : a → Bool) → ∀(xs : Optional a) → Optional a , fold : ∀(a : Type) - → Optional a + → ∀(o : Optional a) → ∀(optional : Type) - → ∀(just : a → optional) - → ∀(nothing : optional) + → ∀(some : a → optional) + → ∀(none : optional) → optional , head : ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a , last : ∀(a : Type) → ∀(xs : List (Optional a)) → Optional a diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOptionalA.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOptionalA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOptionalA.dhall @@ -0,0 +1,1 @@ +λ(x : Optional Bool) → merge { None = 0, Some = λ(_ : Bool) → 1 } x diff --git a/dhall-lang/tests/type-inference/success/unit/MergeOptionalB.dhall b/dhall-lang/tests/type-inference/success/unit/MergeOptionalB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/MergeOptionalB.dhall @@ -0,0 +1,1 @@ +∀(x : Optional Bool) → Natural diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsA.dhall @@ -0,0 +1,1 @@ +{ x.y.z = 1 } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsB.dhall @@ -0,0 +1,1 @@ +{ x : { y : { z : Natural } } } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeA.dhall @@ -0,0 +1,14 @@ +{- This example verifies that a Dhall interpreter correctly handles a corner + case that other languages sometimes misbehave on + + The expression should desugar like this: + + λ(r : { z : Natural }) → { x.y = 1, x = r } + + λ(r : { z : Natural }) → { x = { y = 1 }, x = r } + + λ(r : { z : Natural }) → { x = { y = 1 } ∧ r } + + ... which type-checks since `{ y = 1 }` and `r` do not collide +-} +λ(r : { z : Natural }) → { x.y = 1, x = r } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDottedFieldsMergeB.dhall @@ -0,0 +1,1 @@ +∀(r : { z : Natural }) → { x : { y : Natural, z : Natural } } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractA.dhall @@ -0,0 +1,12 @@ +{- This test illustrates that duplicate fields need not be literals in order + to be properly normalized. One or both of the duplicate fields can be + abstract because field duplication delegates its behavior to the ∧ operator + + This particular example succeeds because it desugars to: + + λ(r : { z : Natural }) → { x = { y = 1 } ∧ r } + + ... and the `∧` operator can infer the absence of conflicts due to knowing + the type of `r` +-} +λ(r : { z : Natural }) → { x = { y = 1 }, x = r } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsAbstractB.dhall @@ -0,0 +1,1 @@ +∀(r : { z : Natural }) → { x : { y : Natural, z : Natural } } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsA.dhall @@ -0,0 +1,12 @@ +{- This type-checks because the expression desugars to: + + { x = { y = 0 } ∧ { z = 0 } } + + ... which in turn type-checks due to the absence of a field collision. + + This expression is analogous to the following common Nix/TOML/Cue idiom, + which we would like to support: + + { x.y = 0, x.z = 0 } +-} +{ x = { y = 0 }, x = { z = 0 } } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitDuplicateFieldsNoCollisionsB.dhall @@ -0,0 +1,1 @@ +{ x : { y : Natural, z : Natural } } diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,8 +1,8 @@ Name: dhall -Version: 1.29.0 +Version: 1.30.0 Cabal-Version: >=1.10 Build-Type: Simple -Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 +Tested-With: GHC == 8.0.2, GHC == 8.4.3, GHC == 8.6.1 License: BSD3 License-File: LICENSE Copyright: 2017 Gabriel Gonzalez @@ -427,7 +427,7 @@ Library Hs-Source-Dirs: src Build-Depends: - base >= 4.8.2.0 && < 5 , + base >= 4.9.1.0 && < 5 , aeson >= 1.0.0.0 && < 1.5 , aeson-pretty < 0.9 , ansi-terminal >= 0.6.3.1 && < 0.11, @@ -441,12 +441,12 @@ data-fix < 0.3 , deepseq < 1.5 , Diff >= 0.2 && < 0.5 , - directory >= 1.2.2.0 && < 1.4 , + directory >= 1.3.0.0 && < 1.4 , dotgen >= 0.4.2 && < 0.5 , either >= 5 && < 5.1, exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , - haskeline >= 0.7.2.1 && < 0.8 , + haskeline >= 0.7.2.1 && < 0.9 , hashable >= 1.2 && < 1.4 , lens-family-core >= 1.0.0 && < 2.1 , megaparsec >= 7 && < 8.1 , @@ -455,14 +455,15 @@ network-uri >= 2.6 && < 2.7 , optparse-applicative >= 0.14.0.0 && < 0.16, parsers >= 0.12.4 && < 0.13, - prettyprinter >= 1.5.1 && < 1.6 , + parser-combinators , + prettyprinter >= 1.5.1 && < 1.7 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , pretty-simple < 4 , profunctors >= 3.1.2 && < 5.6 , repline >= 0.2.1.0 && < 0.3 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell < 2.16, + template-haskell >= 2.11.1.0 && < 2.16, text >= 0.11.1.0 && < 1.3 , th-lift-instances >= 0.1.13 && < 0.2 , transformers >= 0.2.0.0 && < 0.6 , @@ -542,6 +543,7 @@ Dhall.Repl Dhall.Set Dhall.Src + Dhall.Substitution Dhall.Tags Dhall.Tutorial Dhall.TypeCheck @@ -593,6 +595,7 @@ Dhall.Test.QuickCheck Dhall.Test.Regression Dhall.Test.SemanticHash + Dhall.Test.Substitution Dhall.Test.TH Dhall.Test.Tutorial Dhall.Test.TypeInference diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -33,6 +33,7 @@ , rootDirectory , sourceName , startingContext + , substitutions , normalizer , defaultInputSettings , InputSettings @@ -178,6 +179,7 @@ import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty.Internal +import qualified Dhall.Substitution import qualified Dhall.TypeCheck import qualified Dhall.Util import qualified Lens.Family @@ -335,7 +337,8 @@ -- | @since 1.16 data EvaluateSettings = EvaluateSettings - { _startingContext :: Dhall.Context.Context (Expr Src Void) + { _substitutions :: Dhall.Substitution.Substitutions Src Void + , _startingContext :: Dhall.Context.Context (Expr Src Void) , _normalizer :: Maybe (Dhall.Core.ReifiedNormalizer Void) } @@ -345,7 +348,8 @@ -- @since 1.16 defaultEvaluateSettings :: EvaluateSettings defaultEvaluateSettings = EvaluateSettings - { _startingContext = Dhall.Context.empty + { _substitutions = Dhall.Substitution.empty + , _startingContext = Dhall.Context.empty , _normalizer = Nothing } @@ -361,6 +365,18 @@ => LensLike' f EvaluateSettings (Dhall.Context.Context (Expr Src Void)) l k s = fmap (\x -> s { _startingContext = x}) (k (_startingContext s)) +-- | Access the custom substitutions. +-- +-- @since 1.30 +substitutions + :: (Functor f, HasEvaluateSettings s) + => LensLike' f s (Dhall.Substitution.Substitutions Src Void) +substitutions = evaluateSettings . l + where + l :: (Functor f) + => LensLike' f EvaluateSettings (Dhall.Substitution.Substitutions Src Void) + l k s = fmap (\x -> s { _substitutions = x }) (k (_substitutions s)) + -- | Access the custom normalizer. -- -- @since 1.16 @@ -428,31 +444,17 @@ -> IO a -- ^ The decoded value in Haskell inputWithSettings settings (Decoder {..}) txt = do - expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) - - let InputSettings {..} = settings - - let EvaluateSettings {..} = _evaluateSettings - - let transform = - Lens.Family.set Dhall.Import.normalizer _normalizer - . Lens.Family.set Dhall.Import.startingContext _startingContext - - let status = transform (Dhall.Import.emptyStatus _rootDirectory) - - expr' <- State.evalStateT (Dhall.Import.loadWith expr) status - let suffix = Dhall.Pretty.Internal.prettyToStrictText expected - let annot = case expr' of + let annotate substituted = case substituted of Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot expr' expected) + Note (Src begin end bytes') (Annot substituted expected) where bytes' = bytes <> " : " <> suffix _ -> - Annot expr' expected - _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) - let normExpr = Dhall.Core.normalizeWith (view normalizer settings) expr' + Annot substituted expected + normExpr <- inputHelper annotate settings txt + case extract normExpr of Success x -> return x Failure e -> Control.Exception.throwIO e @@ -521,7 +523,20 @@ -- ^ The Dhall program -> IO (Expr Src Void) -- ^ The fully normalized AST -inputExprWithSettings settings txt = do +inputExprWithSettings = inputHelper id + +{-| Helper function for the input* function family + +@since 1.30 +-} +inputHelper + :: (Expr Src Void -> Expr Src Void) + -> InputSettings + -> Text + -- ^ The Dhall program + -> IO (Expr Src Void) + -- ^ The fully normalized AST +inputHelper annotate settings txt = do expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) let InputSettings {..} = settings @@ -529,15 +544,18 @@ let EvaluateSettings {..} = _evaluateSettings let transform = - Lens.Family.set Dhall.Import.normalizer _normalizer + Lens.Family.set Dhall.Import.substitutions _substitutions + . Lens.Family.set Dhall.Import.normalizer _normalizer . Lens.Family.set Dhall.Import.startingContext _startingContext let status = transform (Dhall.Import.emptyStatus _rootDirectory) expr' <- State.evalStateT (Dhall.Import.loadWith expr) status - _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) expr') - pure (Dhall.Core.normalizeWith (view normalizer settings) expr') + let substituted = Dhall.Substitution.substitute expr' $ view substitutions settings + let annot = annotate substituted + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) + pure (Dhall.Core.normalizeWith (view normalizer settings) substituted) -- | Use this function to extract Haskell values directly from Dhall AST. -- The intended use case is to allow easy extraction of Dhall values for diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -305,7 +305,7 @@ 5 -> return NaturalTimes 6 -> return TextAppend 7 -> return ListAppend - 8 -> return Combine + 8 -> return (Combine Nothing) 9 -> return Prefer 10 -> return CombineTypes 11 -> return ImportAlt @@ -756,7 +756,7 @@ ListAppend l r -> encodeOperator 7 l r - Combine l r -> + Combine _ l r -> encodeOperator 8 l r Prefer l r -> diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -882,7 +882,7 @@ diffCombineExpression l@(Combine {}) r@(Combine {}) = enclosed' " " (operator "∧" <> " ") (docs l r) where - docs (Combine aL bL) (Combine aR bR) = + docs (Combine _ aL bL) (Combine _ aR bR) = Data.List.NonEmpty.cons (diffPreferExpression aL aR) (docs bL bR) docs aL aR = pure (diffPreferExpression aL aR) diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -216,7 +216,7 @@ | VRecord !(Map Text (Val a)) | VRecordLit !(Map Text (Val a)) | VUnion !(Map Text (Maybe (Val a))) - | VCombine !(Val a) !(Val a) + | VCombine !(Maybe Text) !(Val a) !(Val a) | VCombineTypes !(Val a) !(Val a) | VPrefer !(Val a) !(Val a) | VMerge !(Val a) !(Val a) !(Maybe (Val a)) @@ -288,17 +288,17 @@ VPrefer t' u' {-# INLINE vPrefer #-} -vCombine :: Val a -> Val a -> Val a -vCombine t u = +vCombine :: Maybe Text -> Val a -> Val a -> Val a +vCombine mk t u = case (t, u) of (VRecordLit m, u') | null m -> u' (t', VRecordLit m) | null m -> t' (VRecordLit m, VRecordLit m') -> - VRecordLit (Map.unionWith vCombine m m') + VRecordLit (Map.unionWith (vCombine Nothing) m m') (t', u') -> - VCombine t' u' + VCombine mk t' u' vCombineTypes :: Val a -> Val a -> Val a vCombineTypes t u = @@ -356,11 +356,11 @@ VPrefer l (VRecordLit m) -> case Map.lookup k m of Just v -> v Nothing -> go l - VCombine (VRecordLit m) r -> case Map.lookup k m of - Just v -> VField (VCombine (singletonVRecordLit v) r) k + VCombine mk (VRecordLit m) r -> case Map.lookup k m of + Just v -> VField (VCombine mk (singletonVRecordLit v) r) k Nothing -> go r - VCombine l (VRecordLit m) -> case Map.lookup k m of - Just v -> VField (VCombine l (singletonVRecordLit v)) k + VCombine mk l (VRecordLit m) -> case Map.lookup k m of + Just v -> VField (VCombine mk l (singletonVRecordLit v)) k Nothing -> go l t -> VField t k @@ -684,8 +684,8 @@ VRecordLit (Map.sort (fmap (eval env) kts)) Union kts -> VUnion (Map.sort (fmap (fmap (eval env)) kts)) - Combine t u -> - vCombine (eval env t) (eval env u) + Combine mk t u -> + vCombine mk (eval env t) (eval env u) CombineTypes t u -> vCombineTypes (eval env t) (eval env u) Prefer t u -> @@ -924,7 +924,7 @@ eqMapsBy (conv env) m m' (VUnion m, VUnion m') -> eqMapsBy (eqMaybeBy (conv env)) m m' - (VCombine t u, VCombine t' u') -> + (VCombine _ t u, VCombine _ t' u') -> conv env t t' && conv env u u' (VCombineTypes t u, VCombineTypes t' u') -> conv env t t' && conv env u u' @@ -1112,8 +1112,8 @@ RecordLit (fmap (quote env) m) VUnion m -> Union (fmap (fmap (quote env)) m) - VCombine t u -> - Combine (quote env t) (quote env u) + VCombine mk t u -> + Combine mk (quote env t) (quote env u) VCombineTypes t u -> CombineTypes (quote env t) (quote env u) VPrefer t u -> @@ -1292,8 +1292,8 @@ RecordLit (fmap go kts) Union kts -> Union (fmap (fmap go) kts) - Combine t u -> - Combine (go t) (go u) + Combine m t u -> + Combine m (go t) (go u) CombineTypes t u -> CombineTypes (go t) (go u) Prefer t u -> diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs --- a/src/Dhall/Format.hs +++ b/src/Dhall/Format.hs @@ -7,15 +7,20 @@ module Dhall.Format ( -- * Format Format(..) - , FormatMode(..) , format ) where -import Control.Exception (Exception) import Data.Monoid ((<>)) import Dhall.Pretty (CharacterSet(..), annToAnsiStyle) -import Dhall.Util (Censor, Input(..), Header(..)) +import Dhall.Util + ( Censor + , CheckFailed(..) + , Header(..) + , Input(..) + , OutputMode(..) + ) + 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 @@ -27,30 +32,16 @@ import qualified System.Console.ANSI import qualified System.IO -data NotFormatted = NotFormatted - deriving (Exception) - -instance Show NotFormatted where - show _ = "" - -- | Arguments to the `format` subcommand data Format = Format { characterSet :: CharacterSet , censor :: Censor - , formatMode :: FormatMode + , input :: Input + , outputMode :: OutputMode } -{-| The `format` subcommand can either `Modify` its input or simply `Check` - that the input is already formatted --} -data FormatMode - = Modify { inplace :: Input } - | Check { path :: Input } - -- | Implementation of the @dhall format@ subcommand -format - :: Format - -> IO () +format :: Format -> IO () format (Format {..}) = do let layoutHeaderAndExpr (Header header, expr) = Dhall.Pretty.layout @@ -58,16 +49,16 @@ <> Dhall.Pretty.prettyCharacterSet characterSet expr <> "\n") - let layoutInput input = do + let layoutInput = do headerAndExpr <- Dhall.Util.getExpressionAndHeader censor input return (layoutHeaderAndExpr headerAndExpr) - case formatMode of - Modify {..} -> do - docStream <- layoutInput inplace + case outputMode of + Write -> do + docStream <- layoutInput - case inplace of + case input of InputFile file -> do AtomicWrite.LazyText.atomicWriteFile file @@ -82,13 +73,13 @@ then (fmap annToAnsiStyle docStream) else (Pretty.unAnnotateS docStream)) - Check {..} -> do - originalText <- case path of + Check -> do + originalText <- case input of InputFile file -> Data.Text.IO.readFile file StandardInput -> Data.Text.IO.getContents - docStream <- case path of - InputFile _ -> layoutInput path + docStream <- case input of + InputFile _ -> layoutInput StandardInput -> do headerAndExpr <- Dhall.Util.getExpressionAndHeaderFromStdinText censor originalText return (layoutHeaderAndExpr headerAndExpr) @@ -97,4 +88,9 @@ if originalText == formattedText then return () - else Control.Exception.throwIO NotFormatted + else do + let command = "format" + + let modified = "formatted" + + Control.Exception.throwIO CheckFailed{..} diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs --- a/src/Dhall/Freeze.hs +++ b/src/Dhall/Freeze.hs @@ -15,25 +15,34 @@ , Intent(..) ) where +import Data.Bifunctor (first) import Data.Monoid ((<>)) import Data.Text import Dhall.Parser (Src) import Dhall.Pretty (CharacterSet) import Dhall.Syntax (Expr(..), Import(..), ImportHashed(..), ImportType(..)) -import Dhall.Util (Censor, Input(..)) +import Dhall.Util + ( Censor + , CheckFailed(..) + , Header(..) + , Input(..) + , OutputMode(..) + ) import System.Console.ANSI (hSupportsANSI) -import qualified Control.Exception +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 Dhall.Import import qualified Dhall.Optics +import qualified Dhall.Parser as Parser import qualified Dhall.Pretty import qualified Dhall.TypeCheck -import qualified Dhall.Util +import qualified Dhall.Util as Util import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.FilePath import qualified System.IO @@ -58,7 +67,7 @@ expression <- State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status case Dhall.TypeCheck.typeOf expression of - Left exception -> Control.Exception.throwIO exception + Left exception -> Exception.throwIO exception Right _ -> return () let normalizedExpression = Core.alphaNormalize (Core.normalize expression) @@ -86,7 +95,7 @@ _ -> return import_ writeExpr :: Input -> (Text, Expr Src Import) -> CharacterSet -> IO () -writeExpr inplace (header, expr) characterSet = do +writeExpr input (header, expr) characterSet = do let doc = Pretty.pretty header <> Dhall.Pretty.prettyCharacterSet characterSet expr <> "\n" @@ -95,7 +104,7 @@ let unAnnotated = Pretty.unAnnotateS stream - case inplace of + case input of InputFile file -> AtomicWrite.LazyText.atomicWriteFile file @@ -129,20 +138,18 @@ -- | Implementation of the @dhall freeze@ subcommand freeze - :: Input + :: OutputMode + -> Input -> Scope -> Intent -> CharacterSet -> Censor -> IO () -freeze inplace scope intent characterSet censor = do - let directory = case inplace of +freeze outputMode input scope intent characterSet censor = do + let directory = case input of StandardInput -> "." InputFile file -> System.FilePath.takeDirectory file - (Dhall.Util.Header header, parsedExpression) <- - Dhall.Util.getExpressionAndHeader censor inplace - let freezeScope = case scope of AllImports -> freezeImport @@ -194,6 +201,42 @@ cache expression - frozenExpression <- rewrite parsedExpression + case outputMode of + Write -> do + (Header header, parsedExpression) <- do + Util.getExpressionAndHeader censor input - writeExpr inplace (header, frozenExpression) characterSet + frozenExpression <- rewrite parsedExpression + + writeExpr input (header, frozenExpression) characterSet + + Check -> do + originalText <- case input of + InputFile file -> Text.IO.readFile file + StandardInput -> Text.IO.getContents + + let name = case input of + InputFile file -> file + StandardInput -> "(stdin)" + + (Header header, parsedExpression) <- do + Core.throws (first Parser.censor (Parser.exprAndHeaderFromText name originalText)) + + frozenExpression <- rewrite parsedExpression + + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet frozenExpression + <> "\n" + + let stream = Dhall.Pretty.layout doc + + let modifiedText = Pretty.Text.renderStrict stream + + if originalText == modifiedText + then return () + else do + let command = "freeze" + + let modified = "frozen" + + Exception.throwIO CheckFailed{..} diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -122,6 +122,7 @@ , graph , remote , toHeaders + , substitutions , normalizer , startingContext , chainImport @@ -150,10 +151,6 @@ import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Void (Void, absurd) -#if MIN_VERSION_base(4,8,0) -#else -import Data.Traversable (traverse) -#endif import Data.Typeable (Typeable) import System.FilePath (()) import Dhall.Binary (StandardVersion(..)) @@ -198,6 +195,7 @@ import qualified Dhall.Map import qualified Dhall.Parser import qualified Dhall.Pretty.Internal +import qualified Dhall.Substitution import qualified Dhall.TypeCheck import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary import qualified System.Environment @@ -607,9 +605,11 @@ return importSemantics Nothing -> do - betaNormal <- case Dhall.TypeCheck.typeWith _startingContext resolvedExpr of - Left err -> throwMissingImport (Imported _stack err) - Right _ -> return (Dhall.Core.normalizeWith _normalizer resolvedExpr) + betaNormal <- do + let substitutedExpr = Dhall.Substitution.substitute resolvedExpr _substitutions + case Dhall.TypeCheck.typeWith _startingContext substitutedExpr of + Left err -> throwMissingImport (Imported _stack err) + Right _ -> return (Dhall.Core.normalizeWith _normalizer resolvedExpr) let bytes = encodeExpression NoVersion betaNormal lift $ writeToSemisemanticCache semisemanticHash bytes @@ -1078,7 +1078,7 @@ Record a -> Record <$> mapM loadWith a RecordLit a -> RecordLit <$> mapM loadWith a Union a -> Union <$> mapM (mapM loadWith) a - Combine a b -> Combine <$> loadWith a <*> loadWith b + Combine m a b -> Combine m <$> loadWith a <*> loadWith b CombineTypes a b -> CombineTypes <$> loadWith a <*> loadWith b Prefer a b -> Prefer <$> loadWith a <*> loadWith b RecordCompletion a b -> RecordCompletion <$> loadWith a <*> loadWith b 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 @@ -36,6 +36,7 @@ import qualified Dhall.Context import qualified Dhall.Map as Map +import qualified Dhall.Substitution import qualified Data.Text -- | A fully 'chained' import, i.e. if it contains a relative path that path is @@ -90,6 +91,8 @@ , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. + , _substitutions :: Dhall.Substitution.Substitutions Src Void + , _normalizer :: Maybe (ReifiedNormalizer Void) , _startingContext :: Context (Expr Src Void) @@ -110,6 +113,8 @@ _manager = Nothing + _substitutions = Dhall.Substitution.empty + _normalizer = Nothing _startingContext = Dhall.Context.empty @@ -149,6 +154,11 @@ remote :: Functor f => LensLike' f Status (URL -> StateT Status IO Data.Text.Text) remote k s = fmap (\x -> s { _remote = x }) (k (_remote s)) + +-- | Lens from a `Status` to its `_substitutions` field +substitutions :: Functor f => LensLike' f Status (Dhall.Substitution.Substitutions Src Void) +substitutions k s = + fmap (\x -> s { _substitutions = x }) (k (_substitutions s)) -- | Lens from a `Status` to its `_normalizer` field normalizer :: Functor f => LensLike' f Status (Maybe (ReifiedNormalizer Void)) diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs --- a/src/Dhall/Lint.hs +++ b/src/Dhall/Lint.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} @@ -12,12 +13,16 @@ , removeUnusedBindings , fixAssert , fixParentPath + , removeLetInLet + , replaceOptionalBuildFold + , replaceSaturatedOptionalFold ) where import Control.Applicative ((<|>)) import Dhall.Syntax ( Binding(..) + , Const(..) , Directory(..) , Expr(..) , File(..) @@ -42,16 +47,21 @@ * fixes @let a = x ≡ y@ to be @let a = assert : x ≡ y@ * consolidates nested @let@ bindings to use a multiple-@let@ binding with 'removeLetInLet' * fixes paths of the form @.\/..\/foo@ to @..\/foo@ + * Replaces deprecated @Optional\/fold@ and @Optional\/build@ built-ins -} lint :: Expr s Import -> Expr s Import -lint = Dhall.Optics.rewriteOf subExpressions rewrite +lint = Dhall.Optics.rewriteOf subExpressions lowerPriorityRewrite + . Dhall.Optics.rewriteOf subExpressions higherPriorityRewrite where - rewrite e = - fixAssert e - <|> removeUnusedBindings e - <|> fixParentPath e - <|> removeLetInLet e + lowerPriorityRewrite e = + fixAssert e + <|> removeUnusedBindings e + <|> fixParentPath e + <|> removeLetInLet e + <|> replaceOptionalBuildFold e + higherPriorityRewrite = replaceSaturatedOptionalFold + -- | Remove unused `Let` bindings. removeUnusedBindings :: Eq a => Expr s a -> Maybe (Expr s a) -- Don't remove assertions! @@ -102,7 +112,7 @@ isOrContainsAssert (Assert _) = True isOrContainsAssert e = Lens.Family.anyOf subExpressions isOrContainsAssert e --- The difference between +-- | The difference between -- -- > let x = 1 let y = 2 in x + y -- @@ -117,3 +127,65 @@ removeLetInLet :: Expr s a -> Maybe (Expr s a) removeLetInLet (Let binding (Note _ l@Let{})) = Just (Let binding l) removeLetInLet _ = Nothing + +-- | This replaces @Optional/fold@ and @Optional/build@, both of which can be +-- implemented within the language +replaceOptionalBuildFold :: Expr s a -> Maybe (Expr s a) +replaceOptionalBuildFold OptionalBuild = + Just + (Lam "a" (Const Type) + (Lam "build" + (Pi "optional" (Const Type) + (Pi "some" (Pi "_" "a" "optional") + (Pi "none" "optional" "optional") + ) + ) + (App (App (App "build" (App Optional "a")) (Lam "x" "a" (Some "x"))) (App None "a")) + ) + ) +replaceOptionalBuildFold OptionalFold = + Just + (Lam "a" (Const Type) + (Lam "o" (App Optional "a") + (Lam "optional" (Const Type) + (Lam "some" (Pi "_" "a" "optional") + (Lam "none" "optional" + (Merge + (RecordLit + [ ("Some", "some") + , ("None", "none") + ] + ) + "o" + Nothing + ) + ) + ) + ) + ) + ) +replaceOptionalBuildFold _ = + Nothing + +-- | This replaces a saturated @Optional/fold@ with the equivalent @merge@ +-- expression +replaceSaturatedOptionalFold :: Expr s a -> Maybe (Expr s a) +replaceSaturatedOptionalFold + (App + (Core.shallowDenote -> App + (Core.shallowDenote -> App + (Core.shallowDenote -> App + (Core.shallowDenote -> App + (Core.shallowDenote -> OptionalFold) + _ + ) + o + ) + _ + ) + some + ) + none + ) = Just (Merge (RecordLit [ ("Some", some), ("None", none) ]) o Nothing) +replaceSaturatedOptionalFold _ = + Nothing diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -16,38 +16,47 @@ , parserInfoOptions -- * Execution - , command + , Dhall.Main.command , main ) where import Control.Applicative (optional, (<|>)) import Control.Exception (Handler(..), SomeException) import Control.Monad (when) +import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Void (Void) -import Dhall.Core - ( Expr(Annot) - , Import(..) - , ImportHashed(..) - , ImportType(..) - , URL(..) - , pretty - ) import Dhall.Freeze (Intent(..), Scope(..)) import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode) import Dhall.Parser (Src) import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle) import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError) -import Dhall.Util (Censor(..), Header (..), Input(..), Output(..)) import Dhall.Version (dhallVersionString) import Options.Applicative (Parser, ParserInfo) import System.Exit (ExitCode, exitFailure) import System.IO (Handle) import Text.Dot ((.->.)) +import Dhall.Core + ( Expr(Annot) + , Import(..) + , ImportHashed(..) + , ImportType(..) + , URL(..) + , pretty + ) +import Dhall.Util + ( Censor(..) + , CheckFailed(..) + , Header (..) + , Input(..) + , OutputMode(..) + , Output(..) + ) + import qualified Codec.CBOR.JSON import qualified Codec.CBOR.Read import qualified Codec.CBOR.Write @@ -73,6 +82,7 @@ import qualified Dhall.Import import qualified Dhall.Import.Types import qualified Dhall.Lint +import qualified Dhall.Parser as Parser import qualified Dhall.Map import qualified Dhall.Tags import qualified Dhall.Pretty @@ -127,11 +137,11 @@ } | Normalize { file :: Input , alpha :: Bool } | Repl - | Format { formatMode :: Dhall.Format.FormatMode } - | Freeze { inplace :: Input, all_ :: Bool, cache :: Bool } + | Format { input :: Input, outputMode :: OutputMode } + | Freeze { input :: Input, all_ :: Bool, cache :: Bool, outputMode :: OutputMode } | Hash { file :: Input } | Diff { expr1 :: Text, expr2 :: Text } - | Lint { inplace :: Input } + | Lint { input :: Input, outputMode :: OutputMode } | Tags { input :: Input , output :: Output @@ -224,7 +234,7 @@ <|> subcommand "lint" "Improve Dhall code by using newer language features and removing dead code" - (Lint <$> parseInplace) + (Lint <$> parseInplace <*> parseCheck) <|> subcommand "tags" "Generate etags file" @@ -232,11 +242,11 @@ <|> subcommand "format" "Standard code formatter for the Dhall language" - (Format <$> parseFormatMode) + (Format <$> parseInplace <*> parseCheck) <|> subcommand "freeze" "Add integrity checks to remote import statements of an expression" - (Freeze <$> parseInplace <*> parseAllFlag <*> parseCacheFlag) + (Freeze <$> parseInplace <*> parseAllFlag <*> parseCacheFlag <*> parseCheck) <|> subcommand "encode" "Encode a Dhall expression to binary" @@ -415,12 +425,17 @@ <> Options.Applicative.help "Add fallback unprotected imports when using integrity checks purely for caching purposes" ) - parseCheck = - Options.Applicative.switch - ( Options.Applicative.long "check" - <> Options.Applicative.help "Only check if the input is formatted" - ) + parseCheck = fmap adapt switch + where + adapt True = Check + adapt False = Write + switch = + Options.Applicative.switch + ( Options.Applicative.long "check" + <> Options.Applicative.help "Only check if the input is formatted" + ) + parseDirectoryTreeOutput = Options.Applicative.strOption ( Options.Applicative.long "output" @@ -428,11 +443,6 @@ <> Options.Applicative.metavar "PATH" ) - parseFormatMode = adapt <$> parseCheck <*> parseInplace - where - adapt True path = Dhall.Format.Check {..} - adapt False inplace = Dhall.Format.Modify {..} - -- | `ParserInfo` for the `Options` type parserInfoOptions :: ParserInfo Options parserInfoOptions = @@ -686,7 +696,7 @@ let intent = if cache then Cache else Secure - Dhall.Freeze.freeze inplace scope intent characterSet censor + Dhall.Freeze.freeze outputMode input scope intent characterSet censor Hash {..} -> do expression <- getExpression file @@ -702,18 +712,49 @@ Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression) Lint {..} -> do - (Header header, expression) <- getExpressionAndHeader inplace + case outputMode of + Write -> do + (Header header, expression) <- do + getExpressionAndHeader input - let lintedExpression = Dhall.Lint.lint expression + let lintedExpression = Dhall.Lint.lint expression - let doc = Pretty.pretty header - <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression - case inplace of - InputFile file -> writeDocToFile file doc + case input of + InputFile file -> writeDocToFile file doc - StandardInput -> renderDoc System.IO.stdout doc + StandardInput -> renderDoc System.IO.stdout doc + Check -> do + originalText <- case input of + InputFile file -> Data.Text.IO.readFile file + StandardInput -> Data.Text.IO.getContents + + let name = case input of + InputFile file -> file + StandardInput -> "(stdin)" + + (Header header, expression) <- do + Dhall.Core.throws (first Parser.censor (Parser.exprAndHeaderFromText name originalText)) + + let lintedExpression = Dhall.Lint.lint expression + + let doc = Pretty.pretty header + <> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression + + let stream = Dhall.Pretty.layout doc + + let modifiedText = Pretty.Text.renderStrict stream <> "\n" + + if originalText == modifiedText + then return () + else do + let modified = "linted" + + Control.Exception.throwIO CheckFailed{ command = "lint", ..} + Encode {..} -> do expression <- getExpression file @@ -813,4 +854,5 @@ main :: IO () main = do options <- Options.Applicative.execParser parserInfoOptions - command options + + Dhall.Main.command options diff --git a/src/Dhall/Map.hs b/src/Dhall/Map.hs --- a/src/Dhall/Map.hs +++ b/src/Dhall/Map.hs @@ -80,6 +80,7 @@ import qualified Data.Map import qualified Data.Set import qualified GHC.Exts +import qualified Language.Haskell.TH.Syntax as Syntax import qualified Prelude {-| A `Map` that remembers the original ordering of keys @@ -92,14 +93,16 @@ data Map k v = Map (Data.Map.Map k v) (Keys k) deriving (Data, Generic, NFData) -instance (Data k, Data v, Lift k, Lift v, Ord k) => Lift (Map k v) +instance (Data k, Data v, Lift k, Lift v, Ord k) => Lift (Map k v) where + lift = Syntax.liftData data Keys a = Sorted | Original [a] deriving (Data, Generic, NFData) -instance (Data a, Lift a) => Lift (Keys a) +instance (Data a, Lift a) => Lift (Keys a) where + lift = Syntax.liftData instance (Ord k, Eq v) => Eq (Map k v) where m1 == m2 = diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -232,10 +232,10 @@ shift d v (Union a) = Union a' where a' = fmap (fmap (shift d v)) a -shift d v (Combine a b) = Combine a' b' +shift d v (Combine a b c) = Combine a b' c' where - a' = shift d v a b' = shift d v b + c' = shift d v c shift d v (CombineTypes a b) = CombineTypes a' b' where a' = shift d v a @@ -407,10 +407,10 @@ subst x e (Union kts) = Union kts' where kts' = fmap (fmap (subst x e)) kts -subst x e (Combine a b) = Combine a' b' +subst x e (Combine a b c) = Combine a b' c' where - a' = subst x e a b' = subst x e b + c' = subst x e c subst x e (CombineTypes a b) = CombineTypes a' b' where a' = subst x e a @@ -864,7 +864,7 @@ Union kts -> Union . Dhall.Map.sort <$> kts' where kts' = traverse (traverse loop) kts - Combine x y -> decide <$> loop x <*> loop y + Combine mk x y -> decide <$> loop x <*> loop y where decide (RecordLit m) r | Data.Foldable.null m = r @@ -873,7 +873,7 @@ decide (RecordLit m) (RecordLit n) = RecordLit (Dhall.Map.unionWith decide m n) decide l r = - Combine l r + Combine mk l r CombineTypes x y -> decide <$> loop x <*> loop y where decide (Record m) r | Data.Foldable.null m = @@ -972,11 +972,11 @@ Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of Just v -> pure v Nothing -> loop (Field l x) - Combine (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Combine (singletonRecordLit v) r_) x) + Combine m (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Combine m (singletonRecordLit v) r_) x) Nothing -> loop (Field r_ x) - Combine l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Combine l (singletonRecordLit v)) x) + Combine m l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Combine m l (singletonRecordLit v)) x) Nothing -> loop (Field l x) _ -> pure (Field r' x) Project x (Left fields)-> do @@ -1180,7 +1180,7 @@ Record kts -> Dhall.Map.isSorted kts && all loop kts RecordLit kvs -> Dhall.Map.isSorted kvs && all loop kvs Union kts -> Dhall.Map.isSorted kts && all (all loop) kts - Combine x y -> loop x && loop y && decide x y + Combine _ x y -> loop x && loop y && decide x y where decide (RecordLit m) _ | Data.Foldable.null m = False decide _ (RecordLit n) | Data.Foldable.null n = False @@ -1215,8 +1215,8 @@ Project _ _ -> False Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r Prefer _ (RecordLit _) -> False - Combine (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r - Combine _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r + Combine _ (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r + Combine _ _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r _ -> loop r Project r p -> loop r && case p of diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# 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 @@ -257,3 +257,11 @@ err k _v1 _v2 = Text.Parser.Combinators.unexpected ("duplicate field: " ++ Data.Text.unpack k) + +toMapWith + :: (Text -> Parser a -> Parser a -> Parser a) + -> [(Text, a)] + -> Parser (Map Text a) +toMapWith combine kvs = sequence m + where + m = Dhall.Map.fromListWithKey combine (map (\(k, v) -> (k, pure v)) kvs) diff --git a/src/Dhall/Parser/Expression.hs b/src/Dhall/Parser/Expression.hs --- a/src/Dhall/Parser/Expression.hs +++ b/src/Dhall/Parser/Expression.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedLists #-} @@ -8,7 +7,7 @@ -- | Parsing Dhall expressions. module Dhall.Parser.Expression where -import Control.Applicative (Alternative(..), optional) +import Control.Applicative (liftA2, Alternative(..), optional) import Data.ByteArray.Encoding (Base(..)) import Data.Foldable (foldl') import Data.Functor (void) @@ -20,11 +19,12 @@ import Text.Parser.Combinators (choice, try, ()) import qualified Control.Monad +import qualified Control.Monad.Combinators.NonEmpty as Combinators.NonEmpty import qualified Data.ByteArray.Encoding import qualified Data.ByteString -import qualified Data.Char as Char +import qualified Data.Char as Char import qualified Data.List -import qualified Data.List.NonEmpty +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence import qualified Data.Text import qualified Data.Text.Encoding @@ -184,7 +184,7 @@ return (Binding (Just src0) c (Just src1) d (Just src3) f) - as <- Data.List.NonEmpty.some1 binding + as <- NonEmpty.some1 binding try (_in *> nonemptyWhitespace) @@ -277,19 +277,19 @@ operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)] operatorParsers = - [ ImportAlt <$ _importAlt <* nonemptyWhitespace - , BoolOr <$ _or <* whitespace - , NaturalPlus <$ _plus <* nonemptyWhitespace - , TextAppend <$ _textAppend <* whitespace - , ListAppend <$ _listAppend <* whitespace - , BoolAnd <$ _and <* whitespace - , Combine <$ _combine <* whitespace - , Prefer <$ _prefer <* whitespace - , CombineTypes <$ _combineTypes <* whitespace - , NaturalTimes <$ _times <* whitespace - , BoolEQ <$ _doubleEqual <* whitespace - , BoolNE <$ _notEqual <* whitespace - , Equivalent <$ _equivalent <* whitespace + [ ImportAlt <$ _importAlt <* nonemptyWhitespace + , BoolOr <$ _or <* whitespace + , NaturalPlus <$ _plus <* nonemptyWhitespace + , TextAppend <$ _textAppend <* whitespace + , ListAppend <$ _listAppend <* whitespace + , BoolAnd <$ _and <* whitespace + , Combine Nothing <$ _combine <* whitespace + , Prefer <$ _prefer <* whitespace + , CombineTypes <$ _combineTypes <* whitespace + , NaturalTimes <$ _times <* whitespace + , BoolEQ <$ _doubleEqual <* whitespace + , BoolNE <$ _notEqual <* whitespace + , Equivalent <$ _equivalent <* whitespace ] applicationExpression = do @@ -695,12 +695,8 @@ alternative2 = return (Record mempty) nonEmptyRecordTypeOrLiteral = do - a <- anyLabel - - whitespace - let nonEmptyRecordType = do - _colon + a <- try (anyLabel <* whitespace <* _colon) nonemptyWhitespace @@ -731,35 +727,45 @@ return (Record m) - let nonEmptyRecordLiteral = do - _equal + let keysValue = do + keys <- Combinators.NonEmpty.sepBy1 anyLabel (try (whitespace *> _dot) *> whitespace) whitespace - b <- expression + _equal whitespace - e <- Text.Megaparsec.many (do - _comma + value <- expression - whitespace + whitespace - c <- anyLabel + let cons key (key', values) = + (key, RecordLit [ (key', values) ]) - whitespace + let nil = (NonEmpty.last keys, value) - _equal + return (foldr cons nil (NonEmpty.init keys)) - whitespace + let nonEmptyRecordLiteral = do + (a, b) <- keysValue - d <- expression + e <- Text.Megaparsec.many (do + _comma whitespace + (c, d) <- keysValue + return (c, d) ) - m <- toMap ((a, b) : e) + {- The `flip` is necessary because `toMapWith` is internally + based on `Data.Map.fromListWithKey` which combines keys + in reverse order + -} + let combine k = liftA2 (flip (Combine (Just k))) + + m <- toMapWith combine ((a, b) : e) return (RecordLit m) 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 @@ -111,7 +111,7 @@ import Control.Applicative (Alternative(..), optional) import Data.Bits ((.&.)) -import Data.Functor (void) +import Data.Functor (void, ($>)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Dhall.Syntax @@ -121,6 +121,7 @@ import qualified Control.Monad import qualified Data.Char as Char +import qualified Data.Foldable import qualified Data.HashSet import qualified Data.List.NonEmpty import qualified Data.Text @@ -134,8 +135,6 @@ import Numeric.Natural (Natural) import Prelude hiding (const, pi) -import qualified Text.Parser.Token - -- | Returns `True` if the given `Int` is a valid Unicode codepoint validCodepoint :: Int -> Bool validCodepoint c = @@ -191,7 +190,7 @@ doubleLiteral :: Parser Double doubleLiteral = (do sign <- signPrefix <|> pure id - a <- Text.Parser.Token.double + a <- Text.Megaparsec.Char.Lexer.float return (sign a) ) "literal" {-| Parse a signed @Infinity@ @@ -223,8 +222,29 @@ naturalLiteral :: Parser Natural naturalLiteral = (do a <- try (char '0' >> char 'x' >> Text.Megaparsec.Char.Lexer.hexadecimal) - <|> Text.Megaparsec.Char.Lexer.decimal + <|> decimal + <|> (char '0' $> 0) return a ) "literal" + where + decimal = do + n <- headDigit + ns <- many tailDigit + return (mkNum (n:ns)) + where + headDigit = decimalDigit nonZeroDigit "non-zero digit" + where + nonZeroDigit c = '1' <= c && c <= '9' + + tailDigit = decimalDigit digit "digit" + + decimalDigit predicate = do + c <- Text.Parser.Char.satisfy predicate + return (fromIntegral (Char.ord c - Char.ord '0')) + + mkNum = Data.Foldable.foldl' step 0 + where + step acc x = acc * 10 + x + {-| Parse an identifier (i.e. a variable or built-in) diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -64,11 +63,8 @@ , rparen ) where -#if MIN_VERSION_base(4,8,0) -#else -import Control.Applicative (Applicative(..), (<$>)) -#endif import Data.Foldable +import Data.List.NonEmpty (NonEmpty) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty, space) @@ -83,12 +79,13 @@ import qualified Data.Char import qualified Data.HashSet import qualified Data.List +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set import qualified Data.Text as Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty -import qualified Dhall.Map +import qualified Dhall.Map as Map import qualified Dhall.Set {-| Annotation type used to tag elements in a pretty-printed document for @@ -441,6 +438,10 @@ prettyAnyLabel :: Text -> Doc Ann prettyAnyLabel = prettyLabelShared True +prettyAnyLabels :: NonEmpty Text -> Doc Ann +prettyAnyLabels = + mconcat . Pretty.punctuate dot . fmap prettyAnyLabel . toList + prettyLabels :: Set Text -> Doc Ann prettyLabels a | Data.Set.null (Dhall.Set.toSet a) = @@ -810,12 +811,12 @@ prettyCombineExpression a0 prettyCombineExpression :: Pretty a => Expr Src a -> Doc Ann - prettyCombineExpression a0@(Combine _ _) = + prettyCombineExpression a0@(Combine _ _ _) = prettyOperator (combine characterSet) (docs a0) where - docs (Combine a b) = prettyPreferExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyPreferExpression b ] + docs (Combine _ a b) = prettyPreferExpression b : docs a + docs (Note _ b) = docs b + docs b = [ prettyPreferExpression b ] prettyCombineExpression (Note _ a) = prettyCombineExpression a prettyCombineExpression a0 = @@ -1053,8 +1054,9 @@ short = lparen <> prettyExpression a <> rparen - prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr Src a) -> (Doc Ann, Doc Ann) - prettyKeyValue separator (key, val) = + prettyKeyValue + :: Pretty a => (k -> Doc Ann) -> Doc Ann -> (k, Expr Src a) -> (Doc Ann, Doc Ann) + prettyKeyValue prettyKey separator (key, val) = duplicate (Pretty.group (Pretty.flatAlt long short)) where completion _T r = @@ -1067,25 +1069,38 @@ _ -> prettySelectorExpression r - short = prettyAnyLabel key + short = prettyKey key <> " " <> separator <> " " <> prettyExpression val long = - prettyAnyLabel key + prettyKey key <> " " <> separator <> case shallowDenote val of Some val' -> - " Some" + " " <> builtin "Some" <> case shallowDenote val' of RecordCompletion _T r -> completion _T r + ListLit _ xs + | not (null xs) -> + Pretty.hardline + <> " " + <> prettyExpression val' _ -> Pretty.hardline <> " " <> prettyImportExpression val' + ToMap val' Nothing -> + " " <> keyword "toMap" + <> case shallowDenote val' of + RecordCompletion _T r -> + completion _T r + _ -> Pretty.hardline + <> " " + <> prettyImportExpression val' RecordCompletion _T r -> completion _T r ListLit _ xs @@ -1100,29 +1115,37 @@ prettyRecord :: Pretty a => Map Text (Expr Src a) -> Doc Ann prettyRecord = - braces . map (prettyKeyValue colon) . Dhall.Map.toList + braces . map (prettyKeyValue prettyAnyLabel colon) . Map.toList prettyRecordLit :: Pretty a => Map Text (Expr Src a) -> Doc Ann prettyRecordLit a | Data.Foldable.null a = lbrace <> equals <> rbrace | otherwise = - braces (map (prettyKeyValue equals) (Dhall.Map.toList a)) + braces (map prettyRecordEntry (Map.toList consolidated)) + where + consolidated = consolidateRecordLiteral a + prettyRecordEntry = prettyKeyValue prettyAnyLabels equals + prettyCompletionLit :: Pretty a => Int -> Map Text (Expr Src a) -> Doc Ann prettyCompletionLit n a | Data.Foldable.null a = lbrace <> equals <> rbrace | otherwise = - hangingBraces n (map (prettyKeyValue equals) (Dhall.Map.toList a)) + hangingBraces n (map prettyRecordEntry (Map.toList consolidated)) + where + consolidated = consolidateRecordLiteral a - prettyAlternative (key, Just val) = prettyKeyValue colon (key, val) + prettyRecordEntry = prettyKeyValue prettyAnyLabels equals + + prettyAlternative (key, Just val) = prettyKeyValue prettyAnyLabel colon (key, val) prettyAlternative (key, Nothing ) = duplicate (prettyAnyLabel key) prettyUnion :: Pretty a => Map Text (Maybe (Expr Src a)) -> Doc Ann prettyUnion = - angles . map prettyAlternative . Dhall.Map.toList + angles . map prettyAlternative . Map.toList prettyChunks :: Pretty a => Chunks Src a -> Doc Ann prettyChunks chunks@(Chunks a b) @@ -1281,6 +1304,25 @@ -- | Pretty-print a value pretty_ :: Pretty a => a -> Text pretty_ = prettyToStrictText + +{- This utility function converts + `{ x = { y = { z = 1 } } }` to `{ x.y.z. = 1 }` +-} +consolidateRecordLiteral + :: Map Text (Expr s a) -> Map (NonEmpty Text) (Expr s a) +consolidateRecordLiteral = Map.fromList . fmap adapt . Map.toList + where + adapt :: (Text, Expr s a) -> (NonEmpty Text, Expr s a) + adapt (key, expression) = + case shallowDenote expression of + RecordLit m -> + case fmap adapt (Map.toList m) of + [ (keys, expression') ] -> + (NonEmpty.cons key keys, expression') + _ -> + (pure key, RecordLit m) + _ -> + (pure key, expression) -- | Escape a `Text` literal using Dhall's escaping rules for single-quoted -- @Text@ diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs --- a/src/Dhall/Repl.hs +++ b/src/Dhall/Repl.hs @@ -124,7 +124,7 @@ :: MonadIO m => String -> m ( Dhall.Expr Dhall.Src Void) parseAndLoad src = do parsed <- - case Dhall.exprFromText "(stdin)" ( Text.pack src ) of + case Dhall.exprFromText "(stdin)" (Text.pack src <> "\n") of Left e -> liftIO ( throwIO e ) diff --git a/src/Dhall/Set.hs b/src/Dhall/Set.hs --- a/src/Dhall/Set.hs +++ b/src/Dhall/Set.hs @@ -36,6 +36,7 @@ import qualified Data.Set import qualified Data.Sequence import qualified Data.Foldable +import qualified Language.Haskell.TH.Syntax as Syntax {-| This is a variation on @"Data.Set".`Data.Set.Set`@ that remembers the original order of elements. This ensures that ordering is not lost when @@ -53,7 +54,8 @@ compare (Set _ x) (Set _ y) = compare x y {-# INLINABLE compare #-} -instance (Data a, Lift a, Ord a) => Lift (Set a) +instance (Data a, Lift a, Ord a) => Lift (Set a) where + lift = Syntax.liftData instance Foldable Set where foldMap f (Set _ x) = foldMap f x diff --git a/src/Dhall/Substitution.hs b/src/Dhall/Substitution.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Substitution.hs @@ -0,0 +1,34 @@ +{- | This module provides types and functions used in the substitution step + which is done before type checking and normalization. +-} + +module Dhall.Substitution where + +import Data.Text (Text) +import Dhall.Normalize (subst) +import Dhall.Syntax (Expr, Var(..)) + +import qualified Dhall.Map + +{- | Substitutions map variables to arbitrary Dhall expressions. + Note that we use "Dhall.Map.Map" as an underlying structure. Hence we respect insertion order. +-} +type Substitutions s a = Dhall.Map.Map Text (Expr s a) + +{- | An empty substitution map. +-} +empty :: Substitutions s a +empty = Dhall.Map.empty + +-- | @substitute expr s@ replaces all variables in @expr@ (or its subexpression) with their substitute. +-- For example, if the substitution map maps the variable @Foo@ to the text \"Foo\" all occurrences of @Foo@ with the text \"Foo\". +-- +-- The substitutions will be done in the order they are inserted into the substitution map: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > substitute (Dhall.Core.Var "Foo") (Dhall.Map.fromList [("Foo", Dhall.Core.Var "Bar"), ("Bar", Dhall.Core.Var "Baz")]) +-- +-- results in @Dhall.Core.Var \"Baz\"@ since we first substitute \"Foo\" with \"Bar\" and then the resulting \"Bar\" with the final \"Baz\". +substitute :: Expr s a -> Substitutions s a -> Expr s a +substitute expr = foldl (\memo (k, v) -> subst (V k 0) v memo) expr . Dhall.Map.toList diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -93,9 +93,10 @@ import qualified Data.HashSet import qualified Data.List.NonEmpty import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Dhall.Crypto -import qualified Network.URI as URI +import qualified Language.Haskell.TH.Syntax as Syntax +import qualified Network.URI as URI {-| Constants for a pure type system @@ -119,7 +120,8 @@ data Const = Type | Kind | Sort deriving (Show, Eq, Ord, Data, Bounded, Enum, Generic, NFData) -instance Lift Const +instance Lift Const where + lift = Syntax.liftData instance Pretty Const where pretty = Pretty.unAnnotate . prettyConst @@ -159,7 +161,8 @@ data Var = V Text !Int deriving (Data, Generic, Eq, Ord, Show, NFData) -instance Lift Var +instance Lift Var where + lift = Syntax.liftData instance IsString Var where fromString str = V (fromString str) 0 @@ -238,7 +241,8 @@ data Chunks s a = Chunks [(Text, Expr s a)] Text deriving (Functor, Foldable, Generic, Traversable, Show, Eq, Ord, Data, NFData) -instance (Lift s, Lift a, Data s, Data a) => Lift (Chunks s a) +instance (Lift s, Lift a, Data s, Data a) => Lift (Chunks s a) where + lift = Syntax.liftData instance Data.Semigroup.Semigroup (Chunks s a) where Chunks xysL zL <> Chunks [] zR = @@ -415,8 +419,13 @@ | RecordLit (Map Text (Expr s a)) -- | > Union [(k1, Just t1), (k2, Nothing)] ~ < k1 : t1 | k2 > | Union (Map Text (Maybe (Expr s a))) - -- | > Combine x y ~ x ∧ y - | Combine (Expr s a) (Expr s a) + -- | > Combine Nothing x y ~ x ∧ y + -- + -- The first field is a `Just` when the `Combine` operator is introduced + -- as a result of desugaring duplicate record fields: + -- + -- > RecordLit [ (k, Combine (Just k) x y) ] ~ { k = x, k = y } + | Combine (Maybe Text) (Expr s a) (Expr s a) -- | > CombineTypes x y ~ x ⩓ y | CombineTypes (Expr s a) (Expr s a) -- | > Prefer x y ~ x ⫽ y @@ -461,7 +470,8 @@ -- | Note that this 'Ord' instance inherits `DhallDouble`'s defects. deriving instance (Ord s, Ord a) => Ord (Expr s a) -instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a) +instance (Lift s, Lift a, Data s, Data a) => Lift (Expr s a) where + lift = Syntax.liftData -- This instance is hand-written due to the fact that deriving -- it does not give us an INLINABLE pragma. We annotate this fmap @@ -525,7 +535,7 @@ fmap f (Record r) = Record (fmap (fmap f) r) fmap f (RecordLit r) = RecordLit (fmap (fmap f) r) fmap f (Union u) = Union (fmap (fmap (fmap f)) u) - fmap f (Combine e1 e2) = Combine (fmap f e1) (fmap f e2) + fmap f (Combine m e1 e2) = Combine m (fmap f e1) (fmap f e2) fmap f (CombineTypes e1 e2) = CombineTypes (fmap f e1) (fmap f e2) fmap f (Prefer e1 e2) = Prefer (fmap f e1) (fmap f e2) fmap f (RecordCompletion e1 e2) = RecordCompletion (fmap f e1) (fmap f e2) @@ -610,7 +620,7 @@ Record a >>= k = Record (fmap (>>= k) a) RecordLit a >>= k = RecordLit (fmap (>>= k) a) Union a >>= k = Union (fmap (fmap (>>= k)) a) - Combine a b >>= k = Combine (a >>= k) (b >>= k) + Combine a b c >>= k = Combine a (b >>= k) (c >>= k) CombineTypes a b >>= k = CombineTypes (a >>= k) (b >>= k) Prefer a b >>= k = Prefer (a >>= k) (b >>= k) RecordCompletion a b >>= k = RecordCompletion (a >>= k) (b >>= k) @@ -682,7 +692,7 @@ first k (Record a ) = Record (fmap (first k) a) first k (RecordLit a ) = RecordLit (fmap (first k) a) first k (Union a ) = Union (fmap (fmap (first k)) a) - first k (Combine a b ) = Combine (first k a) (first k b) + first k (Combine a b c ) = Combine a (first k b) (first k c) first k (CombineTypes a b ) = CombineTypes (first k a) (first k b) first k (Prefer a b ) = Prefer (first k a) (first k b) first k (RecordCompletion a b) = RecordCompletion (first k a) (first k b) @@ -815,7 +825,7 @@ subExpressions f (Record a) = Record <$> traverse f a subExpressions f ( RecordLit a ) = RecordLit <$> traverse f a subExpressions f (Union a) = Union <$> traverse (traverse f) a -subExpressions f (Combine a b) = Combine <$> f a <*> f b +subExpressions f (Combine a b c) = Combine a <$> f b <*> f c subExpressions f (CombineTypes a b) = CombineTypes <$> f a <*> f b subExpressions f (Prefer a b) = Prefer <$> f a <*> f b subExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b @@ -1121,7 +1131,7 @@ denote (Record a ) = Record (fmap denote a) denote (RecordLit a ) = RecordLit (fmap denote a) denote (Union a ) = Union (fmap (fmap denote) a) -denote (Combine a b ) = Combine (denote a) (denote b) +denote (Combine _ b c ) = Combine Nothing (denote b) (denote c) denote (CombineTypes a b ) = CombineTypes (denote a) (denote b) denote (Prefer a b ) = Prefer (denote a) (denote b) denote (RecordCompletion a b) = RecordCompletion (denote a) (denote b) diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -- | Template Haskell utilities @@ -7,6 +9,8 @@ ( -- * Template Haskell staticDhallExpression , makeHaskellTypeFromUnion + , makeHaskellTypes + , HaskellType(..) ) where import Data.Monoid ((<>)) @@ -21,19 +25,17 @@ , Exp(..) , Q , Type(..) -#if MIN_VERSION_template_haskell(2,11,0) , Bang(..) , SourceStrictness(..) , SourceUnpackedness(..) -#else - , Strict(..) -#endif ) +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 Dhall +import qualified Dhall.Core as Core import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Util @@ -79,11 +81,22 @@ liftText = fmap (AppE (VarE 'Text.pack)) . Syntax.lift . Text.unpack {-| Convert a Dhall type to a Haskell type that does not require any new - data declarations + data declarations beyond the data declarations supplied as the first + argument -} -toSimpleHaskellType :: Pretty a => Expr s a -> Q Type -toSimpleHaskellType dhallType = - case dhallType of +toNestedHaskellType + :: (Eq a, Pretty a) + => [HaskellType (Expr s a)] + -- ^ All Dhall-derived data declarations + -- + -- Used to replace complex types with references to one of these + -- data declarations when the types match + -> Expr s a + -- ^ Dhall expression to convert to a simple Haskell type + -> Q Type +toNestedHaskellType haskellTypes = loop + where + loop dhallType = case dhallType of Bool -> do return (ConT ''Bool) @@ -100,23 +113,27 @@ return (ConT ''Text) App List dhallElementType -> do - haskellElementType <- toSimpleHaskellType dhallElementType + haskellElementType <- loop dhallElementType return (AppT (ConT ''[]) haskellElementType) App Optional dhallElementType -> do - haskellElementType <- toSimpleHaskellType dhallElementType + haskellElementType <- loop dhallElementType return (AppT (ConT ''Maybe) haskellElementType) - _ -> do + _ | Just haskellType <- List.find predicate haskellTypes -> do + let name = Syntax.mkName (Text.unpack (typeName haskellType)) + + return (ConT name) + | otherwise -> do let document = mconcat - [ "Unsupported simple type\n" + [ "Unsupported nested type\n" , " \n" - , "Explanation: Not all Dhall alternative types can be converted to Haskell \n" - , "constructor types. Specifically, only the following simple Dhall types are \n" - , "supported as an alternative type or a field of an alternative type: \n" + , "Explanation: Not all Dhall types can be nested within Haskell datatype \n" + , "declarations. Specifically, only the following simple Dhall types are supported\n" + , "as a nested type inside of a data declaration: \n" , " \n" , "• ❰Bool❱ \n" , "• ❰Double❱ \n" @@ -125,34 +142,102 @@ , "• ❰Text❱ \n" , "• ❰List a❱ (where ❰a❱ is also a simple type) \n" , "• ❰Optional a❱ (where ❰a❱ is also a simple type) \n" + , "• Another matching datatype declaration \n" , " \n" - , "The Haskell datatype generation logic encountered the following complex \n" - , "Dhall type: \n" + , "The Haskell datatype generation logic encountered the following Dhall type: \n" , " \n" , " " <> Dhall.Util.insert dhallType <> "\n" , " \n" - , "... where a simpler type was expected." + , "... which did not fit any of the above criteria." ] let message = Pretty.renderString (Dhall.Pretty.layout document) fail message + where + predicate haskellType = + Core.judgmentallyEqual (code haskellType) dhallType --- | Convert a Dhall type to the corresponding Haskell constructor type -toConstructor :: Pretty a => (Text, Maybe (Expr s a)) -> Q Con -toConstructor (constructorName, maybeAlternativeType) = do +-- | Convert a Dhall type to the corresponding Haskell datatype declaration +toDeclaration + :: (Eq a, Pretty a) + => [HaskellType (Expr s a)] + -> HaskellType (Expr s a) + -> Q Dec +toDeclaration haskellTypes MultipleConstructors{..} = do + case code of + Union kts -> do + let name = Syntax.mkName (Text.unpack typeName) + + constructors <- traverse (toConstructor haskellTypes) (Dhall.Map.toList kts ) + + return (DataD [] name [] Nothing constructors []) + + _ -> do + let document = + mconcat + [ "Dhall.TH.makeHaskellTypes: Not a union type\n" + , " \n" + , "Explanation: This function expects the ❰code❱ field of ❰MultipleConstructors❱ to\n" + , "evaluate to a union type. \n" + , " \n" + , "For example, this is a valid Dhall union type that this function would accept: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────────────────────────────────┐ \n" + , " │ Dhall.TH.makeHaskellTypes (MultipleConstructors \"T\" \"< A | B >\") │ \n" + , " └──────────────────────────────────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "... which corresponds to this Haskell type declaration: \n" + , " \n" + , " \n" + , " ┌────────────────┐ \n" + , " │ data T = A | B │ \n" + , " └────────────────┘ \n" + , " \n" + , " \n" + , "... but the following Dhall type is rejected due to being a bare record type: \n" + , " \n" + , " \n" + , " ┌──────────────────────────────────────────────┐ \n" + , " │ Dhall.TH.makeHaskellTypes \"T\" \"{ x : Bool }\" │ Not valid \n" + , " └──────────────────────────────────────────────┘ \n" + , " \n" + , " \n" + , "The Haskell datatype generation logic encountered the following Dhall type: \n" + , " \n" + , " " <> Dhall.Util.insert code <> "\n" + , " \n" + , "... which is not a union type." + ] + + let message = Pretty.renderString (Dhall.Pretty.layout document) + + fail message +toDeclaration haskellTypes SingleConstructor{..} = do + let name = Syntax.mkName (Text.unpack typeName) + + constructor <- toConstructor haskellTypes (constructorName, Just code) + + return (DataD [] name [] Nothing [constructor] []) + +-- | Convert a Dhall type to the corresponding Haskell constructor +toConstructor + :: (Eq a, Pretty a) + => [HaskellType (Expr s a)] + -> (Text, Maybe (Expr s a)) + -- ^ @(constructorName, fieldType)@ + -> Q Con +toConstructor haskellTypes (constructorName, maybeAlternativeType) = do let name = Syntax.mkName (Text.unpack constructorName) -#if MIN_VERSION_template_haskell(2,11,0) let bang = Bang NoSourceUnpackedness NoSourceStrictness -#else - let bang = NotStrict -#endif case maybeAlternativeType of Just (Record kts) -> do let process (key, dhallFieldType) = do - haskellFieldType <- toSimpleHaskellType dhallFieldType + haskellFieldType <- toNestedHaskellType haskellTypes dhallFieldType return (Syntax.mkName (Text.unpack key), bang, haskellFieldType) @@ -161,7 +246,7 @@ return (RecC name varBangTypes) Just dhallAlternativeType -> do - haskellAlternativeType <- toSimpleHaskellType dhallAlternativeType + haskellAlternativeType <- toNestedHaskellType haskellTypes dhallAlternativeType return (NormalC name [ (bang, haskellAlternativeType) ]) @@ -171,10 +256,6 @@ -- | Generate a Haskell datatype declaration from a Dhall union type where -- each union alternative corresponds to a Haskell constructor -- --- This comes in handy if you need to keep a Dhall type and Haskell type in --- sync. You make the Dhall type the source of truth and use Template Haskell --- to generate the matching Haskell type declaration from the Dhall type. --- -- For example, this Template Haskell splice: -- -- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >" @@ -183,12 +264,78 @@ -- -- > data T = A {x :: GHC.Types.Bool} | B -- --- If you are starting from an existing record type that you want to convert to --- a Haskell type, wrap the record type in a union with one alternative, like --- this: +-- This is a special case of `Dhall.TH.makeHaskellTypes`: -- --- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : ./recordType.dhall >" +-- > makeHaskellTypeFromUnion typeName code = +-- > makeHaskellTypes [ MultipleConstructors{..} ] +makeHaskellTypeFromUnion + :: Text + -- ^ Name of the generated Haskell type + -> Text + -- ^ Dhall code that evaluates to a union type + -> Q [Dec] +makeHaskellTypeFromUnion typeName code = + makeHaskellTypes [ MultipleConstructors{..} ] + +-- | Used by `makeHaskellTypes` to specify how to generate Haskell types +data HaskellType code + -- | Generate a Haskell type with more than one constructor from a Dhall + -- 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 + -- + -- To generate a constructor with multiple named fields, supply a Dhall + -- record type. This does not support more than one anonymous field. + | SingleConstructor + { typeName :: Text + -- ^ Name of the generated Haskell type + , constructorName :: Text + -- ^ Name of the constructor + , code :: code + -- ^ Dhall code that evaluates to a type + } + deriving (Functor, Foldable, Traversable) + +-- | Generate a Haskell datatype declaration with one constructor from a Dhall +-- 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 +-- to generate the matching Haskell type declarations from the Dhall types. +-- +-- For example, given this Dhall code: +-- +-- > -- ./Department.dhall +-- > < Sales | Engineering | Marketing > +-- +-- > -- ./Employee.dhall +-- > { name : Text, department : ./Department.dhall } +-- +-- ... this Template Haskell splice: +-- +-- > Dhall.TH.makeHaskellTypes +-- > [ MultipleConstructors "Department" "./tests/th/Department.dhall" +-- > , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall" +-- > ] +-- +-- ... generates this Haskell code: +-- +-- > data Department = Engineering | Marketing | Sales +-- > +-- > data Employee +-- > = MakeEmployee {department :: Department, +-- > name :: Data.Text.Internal.Text} +-- +-- Carefully note that the conversion makes a best-effort attempt to +-- auto-detect when a Dhall type (like @./Employee.dhall@) refers to another +-- Dhall type (like @./Department.dhall@) and replaces that reference with the +-- corresponding Haskell type. +-- -- To add any desired instances (such as `Dhall.FromDhall`/`Dhall.ToDhall`), -- you can use the `StandaloneDeriving` language extension, like this: -- @@ -198,85 +345,20 @@ -- > {-# LANGUAGE StandaloneDeriving #-} -- > {-# LANGUAGE TemplateHaskell #-} -- > --- > Dhall.TH.makeHaskellTypeFromUnion "T" "< A : { x : Bool } | B >" --- > --- > deriving instance Generic T --- > deriving instance FromDhall T -makeHaskellTypeFromUnion - :: Text - -- ^ Name of the generated Haskell type - -> Text - -- ^ Dhall code that evaluates to a union type - -> Q [Dec] -makeHaskellTypeFromUnion typeName text = do +-- > Dhall.TH.makeHaskellTypes +-- > [ MultipleConstructors "Department" "./tests/th/Department.dhall" +-- > , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall" +-- > ] +-- > +-- > deriving instance Generic Department +-- > deriving instance FromDhall Department +-- > +-- > deriving instance Generic Employee +-- > deriving instance FromDhall Employee +makeHaskellTypes :: [HaskellType Text] -> Q [Dec] +makeHaskellTypes haskellTypes = do Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) - expression <- Syntax.runIO (Dhall.inputExpr text) - - case expression of - Union kts -> do - let name = Syntax.mkName (Text.unpack typeName) - - constructors <- traverse toConstructor (Dhall.Map.toList kts ) - - let declaration = DataD [] name [] -#if MIN_VERSION_template_haskell(2,11,0) - Nothing -#else -#endif - constructors [] - - return [ declaration ] - - _ -> do - let document = - mconcat - [ "Dhall.TH.makeHaskellTypeFromUnion: Unsupported Dhall type\n" - , " \n" - , "Explanation: This function only coverts Dhall union types to Haskell datatype \n" - , "declarations. \n" - , " \n" - , "For example, this is a valid Dhall union type that this function would accept: \n" - , " \n" - , " \n" - , " ┌──────────────────────────────────────────────────────────────────┐ \n" - , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : { x : Bool } | B >\" │ \n" - , " └──────────────────────────────────────────────────────────────────┘ \n" - , " \n" - , " \n" - , "... which corresponds to this Haskell type declaration: \n" - , " \n" - , " \n" - , " ┌──────────────────────────────────────┐ \n" - , " │ data T = A {x :: GHC.Types.Bool} | B │ \n" - , " └──────────────────────────────────────┘ \n" - , " \n" - , " \n" - , "... but the following Dhall type is rejected due to being a bare record type: \n" - , " \n" - , " \n" - , " ┌──────────────────────────────────────────────────────┐ \n" - , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"{ x : Bool }\" │ Not valid \n" - , " └──────────────────────────────────────────────────────┘ \n" - , " \n" - , " \n" - , "If you are starting from a file containing only a record type and you want to \n" - , "generate a Haskell type from that, then wrap the record type in a union with one\n" - , "alternative, like this: \n" - , " \n" - , " \n" - , " ┌──────────────────────────────────────────────────────────────────┐ \n" - , " │ Dhall.TH.makeHaskellTypeFromUnion \"T\" \"< A : ./recordType.dhall >\" │ \n" - , " └──────────────────────────────────────────────────────────────────┘ \n" - , " \n" - , " \n" - , "The Haskell datatype generation logic encountered the following Dhall type: \n" - , " \n" - , " " <> Dhall.Util.insert expression <> "\n" - , " \n" - , "... which is not a union type." - ] - - let message = Pretty.renderString (Dhall.Pretty.layout document) + haskellTypes' <- traverse (traverse (Syntax.runIO . Dhall.inputExpr)) haskellTypes - fail message + traverse (toDeclaration haskellTypes') haskellTypes' diff --git a/src/Dhall/Tags.hs b/src/Dhall/Tags.hs --- a/src/Dhall/Tags.hs +++ b/src/Dhall/Tags.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} @@ -37,9 +36,9 @@ -} data LineColumn = LC - { lcLine :: Int + { _lcLine :: Int -- ^ line number, starting from 1, where to find the tag - , lcColumn :: Int + , _lcColumn :: Int -- ^ column of line where tag is } deriving (Eq, Ord, Show) @@ -269,11 +268,4 @@ concat <$> mapM (go . () p) contents else return [p | matchingSuffix || p == path] where matchingSuffix = maybe True (any (`isSuffixOf` p)) suffixes - isSymLink = -#if MIN_VERSION_directory(1,3,0) - SD.pathIsSymbolicLink p -#elif MIN_VERSION_directory(1,2,6) - SD.isSymbolicLink pa -#else - return False -#endif + isSymLink = SD.pathIsSymbolicLink p diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -74,6 +74,9 @@ -- ** Extending the language -- $extending + -- ** Substitutions + -- $substitutions + -- * Prelude -- $prelude @@ -1915,6 +1918,64 @@ -- * Keep built-ins easy to implement across language bindings -- * Prefer general purpose built-ins or built-ins appropriate for the task of program configuration -- * Design built-ins to catch errors as early as possible (i.e. when type-checking the configuration) + +-- $substitutions +-- +-- Substitutions are another way to extend the language. +-- Suppose we have the following Haskell datatype: +-- +-- > data Result = Failure Integer | Success String +-- > deriving (Eq, Generic, Show) +-- > +-- > instance FromDhall Result +-- +-- We can use it in Dhall like that: +-- +-- > -- example.dhall +-- > +-- > let Result = < Failure : Integer | Success Text > +-- > in Result.Failure 1 +-- +-- Right now it is quite easy to keep these two definitions (the one in Haskell source and the one in the Dhall file) synchronized: +-- If we implement a new feature in the Haskell source we update the corresponding type in the Dhall file. +-- But what happens if our application is growing and our Result type contains e.g. 10 unions with possible types embedded in it? +-- Maintaining the code will get tedious. Luckily we can extract the correct Dhall type from the Haskell definition: +-- +-- > resultDecoder :: Dhall.Decoder Result +-- > resultDecoder = Dhall.auto +-- > +-- > resultType :: Expr Src Void +-- > resultType = Dhall.expected resultDecoder +-- > +-- > resultTypeString :: String +-- > resultTypeString = show $ pretty resultType +-- +-- Now we just have to inject that type into the Dhall code and we are done. One common way to do that is to wrap the import of example.dhall in a let expression: +-- +-- > Dhall.input (Dhall.auto :: Dhall.Decoder Result) ("let Result = " ++ Data.Text.pack resultTypeString ++ " in ./example.dhall") +-- +-- Now we can omit the definition of Result in our example.dhall file. While this will work perfectly Dhall provides a cleaner solution for our \"injection problem\": +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > myexample :: IO Result +-- > myexample = let +-- > evaluateSettings = Lens.over Dhall.substitutions (Dhall.Map.insert "Result" resultType) Dhall.defaultEvaluateSettings +-- > in Dhall.inputFileWithSettings evaluateSettings resultDecoder "example.dhall" +-- +-- Substitutions are a simple 'Dhall.Map.Map' mapping variables to expressions. The application of these substitutions reflect the order of the insertions in the substitution map: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > substitute (Dhall.Core.Var "Foo") (Dhall.Map.fromList [("Foo", Dhall.Core.Var "Bar"), ("Bar", Dhall.Core.BoolLit True)]) +-- +-- results in @Dhall.Core.Var \"Baz\"@ since we first substitute \"Foo\" with \"Bar\" and then the resulting \"Bar\" with the final @True@. +-- +-- Notable differences to the other extensions of the builtin language: +-- +-- * This approach works well with the inputFile/inputFileWithSettings functions while the let-wrapping will not. +-- +-- * In contrast to the custom built-ins described above substitutions are made BEFORE the type-checking. -- $prelude -- diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -32,6 +32,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer.Strict (execWriterT, tell) import Data.Monoid (Endo(..), First(..)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Max(..), Semigroup(..)) import Data.Sequence (Seq, ViewL(..)) import Data.Set (Set) @@ -48,6 +49,7 @@ import Lens.Family (over) import qualified Data.Foldable +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map import qualified Data.Sequence import qualified Data.Set @@ -803,7 +805,7 @@ Dhall.Map.unorderedTraverseWithKey_ process (Dhall.Map.delete x₀ xTs) return (VConst c₀) - Combine l r -> do + Combine mk l r -> do _L' <- loop ctx l xLs' <- case _L' of @@ -813,7 +815,9 @@ _ -> do let _L'' = quote names _L' - die (MustCombineARecord '∧' l _L'') + case mk of + Nothing -> die (MustCombineARecord '∧' l _L'') + Just t -> die (InvalidDuplicateField t l _L'') _R' <- loop ctx r @@ -824,14 +828,18 @@ _ -> do let _R'' = quote names _R' - die (MustCombineARecord '∧' r _R'') + case mk of + Nothing -> die (MustCombineARecord '∧' r _R'') + Just t -> die (InvalidDuplicateField t r _R'') - let combineTypes xLs₀' xRs₀' = do - let combine _ (VRecord xLs₁') (VRecord xRs₁') = - combineTypes xLs₁' xRs₁' + let combineTypes xs xLs₀' xRs₀' = do + let combine x (VRecord xLs₁') (VRecord xRs₁') = + combineTypes (x : xs) xLs₁' xRs₁' combine x _ _ = do - die (FieldCollision x) + case mk of + Nothing -> die (FieldCollision (NonEmpty.reverse (x :| xs))) + Just t -> die (DuplicateFieldCannotBeMerged (t :| reverse (x : xs))) let xEs = Dhall.Map.outerJoin Right Right combine xLs₀' xRs₀' @@ -840,7 +848,7 @@ return (VRecord xTs) - combineTypes xLs' xRs' + combineTypes [] xLs' xRs' CombineTypes l r -> do _L' <- loop ctx l @@ -873,19 +881,19 @@ VRecord xRs' -> return xRs' _ -> die (CombineTypesRequiresRecordType r r'') - let combineTypes xLs₀' xRs₀' = do - let combine _ (VRecord xLs₁') (VRecord xRs₁') = - combineTypes xLs₁' xRs₁' + let combineTypes xs xLs₀' xRs₀' = do + let combine x (VRecord xLs₁') (VRecord xRs₁') = + combineTypes (x : xs) xLs₁' xRs₁' combine x _ _ = - die (FieldCollision x) + die (FieldTypeCollision (NonEmpty.reverse (x :| xs))) let mL = Dhall.Map.toMap xLs₀' let mR = Dhall.Map.toMap xRs₀' Data.Foldable.sequence_ (Data.Map.intersectionWithKey combine mL mR) - combineTypes xLs' xRs' + combineTypes [] xLs' xRs' return (VConst c) @@ -1308,11 +1316,14 @@ | AlternativeAnnotationMismatch Text (Expr s a) Const Text (Expr s a) Const | ListAppendMismatch (Expr s a) (Expr s a) | MustCombineARecord Char (Expr s a) (Expr s a) + | InvalidDuplicateField Text (Expr s a) (Expr s a) | InvalidRecordCompletion Text (Expr s a) | CompletionSchemaMustBeARecord (Expr s a) (Expr s a) | CombineTypesRequiresRecordType (Expr s a) (Expr s a) | RecordTypeMismatch Const Const (Expr s a) (Expr s a) - | FieldCollision Text + | DuplicateFieldCannotBeMerged (NonEmpty Text) + | FieldCollision (NonEmpty Text) + | FieldTypeCollision (NonEmpty Text) | MustMergeARecord (Expr s a) (Expr s a) | MustMergeUnionOrOptional (Expr s a) (Expr s a) | MustMapARecord (Expr s a) (Expr s a) @@ -2808,6 +2819,72 @@ txt0 = insert expr0 txt1 = insert expr1 +prettyTypeMessage (InvalidDuplicateField k expr0 expr1) = + ErrorMessages {..} + where + short = "Invalid duplicate field: " <> Dhall.Pretty.Internal.prettyLabel k + + long = + "Explanation: You can specify a field twice if both fields are themselves \n\ + \records, like this: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────────────────────────────┐ \n\ + \ │ { ssh = { enable = True }, ssh = { forwardX11 = True } } │ \n\ + \ └──────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... because the language automatically merges two occurrences of a field using \n\ + \the ❰∧❱ operator, and the above example is equivalent to: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────────────────────────┐ \n\ + \ │ { ssh = { enable = True } ∧ { forwardX11 = True } } │ \n\ + \ └─────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... which is in turn equivalent to: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────┐ \n\ + \ │ { ssh = { enable = True, forwardX11 = True } } │ \n\ + \ └────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \However, this implies that both fields must be records since the ❰∧❱ operator \n\ + \cannot merge non-record values. For example, these expressions are not valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────┐ \n\ + \ │ { x = 0, x = 0 } │ Invalid: Neither field is a record \n\ + \ └──────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ { x = 0, x = { y = 0 } } │ Invalid: The first ❰x❱ field is not a record \n\ + \ └──────────────────────────┘ \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You specified more than one field named: \n\ + \ \n\ + \" <> txt0 <> "\n\ + \ \n\ + \... but one of the fields had this value: \n\ + \ \n\ + \" <> txt1 <> "\n\ + \ \n\ + \... with this type: \n\ + \ \n\ + \" <> txt2 <> "\n\ + \ \n\ + \... which is not a record type \n" + where + txt0 = insert (Dhall.Pretty.Internal.escapeLabel True k) + txt1 = insert expr0 + txt2 = insert expr1 + prettyTypeMessage (CombineTypesRequiresRecordType expr0 expr1) = ErrorMessages {..} where @@ -2898,82 +2975,172 @@ txt2 = insert const0 txt3 = insert const1 -prettyTypeMessage (FieldCollision k) = ErrorMessages {..} +prettyTypeMessage (DuplicateFieldCannotBeMerged ks) = ErrorMessages {..} where - short = "Field collision on: " <> Dhall.Pretty.Internal.prettyLabel k + short = "Duplicate field cannot be merged: " <> pretty (toPath ks) long = - "Explanation: You can combine records or record types if they don't share any \n\ - \fields in common, like this: \n\ + "Explanation: Duplicate fields are only allowed if they are both records and if \n\ + \the two records can be recursively merged without collisions. \n\ \ \n\ + \Specifically, an expression like: \n\ \ \n\ - \ ┌───────────────────────────────────────────┐ \n\ - \ │ { foo = 1, bar = \"ABC\" } ∧ { baz = True } │ \n\ - \ └───────────────────────────────────────────┘ \n\ \ \n\ + \ ┌──────────────────┐ \n\ + \ │ { x = a, x = b } │ \n\ + \ └──────────────────┘ \n\ \ \n\ - \ ┌─────────────────────────────────┐ \n\ - \ │ { foo : Text } ⩓ { bar : Bool } │ \n\ - \ └─────────────────────────────────┘ \n\ \ \n\ + \... is syntactic sugar for: \n\ \ \n\ - \ ┌────────────────────────────────────────┐ \n\ - \ │ λ(r : { baz : Bool}) → { foo = 1 } ∧ r │ \n\ - \ └────────────────────────────────────────┘ \n\ \ \n\ + \ ┌───────────────┐ \n\ + \ │ { x = a ∧ b } │ \n\ + \ └───────────────┘ \n\ \ \n\ - \... but you cannot merge two records that share the same field unless the field \n\ - \is a record on both sides. \n\ \ \n\ - \For example, the following expressions are " <> _NOT <> " valid: \n\ + \... which is rejected if ❰a ∧ b❱ does not type-check. One way this can happen \n\ + \is if ❰a❱ and ❰b❱ share a field in common that is not a record, which is known \n\ + \as a \"collision\". \n\ \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ \ \n\ - \ ┌───────────────────────────────────────────┐ \n\ - \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = True } │ Invalid: Colliding ❰foo❱ \n\ - \ └───────────────────────────────────────────┘ fields \n\ \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ { x = { y = 0 }, x = { y = 1 } } │ Invalid: The two ❰x.y❱ fields \"collide\"\n\ + \ └──────────────────────────────────┘ \n\ \ \n\ - \ ┌─────────────────────────────────┐ \n\ - \ │ { foo : Bool } ∧ { foo : Text } │ Invalid: Colliding ❰foo❱ fields \n\ - \ └─────────────────────────────────┘ \n\ \ \n\ + \... whereas the following expression is valid: \n\ \ \n\ - \... but the following expressions are valid: \n\ \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ { x = { y = 0 }, x = { z = 1 } } │ Valid: the two ❰x❱ fields don't collide\n\ + \ └──────────────────────────────────┘ because they can be recursively merged \n\ \ \n\ - \ ┌──────────────────────────────────────────────────┐ \n\ - \ │ { foo = { bar = True } } ∧ { foo = { baz = 1 } } │ Valid: Both ❰foo❱ \n\ - \ └──────────────────────────────────────────────────┘ fields are records \n\ \ \n\ + \Some common reasons why you might get this error: \n\ \ \n\ - \ ┌─────────────────────────────────────────────────────┐ \n\ - \ │ { foo : { bar : Bool } } ⩓ { foo : { baz : Text } } │ Valid: Both ❰foo❱ \n\ - \ └─────────────────────────────────────────────────────┘ fields are records \n\ + \● You specified the same field twice by mistake \n\ \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ \ \n\ + \You specified the following field twice: \n\ + \ \n\ + \" <> txt0 <> "\n\ + \ \n\ + \... which collided on the following path: \n\ + \ \n\ + \" <> txt1 <> "\n" + where + txt0 = insert (Dhall.Pretty.Internal.escapeLabel True (NonEmpty.head ks)) + + txt1 = insert (toPath ks) + +prettyTypeMessage (FieldCollision ks) = ErrorMessages {..} + where + short = "Field collision on: " <> pretty (toPath ks) + + long = + "Explanation: You can recursively merge records using the ❰∧❱ operator: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ { x = a } ∧ { y = b } │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \... but two records cannot be merged in this way if they share a field that is \n\ + \not a record. \n\ + \ \n\ + \For example, the following expressions are " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────┐ \n\ + \ │ { x = 1 } ∧ { x = True } │ Invalid: The ❰x❱ fields \"collide\" because they\n\ + \ └──────────────────────────┘ are not records that can be merged \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────┐ \n\ + \ │ { x = 1 } ∧ { x = { y = True } } │ Invalid: One of the two ❰x❱ fields is \n\ + \ └──────────────────────────────────┘ still not a record \n\ + \ \n\ + \ \n\ + \... but the following expression is valid: \n\ + \ \n\ + \ \n\ + \ ┌──────────────────────────────────────────┐ Valid: The two ❰x❱ fields \n\ + \ │ { x = { y = True } } ∧ { x = { z = 1 } } │ don't collide because they can\n\ + \ └──────────────────────────────────────────┘ be recursively merged \n\ + \ \n\ + \ \n\ \Some common reasons why you might get this error: \n\ \ \n\ \● You tried to use ❰∧❱ to update a field's value, like this: \n\ \ \n\ \ \n\ \ ┌────────────────────────────────────────┐ \n\ - \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = 2 } │ \n\ + \ │ { foo = 1, bar = \"ABC\" } ∧ { foo = 2 } │ \n\ \ └────────────────────────────────────────┘ \n\ \ ⇧ \n\ \ Invalid attempt to update ❰foo❱'s value to ❰2❱\n\ \ \n\ - \ Field updates are intentionally not allowed as the Dhall language discourages \n\ - \ patch-oriented programming \n\ \ \n\ + \ You probably meant to use ❰⫽❱ / ❰//❱ instead: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────┐ \n\ + \ │ { foo = 1, bar = \"ABC\" } ⫽ { foo = 2 } │ \n\ + \ └────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ \────────────────────────────────────────────────────────────────────────────────\n\ \ \n\ - \You combined two records that share the following field: \n\ + \You tried to merge two records which collided on the following path: \n\ \ \n\ - \" <> txt0 <> "\n\ + \" <> txt0 <> "\n" + where + txt0 = insert (toPath ks) + +prettyTypeMessage (FieldTypeCollision ks) = ErrorMessages {..} + where + short = "Field type collision on: " <> pretty (toPath ks) + + long = + "Explanation: You can recursively merge record types using the ❰⩓❱ operator, like\n\ + \this: \n\ \ \n\ - \... which is not allowed \n" + \ \n\ + \ ┌───────────────────────┐ \n\ + \ │ { x : A } ⩓ { y : B } │ \n\ + \ └───────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot merge record types if two field types collide that are not \n\ + \both record types. \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────┐ \n\ + \ │ { x : Natural } ⩓ { x : Bool } │ Invalid: The ❰x❱ fields \"collide\" \n\ + \ └────────────────────────────────┘ because they cannot be merged \n\ + \ \n\ + \ \n\ + \... but the following expression is valid: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────┐ Valid: The ❰x❱ field \n\ + \ │ { x : { y : Bool } } ⩓ { x : { z : Natural } } │ types don't collide and \n\ + \ └────────────────────────────────────────────────┘ can be merged \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \You tried to merge two record types which collided on the following path: \n\ + \ \n\ + \" <> txt0 <> "\n" where - txt0 = insert k + txt0 = insert (toPath ks) prettyTypeMessage (MustMergeARecord expr0 expr1) = ErrorMessages {..} where @@ -4429,6 +4596,8 @@ AlternativeAnnotationMismatch <$> pure a <*> f b <*> pure c <*> pure d <*> f e <*> pure g ListAppendMismatch a b -> ListAppendMismatch <$> f a <*> f b + InvalidDuplicateField a b c -> + InvalidDuplicateField a <$> f b <*> f c MustCombineARecord a b c -> MustCombineARecord <$> pure a <*> f b <*> f c InvalidRecordCompletion a l -> @@ -4439,8 +4608,12 @@ CombineTypesRequiresRecordType <$> f a <*> f b RecordTypeMismatch a b c d -> RecordTypeMismatch <$> pure a <*> pure b <*> f c <*> f d + DuplicateFieldCannotBeMerged a -> + pure (DuplicateFieldCannotBeMerged a) FieldCollision a -> - FieldCollision <$> pure a + pure (FieldCollision a) + FieldTypeCollision a -> + pure (FieldTypeCollision a) MustMergeARecord a b -> MustMergeARecord <$> f a <*> f b MustMergeUnionOrOptional a b -> @@ -4569,3 +4742,10 @@ let shiftedContext = fmap (Dhall.Core.shift (-1) (V x 0)) context' _ <- typeWith shiftedContext shiftedV return () + +toPath :: (Functor list, Foldable list) => list Text -> Text +toPath ks = + Text.intercalate "." + (Data.Foldable.toList + (fmap (Dhall.Pretty.Internal.escapeLabel True) ks) + ) diff --git a/src/Dhall/Util.hs b/src/Dhall/Util.hs --- a/src/Dhall/Util.hs +++ b/src/Dhall/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Shared utility functions @@ -9,11 +10,13 @@ , _ERROR , Censor(..) , Input(..) + , OutputMode(..) , Output(..) , getExpression , getExpressionAndHeader , getExpressionAndHeaderFromStdinText , Header(..) + , CheckFailed(..) ) where import Control.Exception (Exception(..)) @@ -98,7 +101,11 @@ _ERROR :: IsString string => string _ERROR = "\ESC[1;31mError\ESC[0m" -get :: (String -> Text -> Either ParseError a) -> Censor -> InputOrTextFromStdin -> IO a +get + :: (String -> Text -> Either ParseError a) + -> Censor + -> InputOrTextFromStdin + -> IO a get parser censor input = do inText <- do case input of @@ -140,15 +147,40 @@ -- | Path to output data Output = StandardOutput | OutputFile FilePath +{-| Some command-line subcommands can either `Write` their input or `Check` + that the input has already been modified. This type is shared between them + to record that choice. +-} +data OutputMode = Write | Check + +-- | Exception thrown when the @--check@ flag to a command-line subcommand fails +data CheckFailed = CheckFailed { command :: Text, modified :: Text } + +instance Exception CheckFailed + +instance Show CheckFailed where + show CheckFailed{..} = + _ERROR <> ": ❰dhall " <> command_ <> " --check❱ failed\n\ + \\n\ + \You ran ❰dhall " <> command_ <> " --check❱, but the input appears to have not\n\ + \been " <> modified_ <> " before, or was changed since the last time the input\n\ + \was " <> modified_ <> ".\n" + where + modified_ = Data.Text.unpack modified + + command_ = Data.Text.unpack command + -- | Convenient utility for retrieving an expression getExpression :: Censor -> Input -> IO (Expr Src Import) getExpression censor = get Dhall.Parser.exprFromText censor . Input_ -- | Convenient utility for retrieving an expression along with its header getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import) -getExpressionAndHeader censor = get Dhall.Parser.exprAndHeaderFromText censor . Input_ +getExpressionAndHeader censor = + get Dhall.Parser.exprAndHeaderFromText censor . Input_ -- | Convenient utility for retrieving an expression along with its header from -- | text already read from STDIN (so it's not re-read) getExpressionAndHeaderFromStdinText :: Censor -> Text -> IO (Header, Expr Src Import) -getExpressionAndHeaderFromStdinText censor = get Dhall.Parser.exprAndHeaderFromText censor . StdinText +getExpressionAndHeaderFromStdinText censor = + get Dhall.Parser.exprAndHeaderFromText censor . StdinText 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 @@ -324,6 +324,7 @@ standardizedExpression (ListLit Nothing xs) = not (Data.Sequence.null xs) standardizedExpression (ListLit (Just _ ) xs) = Data.Sequence.null xs standardizedExpression (Note _ _ ) = False +standardizedExpression (Combine (Just _) _ _) = False standardizedExpression _ = True instance Arbitrary File where 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 @@ -43,6 +43,7 @@ , issue1131b , issue1341 , issue1584 + , issue1646 , parsing0 , typeChecking0 , typeChecking1 @@ -186,6 +187,13 @@ -- This test ensures that we can parse variables with keyword prefixes -- (e.g. `ifX`) _ <- Util.code "./tests/regression/issue1584.dhall" + return () ) + +issue1646 :: TestTree +issue1646 = Test.Tasty.HUnit.testCase "Issue #1646" (do + -- This test ensures that the parser doesn't eagerly consume trailing + -- whitespace after a `Double` + _ <- Util.code "./tests/regression/issue1646.dhall" return () ) parsing0 :: TestTree diff --git a/tests/Dhall/Test/Substitution.hs b/tests/Dhall/Test/Substitution.hs new file mode 100644 --- /dev/null +++ b/tests/Dhall/Test/Substitution.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Test.Substitution where + +import Data.Void (Void) +import Dhall.Core (Expr(BoolLit, Var)) +import Dhall.Src (Src) + +import qualified Dhall +import qualified Dhall.Map +import qualified Lens.Family as Lens + +data Result = Failure Integer | Success String + deriving (Eq, Dhall.Generic, Show) + +instance Dhall.FromDhall Result + +substituteResult :: FilePath -> IO Result +substituteResult fp = let + evaluateSettings = Lens.over Dhall.substitutions (Dhall.Map.insert "Result" resultType) Dhall.defaultEvaluateSettings + in Dhall.inputFileWithSettings evaluateSettings resultDecoder fp + +resultDecoder :: Dhall.Decoder Result +resultDecoder = Dhall.auto + +resultType :: Expr Src Void +resultType = Dhall.expected resultDecoder + +substituteFoo :: FilePath -> IO Bool +substituteFoo fp = let + evaluateSettings = Lens.set Dhall.substitutions (Dhall.Map.fromList [("Foo", Var "Bar"), ("Bar", BoolLit True)]) Dhall.defaultEvaluateSettings + in Dhall.inputFileWithSettings evaluateSettings Dhall.auto fp 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,6 +7,7 @@ module Dhall.Test.TH where import Dhall (FromDhall(..)) +import Dhall.TH (HaskellType(..)) import GHC.Generics import Test.Tasty (TestTree) @@ -22,6 +23,21 @@ deriving instance Generic T deriving instance FromDhall T +Dhall.TH.makeHaskellTypes + [ MultipleConstructors "Department" "./tests/th/Department.dhall" + , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall" + ] + +deriving instance Eq Department +deriving instance Show Department +deriving instance Generic Department +deriving instance FromDhall Department + +deriving instance Eq Employee +deriving instance Show Employee +deriving instance Generic Employee +deriving instance FromDhall Employee + tests :: TestTree tests = Tasty.testGroup "Template Haskell" [ makeHaskellTypeFromUnion ] @@ -38,3 +54,7 @@ t2 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.C" Tasty.HUnit.assertEqual "" t2 C + + employee <- Dhall.input Dhall.auto "let Department = ./tests/th/Department.dhall in { name = \"John\", department = Department.Marketing }" + + Tasty.HUnit.assertEqual "" employee MakeEmployee{ name = "John", department = Marketing } diff --git a/tests/Dhall/Test/Tutorial.hs b/tests/Dhall/Test/Tutorial.hs --- a/tests/Dhall/Test/Tutorial.hs +++ b/tests/Dhall/Test/Tutorial.hs @@ -6,7 +6,8 @@ import qualified Data.Vector import qualified Dhall -import qualified Dhall.Test.Util as Util +import qualified Dhall.Test.Substitution as Substitution +import qualified Dhall.Test.Util as Util import qualified Test.Tasty import qualified Test.Tasty.HUnit @@ -35,6 +36,17 @@ , example 1 "./tests/tutorial/unions1A.dhall" "./tests/tutorial/unions1B.dhall" , example 3 "./tests/tutorial/unions3A.dhall" "./tests/tutorial/unions3B.dhall" , example 4 "./tests/tutorial/unions4A.dhall" "./tests/tutorial/unions4B.dhall" + ] + , Test.Tasty.testGroup "Substitutions" + [ Test.Tasty.HUnit.testCase "substitution1.dhall" $ do + res <- Substitution.substituteResult "tests/tutorial/substitution1.dhall" + res @?= Substitution.Failure 1 + , Test.Tasty.HUnit.testCase "substitution2.dhall" $ do + res <- Substitution.substituteResult "tests/tutorial/substitution2.dhall" + res @?= Substitution.Failure 1 + , Test.Tasty.HUnit.testCase "substitution3.dhall" $ do + res <- Substitution.substituteFoo "tests/tutorial/substitution3.dhall" + res @?= True ] ] diff --git a/tests/Dhall/Test/TypeInference.hs b/tests/Dhall/Test/TypeInference.hs --- a/tests/Dhall/Test/TypeInference.hs +++ b/tests/Dhall/Test/TypeInference.hs @@ -80,11 +80,11 @@ failureTest :: Text -> TestTree failureTest prefix = do - let expectedFailures = [ typeInferenceDirectory "failure/unit/MergeEmptyNeedsDirectAnnotation1" + let expectedFailures = + [ typeInferenceDirectory "failure/unit/MergeEmptyNeedsDirectAnnotation1" -- Duplicate fields are incorrectly caught during parsing: -- https://github.com/dhall-lang/dhall-haskell/issues/772 - , typeInferenceDirectory "failure/unit/RecordLitDuplicateFields" , typeInferenceDirectory "failure/unit/RecordProjectionDuplicateFields" , typeInferenceDirectory "failure/unit/RecordTypeDuplicateFields" , typeInferenceDirectory "failure/unit/UnionTypeDuplicateVariants1" diff --git a/tests/format/applicationMultilineA.dhall b/tests/format/applicationMultilineA.dhall --- a/tests/format/applicationMultilineA.dhall +++ b/tests/format/applicationMultilineA.dhall @@ -15,6 +15,9 @@ , some = Some aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, someList = + Some + [ aaaaaaaaaaaaaaaaaaaaaaaaaa, bbbbbbbbbbbbbbbbbbbb, cccccccccccccccccccccccc, dddddddddddddd ] , merge = merge aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/tests/format/applicationMultilineB.dhall b/tests/format/applicationMultilineB.dhall --- a/tests/format/applicationMultilineB.dhall +++ b/tests/format/applicationMultilineB.dhall @@ -14,6 +14,12 @@ dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd , some = Some aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, someList = Some + [ aaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbb + , cccccccccccccccccccccccc + , dddddddddddddd + ] , merge = merge aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa @@ -23,7 +29,6 @@ a b ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -, toMap = - toMap - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +, toMap = toMap + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa } diff --git a/tests/format/dottedFieldsA.dhall b/tests/format/dottedFieldsA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/dottedFieldsA.dhall @@ -0,0 +1,1 @@ +{ x = { y = { a = { b = 1 }, c = { d = 2 } } } } diff --git a/tests/format/dottedFieldsB.dhall b/tests/format/dottedFieldsB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/dottedFieldsB.dhall @@ -0,0 +1,1 @@ +{ x.y = { a.b = 1, c.d = 2 } } diff --git a/tests/lint/success/optionalFoldBuildA.dhall b/tests/lint/success/optionalFoldBuildA.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/optionalFoldBuildA.dhall @@ -0,0 +1,4 @@ +{ example0 = Optional/fold +, example1 = Optional/build +, example2 = Optional/fold Natural (Some 1) Bool Natural/even False +} diff --git a/tests/lint/success/optionalFoldBuildB.dhall b/tests/lint/success/optionalFoldBuildB.dhall new file mode 100644 --- /dev/null +++ b/tests/lint/success/optionalFoldBuildB.dhall @@ -0,0 +1,18 @@ +{ example0 = + λ(a : Type) + → λ(o : Optional a) + → λ(optional : Type) + → λ(some : a → optional) + → λ(none : optional) + → merge { Some = some, None = none } o +, example1 = + λ(a : Type) + → λ ( build + : ∀(optional : Type) + → ∀(some : a → optional) + → ∀(none : optional) + → optional + ) + → build (Optional a) (λ(x : a) → Some x) (None a) +, example2 = merge { Some = Natural/even, None = False } (Some 1) +} diff --git a/tests/regression/issue1646.dhall b/tests/regression/issue1646.dhall new file mode 100644 --- /dev/null +++ b/tests/regression/issue1646.dhall @@ -0,0 +1,1 @@ +let f = \(d : Double) -> \(i : Integer) -> {=} in f 3.1 -1 diff --git a/tests/th/Department.dhall b/tests/th/Department.dhall new file mode 100644 --- /dev/null +++ b/tests/th/Department.dhall @@ -0,0 +1,1 @@ +< Sales | Engineering | Marketing > diff --git a/tests/th/Employee.dhall b/tests/th/Employee.dhall new file mode 100644 --- /dev/null +++ b/tests/th/Employee.dhall @@ -0,0 +1,1 @@ +{ name : Text, department : ./Department.dhall } diff --git a/tests/tutorial/substitution1.dhall b/tests/tutorial/substitution1.dhall new file mode 100644 --- /dev/null +++ b/tests/tutorial/substitution1.dhall @@ -0,0 +1,1 @@ +Result.Failure +1 diff --git a/tests/tutorial/substitution2.dhall b/tests/tutorial/substitution2.dhall new file mode 100644 --- /dev/null +++ b/tests/tutorial/substitution2.dhall @@ -0,0 +1,1 @@ +./substitution1.dhall diff --git a/tests/tutorial/substitution3.dhall b/tests/tutorial/substitution3.dhall new file mode 100644 --- /dev/null +++ b/tests/tutorial/substitution3.dhall @@ -0,0 +1,1 @@ +Foo