diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,65 @@ +1.31.0 + +* [Supports version 15.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v15.0.0) + * [Implement `with` keyword](https://github.com/dhall-lang/dhall-haskell/pull/1685) + * You can now write `someRecord with a.b.c = x` to update a nested + fields + * [Add support for record puns](https://github.com/dhall-lang/dhall-haskell/pull/1710) + * You can now write `{ x, y }` as a shorthand for `{ x = x, y = y }` +* BREAKING CHANGE TO THE API: [Auto-derive `Generic`/`FromDhall`/`ToDhall` with Template Haskell](https://github.com/dhall-lang/dhall-haskell/pull/1682) + * Now the `Dhall.TH.makeHaskell*` utilities will include these derived + instances in the generated declarations + * This is a breaking change since users were likely already generating these + instances separately, which will now conflict with the included instances +* BREAKING CHANGE TO THE API: [`From/ToDhall` no longer takes `InterpretOptions` argument](https://github.com/dhall-lang/dhall-haskell/pull/1696) + * The types of the `autoWith` and `injectWith` methods have changed to + take an `InputNormalizer` instead of an `InterpretOptions` + * Note that `InputNormalizer` is a subset of `InterpretOptions` + * This is a breaking change to how derived `FromDhall` / `ToDhall` instances + are customized to more closely match how other Haskell packages customize + derived instances (e.g. `aeson` with `FromJSON` / `ToJSON`) + * Previously you would customize the behavior globally by passing in + a top-level `InterpretOptions` record to `autoWith` + * Now you can customize the behavior locally on a per-instance basis + * This change enables the following change ... +* [Add `Dhall.Deriving` module for `deriving-via` helpers](https://github.com/dhall-lang/dhall-haskell/pull/1700) + * Now you can take advantage of the `-XDerivingVia` language extension to + customize derived `FromDhall`/`ToDhall` instances, like this: + * `deriving (FromDhall, ToDhall) via Codec (SetSingletonConstructors Bare) Name` +* BREAKING CHANGE TO THE LANGUAGE: [Match standard with respect to `using toMap`](https://github.com/dhall-lang/dhall-haskell/pull/1673) + * `https://example.com using toMap customHeaders` is now a parse error + and needs to be explicitly parenthesized as + `https://example.com using (toMap customHeaders)` + * The language standard had always required the parentheses, but the Haskell + implementation was not correctly matching the standard +* [Fix formatting of indented comments containing empty lines](https://github.com/dhall-lang/dhall-haskell/pull/1688) + * `dhall format` was previously not idempotent when formatting indented + comments with empty lines + * Specifically, the formatter kept indenting things further with each + format, which this change fixes +* [Fix pretty-printer to preserve original numeric literals](https://github.com/dhall-lang/dhall-haskell/pull/1674) + * Now `dhall format` will preserve numeric literals exactly how you wrote + them + * For example, `0xFF` will no longer be reformatted as `255` +* [Add `dhall to-directory-tree` support for `Map`s](https://github.com/dhall-lang/dhall-haskell/pull/1705) + * `Map`s are now converted to directories (just like records) +* [Add manpage](https://github.com/dhall-lang/dhall-haskell/pull/1677) + * ... mainly for the benefit of people packaging Dhall for various + distributions +* [Group commands in CLI](https://github.com/dhall-lang/dhall-haskell/pull/1692) + * The command-line `--help` output now groups commands into useful + sections +* [Fix numeric parsing for GHCJS](https://github.com/dhall-lang/dhall-haskell/pull/1681) + * The GHCJS backend for Dhall was failing to parse numbers, which this + change fixes +* Fixes and improvements to error messages: + * [#1656](https://github.com/dhall-lang/dhall-haskell/pull/1656) + * [#1698](https://github.com/dhall-lang/dhall-haskell/pull/1698) + * [#1702](https://github.com/dhall-lang/dhall-haskell/pull/1702) +* Fixes and improvements to the haddocks: + * [#1708](https://github.com/dhall-lang/dhall-haskell/pull/1708) + * [#1712](https://github.com/dhall-lang/dhall-haskell/pull/1712) + 1.30.0 * [Supports version 14.0.0 of the standard](https://github.com/dhall-lang/dhall-lang/releases/tag/v14.0.0) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2018 Gabriel Gonzalez +Copyright (c) 2020 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/benchmark/deep-nested-large-record/Main.hs b/benchmark/deep-nested-large-record/Main.hs --- a/benchmark/deep-nested-large-record/Main.hs +++ b/benchmark/deep-nested-large-record/Main.hs @@ -50,7 +50,7 @@ Nothing (prelude `Core.Field` "types" `Core.Field` "Big") ) - (Core.Prefer "big" "big") + (Core.Prefer Core.PreferFromSource "big" "big") ) ) "x" diff --git a/dhall-lang/Prelude/JSON/Format b/dhall-lang/Prelude/JSON/Format new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/Format @@ -0,0 +1,7 @@ +{- An internal type used by `./renderAs` to select the output format. + + You should not need to use this type directly, simply use `./render` + or `./renderYAML` as appropriate. +-} + +< YAML | JSON > diff --git a/dhall-lang/Prelude/JSON/package.dhall b/dhall-lang/Prelude/JSON/package.dhall --- a/dhall-lang/Prelude/JSON/package.dhall +++ b/dhall-lang/Prelude/JSON/package.dhall @@ -1,8 +1,8 @@ { render = - ./render sha256:f7c372fcc954bfbbc7f83deec2006608a48efa2b08e8753bfdf73dc0aa7b4faf + ./render sha256:eb26e0a4eee530dcda9d73974e9e9256fbad264916101866406a1647e28e280d ? ./render , renderYAML = - ./renderYAML sha256:b3a9d9b0349c90af9a4985c615c60ac4a85031a7bf9de78f2883126481d35aa0 + ./renderYAML sha256:d406a8744b81ced6a485da3cdb40a357fdd37338f4f134b00e7da3684054ebd3 ? ./renderYAML , omitNullFields = ./omitNullFields sha256:e6850e70094540b75edeb46f4d6038324a62def8d63544a1e9541f79739db6f0 diff --git a/dhall-lang/Prelude/JSON/render b/dhall-lang/Prelude/JSON/render --- a/dhall-lang/Prelude/JSON/render +++ b/dhall-lang/Prelude/JSON/render @@ -2,56 +2,48 @@ This is useful for debugging `JSON` values or for tests. For anything more sophisticated you should use `dhall-to-json` or `dhall-to-yaml` + -} let JSON = ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall -let Text/concatMapSep = - ../Text/concatMapSep sha256:c272aca80a607bc5963d1fcb38819e7e0d3e72ac4d02b1183b1afb6a91340840 - ? ../Text/concatMapSep +let renderAs = + ./renderAs sha256:f16238edec4c6dd846f19677c6675b27c579999dcff91db6193c10ade1d83174 + ? ./renderAs +let Format = + ./Format sha256:d7936b510cfc091faa994652af0eb5feb889cd44bc989edbe4f1eb8c5623caac + ? ./Format + let render : JSON.Type → Text - = λ(j : JSON.Type) - → j - Text - { string = λ(x : Text) → Text/show x - , double = λ(x : Double) → Double/show x - , integer = λ(x : Integer) → JSON.renderInteger x - , object = - λ(x : List { mapKey : Text, mapValue : Text }) - → let body = - Text/concatMapSep - "," - { mapKey : Text, mapValue : Text } - ( λ(e : { mapKey : Text, mapValue : Text }) - → " ${Text/show e.mapKey}: ${e.mapValue}" - ) - x - - in "{${body} }" - , array = - λ(x : List Text) - → let body = Text/concatMapSep "," Text (λ(y : Text) → " ${y}") x - - in "[${body} ]" - , bool = λ(x : Bool) → if x then "true" else "false" - , null = "null" - } + = renderAs Format.JSON let example0 = - assert - : render - ( JSON.array - [ JSON.bool True - , JSON.string "Hello" - , JSON.object - [ { mapKey = "foo", mapValue = JSON.null } - , { mapKey = "bar", mapValue = JSON.double 1.0 } - ] + let data = + assert + : render + ( JSON.array + [ JSON.bool True + , JSON.string "Hello" + , JSON.object + [ { mapKey = "foo", mapValue = JSON.null } + , { mapKey = "bar", mapValue = JSON.double 1.0 } + ] + ] + ) + ≡ '' + [ + true, + "Hello", + { + "foo": null, + "bar": 1.0 + } ] - ) - ≡ "[ true, \"Hello\", { \"foo\": null, \"bar\": 1.0 } ]" + '' + + in True in render diff --git a/dhall-lang/Prelude/JSON/renderAs b/dhall-lang/Prelude/JSON/renderAs new file mode 100644 --- /dev/null +++ b/dhall-lang/Prelude/JSON/renderAs @@ -0,0 +1,443 @@ +{- Render a `JSON` value as `Text` in either JSON or YAML format. -} + +let JSON = + ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 + ? ./core.dhall + +let Function/identity = + ../Function/identity sha256:f78b96792b459cb664f41c6119bd8897dd04353a3343521d436cd82ad71cb4d4 + ? ../Function/identity + +let Text/concatMap = + ../Text/concatMap sha256:7a0b0b99643de69d6f94ba49441cd0fa0507cbdfa8ace0295f16097af37e226f + ? ../Text/concatMap + +let List/take = + ../List/take sha256:b3e08ee8c3a5bf3d8ccee6b2b2008fbb8e51e7373aef6f1af67ad10078c9fbfa + ? ../List/take + +let List/drop = + ../List/drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf + ? ../List/drop + +let List/null = + ../List/null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80 + ? ../List/null + +let List/map = + ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + ? ../List/map + +let List/concatMap = + ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 + ? ../List/concatMap + +let Optional/map = + ../Optional/map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa + ? ../Optional/map + +let NonEmpty + : Type → Type + = λ(a : Type) → { head : a, tail : List a } + +let List/uncons + : ∀(a : Type) → List a → Optional (NonEmpty a) + = λ(a : Type) + → λ(ls : List a) + → Optional/map + a + (NonEmpty a) + (λ(head : a) → { head = head, tail = List/drop 1 a ls }) + (List/head a ls) + +let NonEmpty/singleton + : ∀(a : Type) → a → NonEmpty a + = λ(a : Type) → λ(x : a) → { head = x, tail = [] : List a } + +let NonEmpty/toList + : ∀(a : Type) → NonEmpty a → List a + = λ(a : Type) → λ(nonEmpty : NonEmpty a) → [ nonEmpty.head ] # nonEmpty.tail + +let NonEmpty/concat + : ∀(a : Type) → NonEmpty (NonEmpty a) → NonEmpty a + = λ(a : Type) + → λ(lss : NonEmpty (NonEmpty a)) + → { head = lss.head.head + , tail = + lss.head.tail + # List/concatMap (NonEmpty a) a (NonEmpty/toList a) lss.tail + } + +let NonEmpty/map + : ∀(a : Type) → ∀(b : Type) → (a → b) → NonEmpty a → NonEmpty b + = λ(a : Type) + → λ(b : Type) + → λ(fn : a → b) + → λ(ls : NonEmpty a) + → { head = fn ls.head, tail = List/map a b fn ls.tail } + +let NonEmpty/mapHead + : ∀(a : Type) → (a → a) → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(fn : a → a) + → λ(ls : NonEmpty a) + → ls ⫽ { head = fn ls.head } + +let NonEmpty/mapTail + : ∀(a : Type) → (a → a) → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(fn : a → a) + → λ(ls : NonEmpty a) + → ls ⫽ { tail = List/map a a fn ls.tail } + +let List/splitAt + : Natural → ∀(a : Type) → List a → { head : List a, tail : List a } + = λ(index : Natural) + → λ(a : Type) + → λ(ls : List a) + → { head = List/take index a ls, tail = List/drop index a ls } + +let _testSplitAt0 = + assert + : List/splitAt 0 Natural [ 1, 2, 3 ] + ≡ { head = [] : List Natural, tail = [ 1, 2, 3 ] } + +let _testSplitAt1 = + assert + : List/splitAt 1 Natural [ 1, 2, 3 ] ≡ { head = [ 1 ], tail = [ 2, 3 ] } + +let _testSplitAt3 = + assert + : List/splitAt 3 Natural [ 1, 2, 3 ] + ≡ { head = [ 1, 2, 3 ], tail = [] : List Natural } + +let _testSplitAt = + assert + : List/splitAt 1 Natural ([] : List Natural) + ≡ { head = [] : List Natural, tail = [] : List Natural } + +let List/splitLast = + λ(a : Type) + → λ(ls : List a) + → List/splitAt (Natural/subtract 1 (List/length a ls)) a ls + +let NonEmpty/prepend + : ∀(a : Type) → a → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(prefix : a) + → λ(ls : NonEmpty a) + → { head = prefix, tail = NonEmpty/toList a ls } + +let NonEmpty/append + : ∀(a : Type) → a → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(suffix : a) + → λ(ls : NonEmpty a) + → { head = ls.head, tail = ls.tail # [ suffix ] } + +let NonEmpty/mapLast + : ∀(a : Type) → (a → a) → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(fn : a → a) + → λ(ls : NonEmpty a) + → if List/null a ls.tail + + then { head = fn ls.head, tail = [] : List a } + + else let split = List/splitLast a ls.tail + + in { head = ls.head + , tail = split.head # List/map a a fn split.tail + } + +let NonEmpty/mapLeading + : ∀(a : Type) → (a → a) → NonEmpty a → NonEmpty a + = λ(a : Type) + → λ(fn : a → a) + → λ(ls : NonEmpty a) + → if List/null a ls.tail + + then ls + + else let split = List/splitLast a ls.tail + + in { head = fn ls.head + , tail = List/map a a fn split.head # split.tail + } + +let Lines + : Type + = NonEmpty Text + +let Block + : Type + = < Simple : Text | Complex : Lines > + +let Block/toLines + : Block → Lines + = λ(block : Block) + → merge + { Simple = NonEmpty/singleton Text + , Complex = Function/identity Lines + } + block + +let manyBlocks + : ∀(a : Type) → Text → (NonEmpty a → Lines) → List a → Block + = λ(a : Type) + → λ(ifEmpty : Text) + → λ(render : NonEmpty a → Lines) + → λ(inputs : List a) + → merge + { Some = λ(inputs : NonEmpty a) → Block.Complex (render inputs) + , None = Block.Simple ifEmpty + } + (List/uncons a inputs) + +let blockToText + : Block → Text + = λ(block : Block) + → Text/concatMap + Text + (λ(line : Text) → line ++ "\n") + (NonEmpty/toList Text (Block/toLines block)) + +let addPrefix = λ(prefix : Text) → λ(line : Text) → prefix ++ line + +let addIndent = addPrefix " " + +let indentTail = NonEmpty/mapTail Text addIndent + +let Format = + ./Format sha256:d7936b510cfc091faa994652af0eb5feb889cd44bc989edbe4f1eb8c5623caac + ? ./Format + +let ObjectField = { mapKey : Text, mapValue : Block } + +let renderJSONStruct = + λ(prefix : Text) + → λ(suffix : Text) + → λ(blocks : NonEmpty Lines) + → let indent = NonEmpty/map Text Text addIndent + + let appendComma + : Lines → Lines + = NonEmpty/mapLast Text (λ(line : Text) → line ++ ",") + + let blocks = NonEmpty/mapLeading Lines appendComma blocks + + let block = NonEmpty/concat Text blocks + + in if List/null Text block.tail + + then NonEmpty/singleton Text "${prefix} ${block.head} ${suffix}" + + else NonEmpty/prepend + Text + prefix + (NonEmpty/append Text suffix (indent block)) + +let renderObject = + λ(format : Format) + → λ(fields : NonEmpty ObjectField) + → let keystr = λ(field : ObjectField) → "${Text/show field.mapKey}:" + + let prefixKeyOnFirst = + λ(field : ObjectField) + → NonEmpty/mapHead + Text + (addPrefix "${keystr field} ") + (Block/toLines field.mapValue) + + let prependKeyLine = + λ(field : ObjectField) + → NonEmpty/prepend + Text + (keystr field) + (Block/toLines field.mapValue) + + let renderYAMLField = + λ(field : ObjectField) + → merge + { Simple = + λ(line : Text) + → NonEmpty/singleton Text "${keystr field} ${line}" + , Complex = λ(_ : Lines) → indentTail (prependKeyLine field) + } + field.mapValue + + in merge + { JSON = + renderJSONStruct + "{" + "}" + (NonEmpty/map ObjectField Lines prefixKeyOnFirst fields) + , YAML = + NonEmpty/concat + Text + (NonEmpty/map ObjectField Lines renderYAMLField fields) + } + format + +let renderYAMLArrayField = + λ(block : Block) + → NonEmpty/mapHead + Text + (addPrefix "- ") + (indentTail (Block/toLines block)) + +let renderArray = + λ(format : Format) + → λ(fields : NonEmpty Block) + → merge + { JSON = + renderJSONStruct + "[" + "]" + (NonEmpty/map Block Lines Block/toLines fields) + , YAML = + NonEmpty/concat + Text + (NonEmpty/map Block Lines renderYAMLArrayField fields) + } + format + +let renderAs + : Format → JSON.Type → Text + = λ(format : Format) + → λ(json : JSON.Type) + → blockToText + ( json + Block + { string = λ(x : Text) → Block.Simple (Text/show x) + , double = λ(x : Double) → Block.Simple (Double/show x) + , integer = λ(x : Integer) → Block.Simple (JSON.renderInteger x) + , object = manyBlocks ObjectField "{}" (renderObject format) + , array = manyBlocks Block "[]" (renderArray format) + , bool = + λ(x : Bool) → Block.Simple (if x then "true" else "false") + , null = Block.Simple "null" + } + ) + +let example0 = + let data = + JSON.array + [ JSON.bool True + , JSON.string "Hello" + , JSON.object + [ { mapKey = "foo", mapValue = JSON.null } + , { mapKey = "bar", mapValue = JSON.double 1.0 } + ] + ] + + let yaml = + assert + : renderAs Format.YAML data + ≡ '' + - true + - "Hello" + - "foo": null + "bar": 1.0 + '' + + let json = + assert + : renderAs Format.JSON data + ≡ '' + [ + true, + "Hello", + { + "foo": null, + "bar": 1.0 + } + ] + '' + + in True + +let example1 = + let data = + JSON.object + [ { mapKey = "zero", mapValue = JSON.array ([] : List JSON.Type) } + , { mapKey = "one", mapValue = JSON.array [ JSON.string "a" ] } + , { mapKey = "two" + , mapValue = JSON.array [ JSON.string "a", JSON.string "b" ] + } + ] + + let yaml = + assert + : renderAs Format.YAML data + ≡ '' + "zero": [] + "one": + - "a" + "two": + - "a" + - "b" + '' + + let json = + assert + : renderAs Format.JSON data + ≡ '' + { + "zero": [], + "one": [ "a" ], + "two": [ + "a", + "b" + ] + } + '' + + in True + +let example2 = + let data = + JSON.object + [ { mapKey = "zero" + , mapValue = + JSON.object + (toMap {=} : List { mapKey : Text, mapValue : JSON.Type }) + } + , { mapKey = "one" + , mapValue = JSON.object (toMap { a = JSON.null }) + } + , { mapKey = "two" + , mapValue = + JSON.object (toMap { a = JSON.null, b = JSON.null }) + } + ] + + let yaml = + assert + : renderAs Format.YAML data + ≡ '' + "zero": {} + "one": + "a": null + "two": + "a": null + "b": null + '' + + let json = + assert + : renderAs Format.JSON data + ≡ '' + { + "zero": {}, + "one": { "a": null }, + "two": { + "a": null, + "b": null + } + } + '' + + in True + +in renderAs 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 @@ -6,150 +6,24 @@ However, it is useful for debugging `JSON` values or for tests. For anything more sophisticated you should use `dhall-to-json` or `dhall-to-yaml`. + -} let JSON = ./core.dhall sha256:5dc1135d5481cfd6fde625aaed9fcbdb7aa7c14f2e76726aa5fdef028a5c10f5 ? ./core.dhall -let Text/concatSep = - ../Text/concatSep sha256:e4401d69918c61b92a4c0288f7d60a6560ca99726138ed8ebc58dca2cd205e58 - ? ../Text/concatSep - -let List/drop = - ../List/drop sha256:af983ba3ead494dd72beed05c0f3a17c36a4244adedf7ced502c6512196ed0cf - ? ../List/drop - -let List/null = - ../List/null sha256:2338e39637e9a50d66ae1482c0ed559bbcc11e9442bfca8f8c176bbcd9c4fc80 - ? ../List/null - -let List/map = - ../List/map sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 - ? ../List/map - -let List/concatMap = - ../List/concatMap sha256:3b2167061d11fda1e4f6de0522cbe83e0d5ac4ef5ddf6bb0b2064470c5d3fb64 - ? ../List/concatMap - -let Optional/map = - ../Optional/map sha256:501534192d988218d43261c299cc1d1e0b13d25df388937add784778ab0054fa - ? ../Optional/map - -let NonEmpty - : Type → Type - = λ(a : Type) → { head : a, tail : List a } - -let uncons - : ∀(a : Type) → List a → Optional (NonEmpty a) - = λ(a : Type) - → λ(ls : List a) - → Optional/map - a - (NonEmpty a) - (λ(head : a) → { head = head, tail = List/drop 1 a ls }) - (List/head a ls) - -let nonEmptyToList - : ∀(a : Type) → NonEmpty a → List a - = λ(a : Type) → λ(nonEmpty : NonEmpty a) → [ nonEmpty.head ] # nonEmpty.tail - -let concatNonEmpty - : ∀(a : Type) → NonEmpty (NonEmpty a) → NonEmpty a - = λ(a : Type) - → λ(lss : NonEmpty (NonEmpty a)) - → { head = lss.head.head - , tail = - lss.head.tail - # List/concatMap (NonEmpty a) a (nonEmptyToList a) lss.tail - } - -let Block - : Type - = NonEmpty Text - -let indentBlockWith - : Text → Text → Block → Block - = λ(headIndent : Text) - → λ(tailIndent : Text) - → λ(block : Block) - → { head = headIndent ++ block.head - , tail = List/map Text Text (λ(t : Text) → tailIndent ++ t) block.tail - } - -let manyBlocks - : Block → List Block → Block - = λ(ifEmpty : Block) - → λ(blocks : List Block) - → merge - { Some = concatNonEmpty Text, None = ifEmpty } - (uncons Block blocks) - -let singleLine - : Text → Block - = λ(text : Text) → { head = text, tail = [] : List Text } - -let indentKeyedBlock - : Text → Text → Text → Block → Block - = λ(key : Text) - → λ(spacer : Text) - → λ(indentation : Text) - → λ(block : Block) - → if List/null Text block.tail - - then singleLine (key ++ spacer ++ block.head) - - else indentBlockWith - key - indentation - { head = "", tail = nonEmptyToList Text block } +let renderAs = + ./renderAs sha256:f16238edec4c6dd846f19677c6675b27c579999dcff91db6193c10ade1d83174 + ? ./renderAs -let blockToText - : Block → Text - = λ(block : Block) → Text/concatSep "\n" (nonEmptyToList Text block) ++ "\n" +let Format = + ./Format sha256:d7936b510cfc091faa994652af0eb5feb889cd44bc989edbe4f1eb8c5623caac + ? ./Format let renderYAML : JSON.Type → Text - = λ(json : JSON.Type) - → let ObjectField = { mapKey : Text, mapValue : Block } - - in blockToText - ( json - Block - { string = λ(x : Text) → singleLine (Text/show x) - , double = λ(x : Double) → singleLine (Double/show x) - , integer = λ(x : Integer) → singleLine (JSON.renderInteger x) - , object = - λ(fields : List ObjectField) - → manyBlocks - (singleLine "{}") - ( List/map - ObjectField - Block - ( λ(e : ObjectField) - → indentKeyedBlock - "! ${Text/show e.mapKey}:" - " " - " " - e.mapValue - ) - fields - ) - , array = - λ(elements : List Block) - → manyBlocks - (singleLine "[]") - ( List/map - Block - Block - (indentBlockWith "- " " ") - elements - ) - , bool = - λ(x : Bool) → singleLine (if x then "true" else "false") - , null = singleLine "null" - } - ) + = renderAs Format.YAML let example0 = assert @@ -166,8 +40,8 @@ ≡ '' - true - "Hello" - - ! "foo": null - ! "bar": 1.0 + - "foo": null + "bar": 1.0 '' in renderYAML 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 @@ -29,7 +29,7 @@ ./Optional/package.dhall sha256:4324b2bf84ded40f67485f14355e4cb7b237a8f173e713c791ec44cebebc552c ? ./Optional/package.dhall , JSON = - ./JSON/package.dhall sha256:88c358783defee9bbd65aea224cdac56c7666ba367b0dd5f7f6d56de73911292 + ./JSON/package.dhall sha256:1b02c5ff4710f90ee3f8dc1a2565f1b52b45e5317e2df4775307e2ba0cadcf21 ? ./JSON/package.dhall , Text = ./Text/package.dhall sha256:3a5e3acde76fe5f90bd296e6c9d2e43e6ae81c56f804029b39352d2f1664b769 diff --git a/dhall-lang/tests/import/data/fieldOrder/1.dhall b/dhall-lang/tests/import/data/fieldOrder/1.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/data/fieldOrder/1.dhall +++ /dev/null @@ -1,1 +0,0 @@ -{ foo = 1, bar = True } diff --git a/dhall-lang/tests/import/data/fieldOrder/2.dhall b/dhall-lang/tests/import/data/fieldOrder/2.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/data/fieldOrder/2.dhall +++ /dev/null @@ -1,1 +0,0 @@ -{ bar = True, foo = 1 } diff --git a/dhall-lang/tests/import/data/referentiallyOpaque.dhall b/dhall-lang/tests/import/data/referentiallyOpaque.dhall --- a/dhall-lang/tests/import/data/referentiallyOpaque.dhall +++ b/dhall-lang/tests/import/data/referentiallyOpaque.dhall @@ -9,12 +9,10 @@ this file attempts to import a referentially opaque import (an environment variable in this case) to verify that the import fails. - For this test file we need to select a referentially opaque import that would - likely succeed if imported on its own, so that a non-compliant implementation - doesn't fail this test for the wrong reason (i.e. due to the referentially - opaque not being present). In general, we can't guarantee that referentially - opaque imports exist (because they are referentially opaque!), but the - `HOME` environment variable has a high likelihood of bring present on a POSIX - system. + For this test file we need to select a referentially opaque import that + would succeed if imported on its own, so that a non-compliant implementation + doesn't fail this test for the wrong reason (i.e. due to the import not + being present). We thus use the `DHALL_TEST_VAR` environment variable, that + is expected to be set when running import tests. -} -env:HOME as Text +env:DHALL_TEST_VAR as Text diff --git a/dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall b/dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -env:UNSET1 as Text ? env:UNSET2 ? missing ? env:UNSET3 ? 2 diff --git a/dhall-lang/tests/import/success/alternativeEnvNaturalB.dhall b/dhall-lang/tests/import/success/alternativeEnvNaturalB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeEnvNaturalB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -2 diff --git a/dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall b/dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -env:UNSET ? 3 diff --git a/dhall-lang/tests/import/success/alternativeEnvSimpleB.dhall b/dhall-lang/tests/import/success/alternativeEnvSimpleB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeEnvSimpleB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -3 diff --git a/dhall-lang/tests/import/success/alternativeHashMismatchA.dhall b/dhall-lang/tests/import/success/alternativeHashMismatchA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeHashMismatchA.dhall +++ /dev/null @@ -1,2 +0,0 @@ - ../data/simple.dhall sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -? 42 diff --git a/dhall-lang/tests/import/success/alternativeHashMismatchB.dhall b/dhall-lang/tests/import/success/alternativeHashMismatchB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeHashMismatchB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -42 diff --git a/dhall-lang/tests/import/success/alternativeNaturalA.dhall b/dhall-lang/tests/import/success/alternativeNaturalA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeNaturalA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -4 ? missing diff --git a/dhall-lang/tests/import/success/alternativeNaturalB.dhall b/dhall-lang/tests/import/success/alternativeNaturalB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeNaturalB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -4 diff --git a/dhall-lang/tests/import/success/alternativeParseErrorA.dhall b/dhall-lang/tests/import/success/alternativeParseErrorA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeParseErrorA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -(../data/example.txt) ? 42 diff --git a/dhall-lang/tests/import/success/alternativeParseErrorB.dhall b/dhall-lang/tests/import/success/alternativeParseErrorB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeParseErrorB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -42 diff --git a/dhall-lang/tests/import/success/alternativeTypeErrorA.dhall b/dhall-lang/tests/import/success/alternativeTypeErrorA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeTypeErrorA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -../data/doesNotTypecheck.dhall ? 42 diff --git a/dhall-lang/tests/import/success/alternativeTypeErrorB.dhall b/dhall-lang/tests/import/success/alternativeTypeErrorB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/alternativeTypeErrorB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -42 diff --git a/dhall-lang/tests/import/success/asLocationA.dhall b/dhall-lang/tests/import/success/asLocationA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/asLocationA.dhall +++ /dev/null @@ -1,8 +0,0 @@ -{ _1 = ./some/import.dhall as Location -, _2 = ../data/simpleLocation.dhall -, _3 = /absolute/import sha256:f9340badf94a684e652e0a384f64363293d8b632d971f3453f7ee22f10ab6e75 as Location -, _4 = https://prelude.dhall-lang.org/package.dhall as Location -, _5 = env:HOME as Location -, _6 = missing as Location -, _7 = (missing as Location) ? 42 -- `missing` fails as an import, but definitely resolves as Location -} diff --git a/dhall-lang/tests/import/success/asLocationB.dhall b/dhall-lang/tests/import/success/asLocationB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/asLocationB.dhall +++ /dev/null @@ -1,20 +0,0 @@ -{ _1 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Local - "./dhall-lang/tests/import/success/some/import.dhall" -, _2 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Local - "./dhall-lang/tests/import/data/simple.dhall" -, _3 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Local - "/absolute/import" -, _4 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Remote - "https://prelude.dhall-lang.org/package.dhall" -, _5 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Environment - "env:HOME" -, _6 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Missing -, _7 = - < Local : Text | Remote : Text | Environment : Text | Missing >.Missing -} diff --git a/dhall-lang/tests/import/success/asTextA.dhall b/dhall-lang/tests/import/success/asTextA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/asTextA.dhall +++ /dev/null @@ -1,1 +0,0 @@ -../data/example.txt as Text diff --git a/dhall-lang/tests/import/success/asTextB.dhall b/dhall-lang/tests/import/success/asTextB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/asTextB.dhall +++ /dev/null @@ -1,3 +0,0 @@ -'' -Hello, world! -'' diff --git a/dhall-lang/tests/import/success/fieldOrderA.dhall b/dhall-lang/tests/import/success/fieldOrderA.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/fieldOrderA.dhall +++ /dev/null @@ -1,5 +0,0 @@ -{ example0 = - ../data/fieldOrder/1.dhall sha256:d8ae15ff5a40ee7973a23ba75cd98f8e39d14aeb6e1e3f18aadb092fcb825194 -, example1 = - ../data/fieldOrder/2.dhall sha256:d8ae15ff5a40ee7973a23ba75cd98f8e39d14aeb6e1e3f18aadb092fcb825194 -} diff --git a/dhall-lang/tests/import/success/fieldOrderB.dhall b/dhall-lang/tests/import/success/fieldOrderB.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/fieldOrderB.dhall +++ /dev/null @@ -1,1 +0,0 @@ -{ example0 = { bar = True, foo = 1 }, example1 = { bar = True, foo = 1 } } diff --git a/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall b/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall deleted file mode 100644 --- a/dhall-lang/tests/import/success/referentiallyTransparentMissing.dhall +++ /dev/null @@ -1,9 +0,0 @@ -{- This test verifies that `missing` is treated as a referentially transparent - import. The following import contains a `missing as Location` in its - test assertion that should succeed since: - - * The `missing` is never actually resolved (due to the `as Location`) - * The `missing` should be treated as referentially transparent (and therefore - be a valid transitive dependency of a remote import) --} -https://prelude.dhall-lang.org/v11.0.0/Location/Type diff --git a/dhall-lang/tests/normalization/success/WithRecordValueA.dhall b/dhall-lang/tests/normalization/success/WithRecordValueA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/WithRecordValueA.dhall @@ -0,0 +1,12 @@ +{- This test illustrates that `with a = { c = 2 }` is not the same thing as + `with a.c = 2`: + + * `with a = { c = 2 }` overrides the entire value of the field `a` with a new + record containing only `c = 2` + + * `with a.c = 2` extends or updates the record stored underneath `a` to + set the field `c` to `2`. + + Compare this to the `WithNested` test, which contains the `a.c = 2` case +-} +{ a.b = 1 } with a = { c = 2 } diff --git a/dhall-lang/tests/normalization/success/WithRecordValueB.dhall b/dhall-lang/tests/normalization/success/WithRecordValueB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/WithRecordValueB.dhall @@ -0,0 +1,1 @@ +{ a = { c = 2 } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsA.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsA.dhall @@ -0,0 +1,1 @@ +let x = { y = 1 } in { x, x.z = 2 } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsB.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitAllSugarsB.dhall @@ -0,0 +1,1 @@ +{ x = { y = 1, z = 2 } } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitPun1A.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitPun1A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitPun1A.dhall @@ -0,0 +1,1 @@ +let x = 0 in { x } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitPun1B.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitPun1B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitPun1B.dhall @@ -0,0 +1,1 @@ +{ x = 0 } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitPun2A.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitPun2A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitPun2A.dhall @@ -0,0 +1,1 @@ +let x = 0 let y = 1 in { x, y, z = 2 } diff --git a/dhall-lang/tests/normalization/success/unit/RecordLitPun2B.dhall b/dhall-lang/tests/normalization/success/unit/RecordLitPun2B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/RecordLitPun2B.dhall @@ -0,0 +1,1 @@ +{ x = 0, y = 1, z = 2 } diff --git a/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionA.dhall b/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionA.dhall --- a/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionA.dhall +++ b/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionA.dhall @@ -1,1 +1,1 @@ -(x ⫽ { a = v, b = w }).{ a, c } +λ(x : { c : Natural }) → (x ⫽ { a = 1, b = 2 }).{ a, c } diff --git a/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionB.dhall b/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionB.dhall --- a/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionB.dhall +++ b/dhall-lang/tests/normalization/success/unit/RightBiasedRecordMergeWithinRecordProjectionB.dhall @@ -1,1 +1,1 @@ -x.{ c } ⫽ { a = v } +λ(x : { c : Natural }) → x.{ c } ⫽ { a = 1 } diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested1A.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested1A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested1A.dhall @@ -0,0 +1,1 @@ +λ(x: Text) → "${""}${x}" diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested1B.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested1B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested1B.dhall @@ -0,0 +1,1 @@ +λ(x : Text) → x diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested2A.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested2A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested2A.dhall @@ -0,0 +1,1 @@ +λ(x: Text) → "${"${x}"}" diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested2B.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested2B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested2B.dhall @@ -0,0 +1,1 @@ +λ(x : Text) → x diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested3A.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested3A.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested3A.dhall @@ -0,0 +1,1 @@ +λ(x: Text) → "${"${""}"}${x}" diff --git a/dhall-lang/tests/normalization/success/unit/TextLitNested3B.dhall b/dhall-lang/tests/normalization/success/unit/TextLitNested3B.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextLitNested3B.dhall @@ -0,0 +1,1 @@ +λ(x : Text) → x diff --git a/dhall-lang/tests/normalization/success/unit/TextShowEmptyA.dhall b/dhall-lang/tests/normalization/success/unit/TextShowEmptyA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextShowEmptyA.dhall @@ -0,0 +1,1 @@ +Text/show "" diff --git a/dhall-lang/tests/normalization/success/unit/TextShowEmptyB.dhall b/dhall-lang/tests/normalization/success/unit/TextShowEmptyB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/TextShowEmptyB.dhall @@ -0,0 +1,1 @@ +"\"\"" diff --git a/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedA.dhall b/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedA.dhall --- a/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedA.dhall +++ b/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedA.dhall @@ -1,1 +1,1 @@ -λ(with : Text) → Text/show "text ${with} interpolation" +λ(containing : Text) → Text/show "text ${containing} interpolation" diff --git a/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedB.dhall b/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedB.dhall --- a/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedB.dhall +++ b/dhall-lang/tests/normalization/success/unit/TextShowInterpolatedB.dhall @@ -1,1 +1,1 @@ -λ(with : Text) → Text/show "text ${with} interpolation" +λ(containing: Text) → Text/show "text ${containing} interpolation" diff --git a/dhall-lang/tests/normalization/success/unit/WithA.dhall b/dhall-lang/tests/normalization/success/unit/WithA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithA.dhall @@ -0,0 +1,1 @@ +{ a = 1 } with b = 2 diff --git a/dhall-lang/tests/normalization/success/unit/WithB.dhall b/dhall-lang/tests/normalization/success/unit/WithB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithB.dhall @@ -0,0 +1,1 @@ +{ a = 1, b = 2 } diff --git a/dhall-lang/tests/normalization/success/unit/WithChainedA.dhall b/dhall-lang/tests/normalization/success/unit/WithChainedA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithChainedA.dhall @@ -0,0 +1,4 @@ +{- This test verifies that an implementation correctly handles chained + `with` expressions +-} +{ a = 1 } with b = 2 with c = 3 diff --git a/dhall-lang/tests/normalization/success/unit/WithChainedB.dhall b/dhall-lang/tests/normalization/success/unit/WithChainedB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithChainedB.dhall @@ -0,0 +1,1 @@ +{ a = 1, b = 2, c = 3 } diff --git a/dhall-lang/tests/normalization/success/unit/WithNestedA.dhall b/dhall-lang/tests/normalization/success/unit/WithNestedA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithNestedA.dhall @@ -0,0 +1,12 @@ +{- This test verifies that an implementation handles `with` expressions that + update nested labels correctly + + A common mistake an implementation might make is to produce the following + result: + + { a.c = 2 } + + ... due to the nested update clobbering the inner record. A compliant + implementation extends inner records. +-} +{ a.b = 1 } with a.c = 2 diff --git a/dhall-lang/tests/normalization/success/unit/WithNestedB.dhall b/dhall-lang/tests/normalization/success/unit/WithNestedB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithNestedB.dhall @@ -0,0 +1,1 @@ +{ a = { b = 1, c = 2 } } diff --git a/dhall-lang/tests/normalization/success/unit/WithPriorityA.dhall b/dhall-lang/tests/normalization/success/unit/WithPriorityA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithPriorityA.dhall @@ -0,0 +1,6 @@ +{- This test ensures that updates are ordered and latter updates take priority + when the same field is updated more than one time + + In this example, the `a` field is updated twice, and the latter update wins +-} +{ a = 1 } with a = 2 with a = 3 diff --git a/dhall-lang/tests/normalization/success/unit/WithPriorityB.dhall b/dhall-lang/tests/normalization/success/unit/WithPriorityB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/normalization/success/unit/WithPriorityB.dhall @@ -0,0 +1,1 @@ +{ a = 3 } diff --git a/dhall-lang/tests/parser/failure/assertBinding.dhall b/dhall-lang/tests/parser/failure/assertBinding.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/failure/assertBinding.dhall @@ -0,0 +1,1 @@ +let assert = 2 in 1 diff --git a/dhall-lang/tests/parser/success/text/singleQuoteConcatA.dhall b/dhall-lang/tests/parser/success/text/singleQuoteConcatA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/singleQuoteConcatA.dhall @@ -0,0 +1,5 @@ +'' +a'' +++ +'' +b'' diff --git a/dhall-lang/tests/parser/success/text/singleQuoteConcatB.dhallb b/dhall-lang/tests/parser/success/text/singleQuoteConcatB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/text/singleQuoteConcatB.dhallb @@ -0,0 +1,1 @@ +„‚aa‚ab diff --git a/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralA.dhall b/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralA.dhall @@ -0,0 +1,1 @@ +{=} diff --git a/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralB.dhallb b/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/EmptyRecordLiteralB.dhallb @@ -0,0 +1,1 @@ +‚  diff --git a/dhall-lang/tests/parser/success/unit/LetAnnotA.dhall b/dhall-lang/tests/parser/success/unit/LetAnnotA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/LetAnnotA.dhall @@ -0,0 +1,1 @@ +let x: T = y in e diff --git a/dhall-lang/tests/parser/success/unit/LetAnnotB.dhallb b/dhall-lang/tests/parser/success/unit/LetAnnotB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/LetAnnotB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/LetNoAnnotA.dhall b/dhall-lang/tests/parser/success/unit/LetNoAnnotA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/LetNoAnnotA.dhall @@ -0,0 +1,1 @@ +let x = y in e diff --git a/dhall-lang/tests/parser/success/unit/LetNoAnnotB.dhallb b/dhall-lang/tests/parser/success/unit/LetNoAnnotB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/LetNoAnnotB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitPunA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitPunA.dhall @@ -0,0 +1,1 @@ +{ x, y, z } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitPunB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/RecordLitPunB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateA.dhall @@ -0,0 +1,1 @@ +{ x, y, x } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/RecordLitPunDuplicateB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunMixedA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitPunMixedA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitPunMixedA.dhall @@ -0,0 +1,1 @@ +{ x, y = 1, z, w.a.b = 2 } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunMixedB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitPunMixedB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/RecordLitPunMixedB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunSomeA.dhall b/dhall-lang/tests/parser/success/unit/RecordLitPunSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/RecordLitPunSomeA.dhall @@ -0,0 +1,1 @@ +{ Some } diff --git a/dhall-lang/tests/parser/success/unit/RecordLitPunSomeB.dhallb b/dhall-lang/tests/parser/success/unit/RecordLitPunSomeB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/RecordLitPunSomeB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/ToMapA.dhall b/dhall-lang/tests/parser/success/unit/ToMapA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ToMapA.dhall @@ -0,0 +1,1 @@ +toMap x diff --git a/dhall-lang/tests/parser/success/unit/ToMapAnnotA.dhall b/dhall-lang/tests/parser/success/unit/ToMapAnnotA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/ToMapAnnotA.dhall @@ -0,0 +1,1 @@ +toMap x : T diff --git a/dhall-lang/tests/parser/success/unit/ToMapAnnotB.dhallb b/dhall-lang/tests/parser/success/unit/ToMapAnnotB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/ToMapAnnotB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/ToMapB.dhallb b/dhall-lang/tests/parser/success/unit/ToMapB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/ToMapB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceA.dhall b/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceA.dhall @@ -0,0 +1,1 @@ +` x ` diff --git a/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceB.dhallb b/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/unit/VariableQuotedWithSpaceB.dhallb differ diff --git a/dhall-lang/tests/parser/success/unit/WithA.dhall b/dhall-lang/tests/parser/success/unit/WithA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithA.dhall @@ -0,0 +1,6 @@ +{- The purpose of this test is to verify that an implementation correctly + desugars the base case of a non-nested update. Specifically, an + implementation should not use an intermediate `let` when desugaring this + base case. +-} +{ a = 1 } with a = 2 diff --git a/dhall-lang/tests/parser/success/unit/WithB.dhallb b/dhall-lang/tests/parser/success/unit/WithB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithB.dhallb @@ -0,0 +1,1 @@ +„ ‚¡aa‚‚¡aa‚ diff --git a/dhall-lang/tests/parser/success/unit/WithMultipleA.dhall b/dhall-lang/tests/parser/success/unit/WithMultipleA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithMultipleA.dhall @@ -0,0 +1,8 @@ +{- This test ensures that `with` is purely syntactic sugar, meaning that it is + desugared before encoding and therefore is encoded as the desugared expression + in the CBOR encoding. + + This test also ensures that implementations desugar the code exactly as + specified (e.g. using an intermediate `let` binding) +-} +{ a.b = 1, c.d = 2 } with a.b = 3 with c.e = 4 diff --git a/dhall-lang/tests/parser/success/unit/WithMultipleB.dhallb b/dhall-lang/tests/parser/success/unit/WithMultipleB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithMultipleB.dhallb @@ -0,0 +1,1 @@ +„ „ ‚¢aa‚¡ab‚ac‚¡ad‚‚¡aa„ ƒ ‚¢aa‚¡ab‚ac‚¡ad‚aa‚¡ab‚‚¡ac„ ƒ „ ‚¢aa‚¡ab‚ac‚¡ad‚‚¡aa„ ƒ ‚¢aa‚¡ab‚ac‚¡ad‚aa‚¡ab‚ac‚¡ae‚ diff --git a/dhall-lang/tests/parser/success/unit/WithPrecedenceA.dhall b/dhall-lang/tests/parser/success/unit/WithPrecedenceA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithPrecedenceA.dhall @@ -0,0 +1,13 @@ +{- The purpose of this test is to illustrate that function application has + higher precedence than `with` so that chained with expressions parse + correctly + + The following expression should parse as: + + ({ a = Some 1 } with a = Some 2) with a = Some 3 + + ... and not parse as: + + { a = Some 1 } with a = (Some 2 with a = Some 3) +-} +{ a = Some 1 } with a = Some 2 with a = Some 3 diff --git a/dhall-lang/tests/parser/success/unit/WithPrecedenceB.dhallb b/dhall-lang/tests/parser/success/unit/WithPrecedenceB.dhallb new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/unit/WithPrecedenceB.dhallb @@ -0,0 +1,1 @@ +„ „ ‚¡aaƒö‚‚¡aaƒö‚‚¡aaƒö‚ diff --git a/dhall-lang/tests/parser/success/usingToMapA.dhall b/dhall-lang/tests/parser/success/usingToMapA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/parser/success/usingToMapA.dhall @@ -0,0 +1,1 @@ +https://example.com using (toMap { Foo = "Bar" }) diff --git a/dhall-lang/tests/parser/success/usingToMapB.dhallb b/dhall-lang/tests/parser/success/usingToMapB.dhallb new file mode 100644 Binary files /dev/null and b/dhall-lang/tests/parser/success/usingToMapB.dhallb differ diff --git a/dhall-lang/tests/type-inference/failure/SortInLet.dhall b/dhall-lang/tests/type-inference/failure/SortInLet.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/failure/SortInLet.dhall @@ -0,0 +1,1 @@ +let x = Sort in 0 diff --git a/dhall-lang/tests/type-inference/success/CacheImportsA.dhall b/dhall-lang/tests/type-inference/success/CacheImportsA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/CacheImportsA.dhall @@ -0,0 +1,6 @@ +{- + This URL returns (probably) a different result for each request. This test + ensures that import results for a given URL are correctly cached within an + execution of dhall. +-} +let _ = assert : https://csrng.net/csrng/csrng.php?min=0&max=1000 as Text === https://csrng.net/csrng/csrng.php?min=0&max=1000 as Text in 0 diff --git a/dhall-lang/tests/type-inference/success/CacheImportsB.dhall b/dhall-lang/tests/type-inference/success/CacheImportsB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/CacheImportsB.dhall @@ -0,0 +1,1 @@ +Natural diff --git a/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeA.dhall b/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeA.dhall @@ -0,0 +1,5 @@ +{- + This URL returns (probably) a different result for each request. This test + ensures that import locations are canonicalized before being cached. +-} +let _ = assert : https://csrng.net/csrng/csrng.php?min=0&max=1000 as Text === https://csrng.net/csrng/../csrng/csrng.php?min=0&max=1000 as Text in 0 diff --git a/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeB.dhall b/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/CacheImportsCanonicalizeB.dhall @@ -0,0 +1,1 @@ +Natural 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 @@ -226,7 +226,7 @@ ) → JSON , render : - ∀ ( j + ∀ ( json : ∀(JSON : Type) → ∀ ( json : { array : List JSON → JSON diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunA.dhall @@ -0,0 +1,1 @@ +\(x: Bool) -> { x } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunB.dhall @@ -0,0 +1,1 @@ +∀(x : Bool) → { x : Bool } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureA.dhall @@ -0,0 +1,1 @@ +\(x: Bool) -> \(x: Natural) -> { x } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunCaptureB.dhall @@ -0,0 +1,1 @@ +∀(x : Bool) → ∀(x : Natural) → { x : Natural } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeA.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeA.dhall @@ -0,0 +1,1 @@ +let `None` = 0 let `Some` = \(_: Bool) -> 1 in { None, Some } diff --git a/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeB.dhall b/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/RecordLitPunSomeB.dhall @@ -0,0 +1,1 @@ +{ None : Natural, Some : Bool → Natural } diff --git a/dhall-lang/tests/type-inference/success/unit/WithNewFieldA.dhall b/dhall-lang/tests/type-inference/success/unit/WithNewFieldA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithNewFieldA.dhall @@ -0,0 +1,4 @@ +{- This test illustrates how the `with` keyword is permitted to extend a record + with new fields +-} +{ a = 1 } with b = 2 diff --git a/dhall-lang/tests/type-inference/success/unit/WithNewFieldB.dhall b/dhall-lang/tests/type-inference/success/unit/WithNewFieldB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithNewFieldB.dhall @@ -0,0 +1,1 @@ +{ a : Natural, b : Natural } diff --git a/dhall-lang/tests/type-inference/success/unit/WithNewTypeA.dhall b/dhall-lang/tests/type-inference/success/unit/WithNewTypeA.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithNewTypeA.dhall @@ -0,0 +1,4 @@ +{- This test illustrates that the `with` keyword is permitted to override + existing fields with a value of a new type (just like the `//` operator) +-} +{ a = 1 } with a = True diff --git a/dhall-lang/tests/type-inference/success/unit/WithNewTypeB.dhall b/dhall-lang/tests/type-inference/success/unit/WithNewTypeB.dhall new file mode 100644 --- /dev/null +++ b/dhall-lang/tests/type-inference/success/unit/WithNewTypeB.dhall @@ -0,0 +1,1 @@ +{ a : Bool } diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,8 +1,8 @@ Name: dhall -Version: 1.30.0 +Version: 1.31.0 Cabal-Version: >=1.10 Build-Type: Simple -Tested-With: GHC == 8.0.2, GHC == 8.4.3, GHC == 8.6.1 +Tested-With: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 License: BSD3 License-File: LICENSE Copyright: 2017 Gabriel Gonzalez @@ -26,6 +26,7 @@ benchmark/deep-nested-large-record/*.dhall benchmark/examples/*.dhall benchmark/examples/normalize/*.dhall + man/dhall.1 CHANGELOG.md dhall-lang/Prelude/Bool/and dhall-lang/Prelude/Bool/build @@ -60,6 +61,7 @@ dhall-lang/Prelude/Integer/subtract dhall-lang/Prelude/Integer/toDouble dhall-lang/Prelude/Integer/toNatural + dhall-lang/Prelude/JSON/Format dhall-lang/Prelude/JSON/Nesting dhall-lang/Prelude/JSON/Tagged dhall-lang/Prelude/JSON/Type @@ -77,6 +79,7 @@ dhall-lang/Prelude/JSON/omitNullFields dhall-lang/Prelude/JSON/package.dhall dhall-lang/Prelude/JSON/render + dhall-lang/Prelude/JSON/renderAs dhall-lang/Prelude/JSON/renderInteger.dhall dhall-lang/Prelude/JSON/renderYAML dhall-lang/Prelude/JSON/string @@ -181,7 +184,6 @@ dhall-lang/tests/import/cache/dhall/1220efc43103e49b56c5bf089db8e0365bbfc455b8a2f0dc6ee5727a3586f85969fd dhall-lang/tests/import/data/*.dhall dhall-lang/tests/import/data/*.txt - dhall-lang/tests/import/data/fieldOrder/*.dhall dhall-lang/tests/import/failure/*.dhall dhall-lang/tests/import/success/*.dhall dhall-lang/tests/normalization/success/*.dhall @@ -448,7 +450,7 @@ filepath >= 1.4 && < 1.5 , haskeline >= 0.7.2.1 && < 0.9 , hashable >= 1.2 && < 1.4 , - lens-family-core >= 1.0.0 && < 2.1 , + lens-family-core >= 1.0.0 && < 2.2 , megaparsec >= 7 && < 8.1 , memory >= 0.14 && < 0.16, mtl >= 2.2.1 && < 2.3 , @@ -465,6 +467,7 @@ scientific >= 0.3.0.0 && < 0.4 , template-haskell >= 2.11.1.0 && < 2.16, text >= 0.11.1.0 && < 1.3 , + text-manipulate >= 0.2.0.1 && < 0.3 , th-lift-instances >= 0.1.13 && < 0.2 , transformers >= 0.2.0.0 && < 0.6 , transformers-compat >= 0.6.2 && < 0.7 , @@ -552,6 +555,9 @@ if !flag(cross) Exposed-Modules: Dhall.TH + if impl(ghc >= 8.6.1) + Exposed-Modules: + Dhall.Deriving Other-Modules: Dhall.Eval Dhall.Import.Types @@ -613,7 +619,7 @@ filepath , foldl < 1.5 , generic-random >= 1.3.0.0 && < 1.4 , - lens-family-core >= 1.0.0 && < 2.1 , + lens-family-core , megaparsec , prettyprinter , QuickCheck >= 2.10 && < 2.14, @@ -627,6 +633,7 @@ tasty-expected-failure < 0.12, tasty-hunit >= 0.10 && < 0.11, tasty-quickcheck >= 0.9.2 && < 0.11, + template-haskell , text >= 0.11.1.0 && < 1.3 , transformers , turtle < 1.6 , diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main where import Data.Monoid ((<>)) @@ -23,6 +25,12 @@ writeFile "both" "./bool1 && ./bool2" writeFile "file2" "./file1" writeFile "file1" "./file2" + writeFile "simon.dhall" $ unlines + [ "let Name = Text" + , "let Font = < Arial | `Comic Sans` | Helvetica | `Times New Roman` >" + , "let Person = { name : Name, favoriteFont : Font }" + , "in { name = \"Simon\", favoriteFont = Font.`Comic Sans` } : Person" + ] Test.DocTest.doctest [ "-DWITH_HTTP" @@ -38,6 +46,9 @@ -- , prefix "src" , "-i" <> (prefix "src") +#if __GLASGOW_HASKELL__ >= 806 + , prefix "src/Dhall/Deriving.hs" +#endif , prefix "src/Dhall/Tags.hs" , prefix "src/Dhall/Tutorial.hs" ] diff --git a/man/dhall.1 b/man/dhall.1 new file mode 100644 --- /dev/null +++ b/man/dhall.1 @@ -0,0 +1,100 @@ +.\" Automatically generated by Pandoc 2.9.2 +.\" +.TH "dhall (1)" "" "" "" "" +.hy +.SH NAME +.PP +dhall - a programmable configuration language +.SH DESCRIPTION +.PP +\f[B]dhall\f[R] is the command-line interface to the Dhall language +.SH SYNOPSIS +.PP +dhall --file check.dhall +.PP +dhall --file error.dhall --explain +.PP +dhall hash --file to-hash.dhall +.PP +dhall freeze --file with-imports.dhall +.PP +dhall repl +.PP +dhall diff \[aq]./file1.dhall\[cq] \[aq]./file2.dhall\[cq] +.PP +dhall type --quiet --file check-ci.dhall +.SH SUBCOMMANDS +.PP +\f[B]version\f[R] - Display version information +.PP +\f[B]resolve\f[R] - Resolve imports +.PP +\f[B]type\f[R] - Infer type of expression +.PP +\f[B]normalize\f[R] - Normalize an expression +.PP +\f[B]repl\f[R] - Open a REPL +.PP +\f[B]diff\f[R] - Show difference between two expressions +.PP +\f[B]hash\f[R] - Compute hash of expression +.PP +\f[B]lint\f[R] - Lint an expression, removing dead code +.PP +\f[B]tags\f[R] - Generate etags (Emacs) file +.PP +\f[B]format\f[R] - Format an expression +.PP +\f[B]freeze\f[R] - Add hashes to import statements +.PP +\f[B]encode\f[R] - Encode a Dhall expression (CBOR) +.PP +\f[B]decode\f[R] - Decode a Dhall expression +.PP +\f[B]text\f[R] - Render a Dhall expression to text +.PP +\f[B]to-directory-tree\f[R] - Convert nested record of Text into a +directory +.SH OPTIONS +.TP +\f[B]-h\f[R] \f[B]--help\f[R] +Display help +.TP +\f[B]--file\f[R] +Name of file containing Dhall source +.TP +\f[B]--output\f[R] +Output file +.TP +\f[B]--annotate\f[R] +Add type annotation to output +.TP +\f[B]--alpha\f[R] +alpha-normalize output +.TP +\f[B]--no-cache\f[R] +Don\[cq]t use cache to resolve imports +.TP +\f[B]--explain\f[R] +Explain error messages in detail +.TP +\f[B]--version\f[R] +Display version information +.TP +\f[B]--plain\f[R] +Disable syntax highlighting in output +.TP +\f[B]--ascii\f[R] +Format code using only ASCII syntax +.TP +\f[B]--censor\f[R] +Hide source code from error messages +.SH EDITOR INTEGRATION +.PP +Up-to-date information on editor integration is available at: +.PP +https://docs.dhall-lang.org/howtos/Text-Editor-Configuration.html +.SH BUGS +.PP +Please report any bugs you may come across to +https://github.com/dhall-language/dhall-haskell/issues. diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -59,6 +59,7 @@ , fromMonadic , auto , genericAuto + , genericAutoWith , InterpretOptions(..) , SingletonConstructors(..) , defaultInterpretOptions @@ -74,6 +75,7 @@ , list , vector , function + , functionWith , setFromDistinctList , setIgnoringDuplicates , hashSetFromDistinctList @@ -96,6 +98,7 @@ , Inject , inject , genericToDhall + , genericToDhallWith , RecordEncoder(..) , encodeFieldWith , encodeField @@ -841,21 +844,35 @@ {-| Decode a Dhall function into a Haskell function ->>> f <- input (function defaultInterpretOptions inject bool) "Natural/even" :: IO (Natural -> Bool) +>>> f <- input (function inject bool) "Natural/even" :: IO (Natural -> Bool) >>> f 0 True >>> f 1 False -} function - :: InterpretOptions + :: Encoder a + -> Decoder b + -> Decoder (a -> b) +function = functionWith defaultInputNormalizer + +{-| Decode a Dhall function into a Haskell function using the specified normalizer + +>>> f <- input (functionWith defaultInputNormalizer inject bool) "Natural/even" :: IO (Natural -> Bool) +>>> f 0 +True +>>> f 1 +False +-} +functionWith + :: InputNormalizer -> Encoder a -> Decoder b -> Decoder (a -> b) -function options (Encoder {..}) (Decoder extractIn expectedIn) = +functionWith inputNormalizer (Encoder {..}) (Decoder extractIn expectedIn) = Decoder extractOut expectedOut where - normalizer_ = Just (inputNormalizer options) + normalizer_ = Just (getInputNormalizer inputNormalizer) extractOut e = pure (\i -> case extractIn (Dhall.Core.normalizeWith normalizer_ (App e (embed i))) of Success o -> o @@ -1092,15 +1109,20 @@ >>> input auto "toMap { a = False, b = True }" :: IO (Map Text Bool) fromList [("a",False),("b",True)] - This class auto-generates a default implementation for records that + This class auto-generates a default implementation for types that implement `Generic`. This does not auto-generate an instance for recursive types. + + The default instance can be tweaked using 'genericAutoWith' and custom + 'InterpretOptions', or using + [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) + and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} class FromDhall a where - autoWith:: InterpretOptions -> Decoder a + autoWith :: InputNormalizer -> Decoder a default autoWith - :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Decoder a - autoWith options = fmap GHC.Generics.to (evalState (genericAutoWith options) 1) + :: (Generic a, GenericFromDhall (Rep a)) => InputNormalizer -> Decoder a + autoWith _ = genericAuto {-| A compatibility alias for `FromDhall` @@ -1160,29 +1182,29 @@ the list. To ignore duplicates, use `hashSetIgnoringDuplicates`. -} instance (FromDhall a, Hashable a, Ord a, Show a) => FromDhall (Data.HashSet.HashSet a) where - autoWith opts = hashSetFromDistinctList (autoWith opts) + autoWith inputNormalizer = hashSetFromDistinctList (autoWith inputNormalizer) instance (Ord k, FromDhall k, FromDhall v) => FromDhall (Map k v) where - autoWith opts = Dhall.map (autoWith opts) (autoWith opts) + autoWith inputNormalizer = Dhall.map (autoWith inputNormalizer) (autoWith inputNormalizer) instance (Eq k, Hashable k, FromDhall k, FromDhall v) => FromDhall (HashMap k v) where - autoWith opts = Dhall.hashMap (autoWith opts) (autoWith opts) + autoWith inputNormalizer = Dhall.hashMap (autoWith inputNormalizer) (autoWith inputNormalizer) instance (ToDhall a, FromDhall b) => FromDhall (a -> b) where - autoWith opts = - function opts (injectWith opts) (autoWith opts) + autoWith inputNormalizer = + functionWith inputNormalizer (injectWith inputNormalizer) (autoWith inputNormalizer) instance (FromDhall a, FromDhall b) => FromDhall (a, b) -{-| Use the default options for interpreting a configuration file +{-| Use the default input normalizer for interpreting a configuration file -> auto = autoWith defaultInterpretOptions +> auto = autoWith defaultInputNormalizer -} auto :: FromDhall a => Decoder a -auto = autoWith defaultInterpretOptions +auto = autoWith defaultInputNormalizer {-| This type is exactly the same as `Data.Fix.Fix` except with a different - `FromDhall` instance. This intermediate type simplies the implementation + `FromDhall` instance. This intermediate type simplifies the implementation of the inner loop for the `FromDhall` instance for `Fix` -} newtype Result f = Result { _unResult :: f (Result f) } @@ -1191,12 +1213,12 @@ resultToFix (Result x) = Fix (fmap resultToFix x) instance FromDhall (f (Result f)) => FromDhall (Result f) where - autoWith options = Decoder { expected = expected_, extract = extract_ } + autoWith inputNormalizer = Decoder { expected = expected_, extract = extract_ } where expected_ = "result" extract_ (App _ expression) = do - fmap Result (extract (autoWith options) expression) + fmap Result (extract (autoWith inputNormalizer) expression) extract_ expression = do typeError expression expected_ @@ -1275,18 +1297,18 @@ -- > -- > print (convert x :: Expr) instance (Functor f, FromDhall (f (Result f))) => FromDhall (Fix f) where - autoWith options = Decoder { expected = expected_, extract = extract_ } + autoWith inputNormalizer = Decoder { expected = expected_, extract = extract_ } where expected_ = Pi "result" (Const Dhall.Core.Type) - (Pi "Make" (Pi "_" (expected (autoWith options :: Decoder (f (Result f)))) "result") + (Pi "Make" (Pi "_" (expected (autoWith inputNormalizer :: Decoder (f (Result f)))) "result") "result" ) extract_ expression0 = go0 (Dhall.Core.alphaNormalize expression0) where go0 (Lam _ _ (Lam _ _ expression1)) = - fmap resultToFix (extract (autoWith options) expression1) + fmap resultToFix (extract (autoWith inputNormalizer) expression1) go0 _ = typeError expected_ expression0 {-| `genericAuto` is the default implementation for `auto` if you derive @@ -1295,8 +1317,14 @@ the type derives `Generic` -} genericAuto :: (Generic a, GenericFromDhall (Rep a)) => Decoder a -genericAuto = fmap to (evalState (genericAutoWith defaultInterpretOptions) 1) +genericAuto = genericAutoWith defaultInterpretOptions +{-| `genericAutoWith` is a configurable version of `genericAuto`. +-} +genericAutoWith :: (Generic a, GenericFromDhall (Rep a)) => InterpretOptions -> Decoder a +genericAutoWith options = fmap to (evalState (genericAutoWithNormalizer defaultInputNormalizer options) 1) + + {-| Use these options to tweak how Dhall derives a generic implementation of `FromDhall` -} @@ -1310,12 +1338,18 @@ , singletonConstructors :: SingletonConstructors -- ^ Specify how to handle constructors with only one field. The default is -- `Smart` - , inputNormalizer :: Dhall.Core.ReifiedNormalizer Void - -- ^ This is only used by the `FromDhall` instance for functions in order - -- to normalize the function input before marshaling the input into a - -- Dhall expression } +-- | This is only used by the `FromDhall` instance for functions in order +-- to normalize the function input before marshaling the input into a +-- Dhall expression +newtype InputNormalizer = InputNormalizer + { getInputNormalizer :: Dhall.Core.ReifiedNormalizer Void } + +defaultInputNormalizer :: InputNormalizer +defaultInputNormalizer = InputNormalizer + { getInputNormalizer = Dhall.Core.ReifiedNormalizer (const (pure Nothing)) } + {-| This type specifies how to model a Haskell constructor with 1 field in Dhall @@ -1339,9 +1373,10 @@ | Smart -- ^ Only fields in a record if they are named -{-| Default interpret options, which you can tweak or override, like this: +{-| Default interpret options for generics-based instances, + which you can tweak or override, like this: -> autoWith +> genericAutoWith > (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') }) -} defaultInterpretOptions :: InterpretOptions @@ -1352,23 +1387,21 @@ id , singletonConstructors = Smart - , inputNormalizer = - Dhall.Core.ReifiedNormalizer (const (pure Nothing)) } {-| This is the underlying class that powers the `FromDhall` class's support for automatically deriving a generic implementation -} class GenericFromDhall f where - genericAutoWith :: InterpretOptions -> State Int (Decoder (f a)) + genericAutoWithNormalizer :: InputNormalizer -> InterpretOptions -> State Int (Decoder (f a)) instance GenericFromDhall f => GenericFromDhall (M1 D d f) where - genericAutoWith options = do - res <- genericAutoWith options + genericAutoWithNormalizer inputNormalizer options = do + res <- genericAutoWithNormalizer inputNormalizer options pure (fmap M1 res) instance GenericFromDhall V1 where - genericAutoWith _ = pure Decoder {..} + genericAutoWithNormalizer _ _ = pure Decoder {..} where extract expr = typeError expected expr @@ -1429,7 +1462,7 @@ empty instance (Constructor c1, Constructor c2, GenericFromDhall f1, GenericFromDhall f2) => GenericFromDhall (M1 C c1 f1 :+: M1 C c2 f2) where - genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) + genericAutoWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Decoder {..}) where nL :: M1 i c1 f1 a nL = undefined @@ -1457,11 +1490,11 @@ ] ) - Decoder extractL expectedL = evalState (genericAutoWith options) 1 - Decoder extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWithNormalizer inputNormalizer options) 1 + Decoder extractR expectedR = evalState (genericAutoWithNormalizer inputNormalizer options) 1 instance (Constructor c, GenericFromDhall (f :+: g), GenericFromDhall h) => GenericFromDhall ((f :+: g) :+: M1 C c h) where - genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) + genericAutoWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Decoder {..}) where n :: M1 i c h a n = undefined @@ -1478,13 +1511,13 @@ expected = Union (Dhall.Map.insert name (notEmptyRecord expectedR) ktsL) - Decoder extractL expectedL = evalState (genericAutoWith options) 1 - Decoder extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWithNormalizer inputNormalizer options) 1 + Decoder extractR expectedR = evalState (genericAutoWithNormalizer inputNormalizer options) 1 - ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL + ktsL = unsafeExpectUnion "genericAutoWithNormalizer (:+:)" expectedL instance (Constructor c, GenericFromDhall f, GenericFromDhall (g :+: h)) => GenericFromDhall (M1 C c f :+: (g :+: h)) where - genericAutoWith options@(InterpretOptions {..}) = pure (Decoder {..}) + genericAutoWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Decoder {..}) where n :: M1 i c f a n = undefined @@ -1501,31 +1534,31 @@ expected = Union (Dhall.Map.insert name (notEmptyRecord expectedL) ktsR) - Decoder extractL expectedL = evalState (genericAutoWith options) 1 - Decoder extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWithNormalizer inputNormalizer options) 1 + Decoder extractR expectedR = evalState (genericAutoWithNormalizer inputNormalizer options) 1 - ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR + ktsR = unsafeExpectUnion "genericAutoWithNormalizer (:+:)" expectedR instance (GenericFromDhall (f :+: g), GenericFromDhall (h :+: i)) => GenericFromDhall ((f :+: g) :+: (h :+: i)) where - genericAutoWith options = pure (Decoder {..}) + genericAutoWithNormalizer inputNormalizer options = pure (Decoder {..}) where extract e = fmap L1 (extractL e) `ealt` fmap R1 (extractR e) expected = Union (Dhall.Map.union ktsL ktsR) - Decoder extractL expectedL = evalState (genericAutoWith options) 1 - Decoder extractR expectedR = evalState (genericAutoWith options) 1 + Decoder extractL expectedL = evalState (genericAutoWithNormalizer inputNormalizer options) 1 + Decoder extractR expectedR = evalState (genericAutoWithNormalizer inputNormalizer options) 1 - ktsL = unsafeExpectUnion "genericAutoWith (:+:)" expectedL - ktsR = unsafeExpectUnion "genericAutoWith (:+:)" expectedR + ktsL = unsafeExpectUnion "genericAutoWithNormalizer (:+:)" expectedL + ktsR = unsafeExpectUnion "genericAutoWithNormalizer (:+:)" expectedR instance GenericFromDhall f => GenericFromDhall (M1 C c f) where - genericAutoWith options = do - res <- genericAutoWith options + genericAutoWithNormalizer inputNormalizer options = do + res <- genericAutoWithNormalizer inputNormalizer options pure (fmap M1 res) instance GenericFromDhall U1 where - genericAutoWith _ = pure (Decoder {..}) + genericAutoWithNormalizer _ _ = pure (Decoder {..}) where extract _ = pure U1 @@ -1539,12 +1572,12 @@ nn -> pure (Data.Text.pack nn) instance (GenericFromDhall (f :*: g), GenericFromDhall (h :*: i)) => GenericFromDhall ((f :*: g) :*: (h :*: i)) where - genericAutoWith options = do - Decoder extractL expectedL <- genericAutoWith options - Decoder extractR expectedR <- genericAutoWith options + genericAutoWithNormalizer inputNormalizer options = do + Decoder extractL expectedL <- genericAutoWithNormalizer inputNormalizer options + Decoder extractR expectedR <- genericAutoWithNormalizer inputNormalizer options - let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL - let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR + let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" expectedL + let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" expectedR let expected = Record (Dhall.Map.union ktsL ktsR) @@ -1554,17 +1587,17 @@ return (Decoder {..}) instance (GenericFromDhall (f :*: g), Selector s, FromDhall a) => GenericFromDhall ((f :*: g) :*: M1 S s (K1 i a)) where - genericAutoWith options@InterpretOptions{..} = do + genericAutoWithNormalizer inputNormalizer options@InterpretOptions{..} = do let nR :: M1 S s (K1 i a) r nR = undefined nameR <- fmap fieldModifier (getSelName nR) - Decoder extractL expectedL <- genericAutoWith options + Decoder extractL expectedL <- genericAutoWithNormalizer inputNormalizer options - let Decoder extractR expectedR = autoWith options + let Decoder extractR expectedR = autoWith inputNormalizer - let ktsL = unsafeExpectRecord "genericAutoWith (:*:)" expectedL + let ktsL = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" expectedL let expected = Record (Dhall.Map.insert nameR expectedR ktsL) @@ -1584,17 +1617,17 @@ return (Decoder {..}) instance (Selector s, FromDhall a, GenericFromDhall (f :*: g)) => GenericFromDhall (M1 S s (K1 i a) :*: (f :*: g)) where - genericAutoWith options@InterpretOptions{..} = do + genericAutoWithNormalizer inputNormalizer options@InterpretOptions{..} = do let nL :: M1 S s (K1 i a) r nL = undefined nameL <- fmap fieldModifier (getSelName nL) - let Decoder extractL expectedL = autoWith options + let Decoder extractL expectedL = autoWith inputNormalizer - Decoder extractR expectedR <- genericAutoWith options + Decoder extractR expectedR <- genericAutoWithNormalizer inputNormalizer options - let ktsR = unsafeExpectRecord "genericAutoWith (:*:)" expectedR + let ktsR = unsafeExpectRecord "genericAutoWithNormalizer (:*:)" expectedR let expected = Record (Dhall.Map.insert nameL expectedL ktsR) @@ -1614,7 +1647,7 @@ return (Decoder {..}) instance (Selector s1, Selector s2, FromDhall a1, FromDhall a2) => GenericFromDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericAutoWith options@InterpretOptions{..} = do + genericAutoWithNormalizer inputNormalizer InterpretOptions{..} = do let nL :: M1 S s1 (K1 i1 a1) r nL = undefined @@ -1624,8 +1657,8 @@ nameL <- fmap fieldModifier (getSelName nL) nameR <- fmap fieldModifier (getSelName nR) - let Decoder extractL expectedL = autoWith options - let Decoder extractR expectedR = autoWith options + let Decoder extractL expectedL = autoWith inputNormalizer + let Decoder extractR expectedR = autoWith inputNormalizer let expected = Record @@ -1651,13 +1684,13 @@ return (Decoder {..}) instance (Selector s, FromDhall a) => GenericFromDhall (M1 S s (K1 i a)) where - genericAutoWith options@InterpretOptions{..} = do + genericAutoWithNormalizer inputNormalizer InterpretOptions{..} = do let n :: M1 S s (K1 i a) r n = undefined name <- fmap fieldModifier (getSelName n) - let Decoder { extract = extract', expected = expected'} = autoWith options + let Decoder { extract = extract', expected = expected'} = autoWith inputNormalizer let expected = case singletonConstructors of @@ -1720,13 +1753,21 @@ (i.e. @App f x@) * Normalizing the syntax tree (i.e. @normalize (App f x)@) * Marshaling the resulting Dhall expression back into a Haskell value + + This class auto-generates a default implementation for types that + implement `Generic`. This does not auto-generate an instance for recursive + types. + + The default instance can be tweaked using 'genericToDhallWith' and custom + 'InterpretOptions', or using + [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) + and 'Dhall.Deriving.Codec' from "Dhall.Deriving". -} class ToDhall a where - injectWith :: InterpretOptions -> Encoder a + injectWith :: InputNormalizer -> Encoder a default injectWith - :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a - injectWith options - = contramap GHC.Generics.from (evalState (genericToDhallWith options) 1) + :: (Generic a, GenericToDhall (Rep a)) => InputNormalizer -> Encoder a + injectWith _ = genericToDhall {-| A compatibility alias for `ToDhall` @@ -1734,12 +1775,12 @@ -} type Inject = ToDhall -{-| Use the default options for injecting a value +{-| Use the default input normalizer for injecting a value -> inject = injectWith defaultInterpretOptions +> inject = injectWith defaultInputNormalizer -} inject :: ToDhall a => Encoder a -inject = injectWith defaultInterpretOptions +inject = injectWith defaultInputNormalizer {-| Use the default options for injecting a value, whose structure is determined generically. @@ -1750,8 +1791,19 @@ genericToDhall :: (Generic a, GenericToDhall (Rep a)) => Encoder a genericToDhall - = contramap GHC.Generics.from (evalState (genericToDhallWith defaultInterpretOptions) 1) + = genericToDhallWith defaultInterpretOptions +{-| Use custom options for injecting a value, whose structure is +determined generically. + +This can be used when you want to use 'ToDhall' on types that you don't +want to define orphan instances for. +-} +genericToDhallWith + :: (Generic a, GenericToDhall (Rep a)) => InterpretOptions -> Encoder a +genericToDhallWith options + = contramap GHC.Generics.from (evalState (genericToDhallWithNormalizer defaultInputNormalizer options) 1) + instance ToDhall Void where injectWith _ = Encoder {..} where @@ -1782,8 +1834,8 @@ declared = Text instance {-# OVERLAPS #-} ToDhall String where - injectWith options = - contramap Data.Text.pack (injectWith options :: Encoder Text) + injectWith inputNormalizer = + contramap Data.Text.pack (injectWith inputNormalizer :: Encoder Text) instance ToDhall Natural where injectWith _ = Encoder {..} @@ -1879,8 +1931,8 @@ declared = Double instance ToDhall Scientific where - injectWith options = - contramap Data.Scientific.toRealFloat (injectWith options :: Encoder Double) + injectWith inputNormalizer = + contramap Data.Scientific.toRealFloat (injectWith inputNormalizer :: Encoder Double) instance ToDhall () where injectWith _ = Encoder {..} @@ -1890,17 +1942,17 @@ declared = Record mempty instance ToDhall a => ToDhall (Maybe a) where - injectWith options = Encoder embedOut declaredOut + injectWith inputNormalizer = Encoder embedOut declaredOut where embedOut (Just x ) = Some (embedIn x) embedOut Nothing = App None declaredIn - Encoder embedIn declaredIn = injectWith options + Encoder embedIn declaredIn = injectWith inputNormalizer declaredOut = App Optional declaredIn instance ToDhall a => ToDhall (Seq a) where - injectWith options = Encoder embedOut declaredOut + injectWith inputNormalizer = Encoder embedOut declaredOut where embedOut xs = ListLit listType (fmap embedIn xs) where @@ -1910,7 +1962,7 @@ declaredOut = App List declaredIn - Encoder embedIn declaredIn = injectWith options + Encoder embedIn declaredIn = injectWith inputNormalizer instance ToDhall a => ToDhall [a] where injectWith = fmap (contramap Data.Sequence.fromList) injectWith @@ -1918,7 +1970,7 @@ instance ToDhall a => ToDhall (Vector a) where injectWith = fmap (contramap Data.Vector.toList) injectWith -{-| Note that the ouput list will be sorted +{-| Note that the output list will be sorted >>> let x = Data.Set.fromList ["mom", "hi" :: Text] >>> prettyExpr $ embed inject x @@ -1928,7 +1980,7 @@ instance ToDhall a => ToDhall (Data.Set.Set a) where injectWith = fmap (contramap Data.Set.toAscList) injectWith -{-| Note that the ouput list may not be sorted +{-| Note that the output list may not be sorted >>> let x = Data.HashSet.fromList ["hi", "mom" :: Text] >>> prettyExpr $ embed inject x @@ -1950,7 +2002,7 @@ -} instance (ToDhall k, ToDhall v) => ToDhall (Data.Map.Map k v) where - injectWith options = Encoder embedOut declaredOut + injectWith inputNormalizer = Encoder embedOut declaredOut where embedOut m = ListLit listType (mapEntries m) where @@ -1965,8 +2017,8 @@ recordPair (k, v) = RecordLit (Dhall.Map.fromList [("mapKey", embedK k), ("mapValue", embedV v)]) - Encoder embedK declaredK = injectWith options - Encoder embedV declaredV = injectWith options + Encoder embedK declaredK = injectWith inputNormalizer + Encoder embedV declaredV = injectWith inputNormalizer {-| Embed a `Data.HashMap` as a @Prelude.Map.Type@ @@ -1978,7 +2030,7 @@ -} instance (ToDhall k, ToDhall v) => ToDhall (HashMap k v) where - injectWith options = Encoder embedOut declaredOut + injectWith inputNormalizer = Encoder embedOut declaredOut where embedOut m = ListLit listType (mapEntries m) where @@ -1993,29 +2045,29 @@ recordPair (k, v) = RecordLit (Dhall.Map.fromList [("mapKey", embedK k), ("mapValue", embedV v)]) - Encoder embedK declaredK = injectWith options - Encoder embedV declaredV = injectWith options + Encoder embedK declaredK = injectWith inputNormalizer + Encoder embedV declaredV = injectWith inputNormalizer {-| This is the underlying class that powers the `FromDhall` class's support for automatically deriving a generic implementation -} class GenericToDhall f where - genericToDhallWith :: InterpretOptions -> State Int (Encoder (f a)) + genericToDhallWithNormalizer :: InputNormalizer -> InterpretOptions -> State Int (Encoder (f a)) instance GenericToDhall f => GenericToDhall (M1 D d f) where - genericToDhallWith options = do - res <- genericToDhallWith options + genericToDhallWithNormalizer inputNormalizer options = do + res <- genericToDhallWithNormalizer inputNormalizer options pure (contramap unM1 res) instance GenericToDhall f => GenericToDhall (M1 C c f) where - genericToDhallWith options = do - res <- genericToDhallWith options + genericToDhallWithNormalizer inputNormalizer options = do + res <- genericToDhallWithNormalizer inputNormalizer options pure (contramap unM1 res) instance (Selector s, ToDhall a) => GenericToDhall (M1 S s (K1 i a)) where - genericToDhallWith options@InterpretOptions{..} = do + genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do let Encoder { embed = embed', declared = declared' } = - injectWith options + injectWith inputNormalizer let n :: M1 S s (K1 i a) r n = undefined @@ -2045,7 +2097,7 @@ return (Encoder {..}) instance (Constructor c1, Constructor c2, GenericToDhall f1, GenericToDhall f2) => GenericToDhall (M1 C c1 f1 :+: M1 C c2 f2) where - genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -2078,11 +2130,11 @@ keyL = constructorModifier (Data.Text.pack (conName nL)) keyR = constructorModifier (Data.Text.pack (conName nR)) - Encoder embedL declaredL = evalState (genericToDhallWith options) 1 - Encoder embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 instance (Constructor c, GenericToDhall (f :+: g), GenericToDhall h) => GenericToDhall ((f :+: g) :+: M1 C c h) where - genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 l) = case maybeValL of @@ -2090,7 +2142,7 @@ Just valL -> App (Field declared keyL) valL where (keyL, maybeValL) = - unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedL l) + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) embed (R1 (M1 r)) = case notEmptyRecordLit (embedR r) of Nothing -> Field declared keyR @@ -2103,13 +2155,13 @@ declared = Union (Dhall.Map.insert keyR (notEmptyRecord declaredR) ktsL) - Encoder embedL declaredL = evalState (genericToDhallWith options) 1 - Encoder embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL + ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL instance (Constructor c, GenericToDhall f, GenericToDhall (g :+: h)) => GenericToDhall (M1 C c f :+: (g :+: h)) where - genericToDhallWith options@(InterpretOptions {..}) = pure (Encoder {..}) + genericToDhallWithNormalizer inputNormalizer options@(InterpretOptions {..}) = pure (Encoder {..}) where embed (L1 (M1 l)) = case notEmptyRecordLit (embedL l) of @@ -2121,7 +2173,7 @@ Just valR -> App (Field declared keyR) valR where (keyR, maybeValR) = - unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedR r) + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) nL :: M1 i c f a nL = undefined @@ -2130,13 +2182,13 @@ declared = Union (Dhall.Map.insert keyL (notEmptyRecord declaredL) ktsR) - Encoder embedL declaredL = evalState (genericToDhallWith options) 1 - Encoder embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR + ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR instance (GenericToDhall (f :+: g), GenericToDhall (h :+: i)) => GenericToDhall ((f :+: g) :+: (h :+: i)) where - genericToDhallWith options = pure (Encoder {..}) + genericToDhallWithNormalizer inputNormalizer options = pure (Encoder {..}) where embed (L1 l) = case maybeValL of @@ -2144,92 +2196,92 @@ Just valL -> App (Field declared keyL) valL where (keyL, maybeValL) = - unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedL l) + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedL l) embed (R1 r) = case maybeValR of Nothing -> Field declared keyR Just valR -> App (Field declared keyR) valR where (keyR, maybeValR) = - unsafeExpectUnionLit "genericToDhallWith (:+:)" (embedR r) + unsafeExpectUnionLit "genericToDhallWithNormalizer (:+:)" (embedR r) declared = Union (Dhall.Map.union ktsL ktsR) - Encoder embedL declaredL = evalState (genericToDhallWith options) 1 - Encoder embedR declaredR = evalState (genericToDhallWith options) 1 + Encoder embedL declaredL = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 + Encoder embedR declaredR = evalState (genericToDhallWithNormalizer inputNormalizer options) 1 - ktsL = unsafeExpectUnion "genericToDhallWith (:+:)" declaredL - ktsR = unsafeExpectUnion "genericToDhallWith (:+:)" declaredR + ktsL = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredL + ktsR = unsafeExpectUnion "genericToDhallWithNormalizer (:+:)" declaredR instance (GenericToDhall (f :*: g), GenericToDhall (h :*: i)) => GenericToDhall ((f :*: g) :*: (h :*: i)) where - genericToDhallWith options = do - Encoder embedL declaredL <- genericToDhallWith options - Encoder embedR declaredR <- genericToDhallWith options + genericToDhallWithNormalizer inputNormalizer options = do + Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options + Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options let embed (l :*: r) = RecordLit (Dhall.Map.union mapL mapR) where mapL = - unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l) + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) mapR = - unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r) + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) let declared = Record (Dhall.Map.union mapL mapR) where - mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL - mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR + mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL + mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR pure (Encoder {..}) instance (GenericToDhall (f :*: g), Selector s, ToDhall a) => GenericToDhall ((f :*: g) :*: M1 S s (K1 i a)) where - genericToDhallWith options@InterpretOptions{..} = do + genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do let nR :: M1 S s (K1 i a) r nR = undefined nameR <- fmap fieldModifier (getSelName nR) - Encoder embedL declaredL <- genericToDhallWith options + Encoder embedL declaredL <- genericToDhallWithNormalizer inputNormalizer options - let Encoder embedR declaredR = injectWith options + let Encoder embedR declaredR = injectWith inputNormalizer let embed (l :*: M1 (K1 r)) = RecordLit (Dhall.Map.insert nameR (embedR r) mapL) where mapL = - unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedL l) + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedL l) let declared = Record (Dhall.Map.insert nameR declaredR mapL) where - mapL = unsafeExpectRecord "genericToDhallWith (:*:)" declaredL + mapL = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredL return (Encoder {..}) instance (Selector s, ToDhall a, GenericToDhall (f :*: g)) => GenericToDhall (M1 S s (K1 i a) :*: (f :*: g)) where - genericToDhallWith options@InterpretOptions{..} = do + genericToDhallWithNormalizer inputNormalizer options@InterpretOptions{..} = do let nL :: M1 S s (K1 i a) r nL = undefined nameL <- fmap fieldModifier (getSelName nL) - let Encoder embedL declaredL = injectWith options + let Encoder embedL declaredL = injectWith inputNormalizer - Encoder embedR declaredR <- genericToDhallWith options + Encoder embedR declaredR <- genericToDhallWithNormalizer inputNormalizer options let embed (M1 (K1 l) :*: r) = RecordLit (Dhall.Map.insert nameL (embedL l) mapR) where mapR = - unsafeExpectRecordLit "genericToDhallWith (:*:)" (embedR r) + unsafeExpectRecordLit "genericToDhallWithNormalizer (:*:)" (embedR r) let declared = Record (Dhall.Map.insert nameL declaredL mapR) where - mapR = unsafeExpectRecord "genericToDhallWith (:*:)" declaredR + mapR = unsafeExpectRecord "genericToDhallWithNormalizer (:*:)" declaredR return (Encoder {..}) instance (Selector s1, Selector s2, ToDhall a1, ToDhall a2) => GenericToDhall (M1 S s1 (K1 i1 a1) :*: M1 S s2 (K1 i2 a2)) where - genericToDhallWith options@InterpretOptions{..} = do + genericToDhallWithNormalizer inputNormalizer InterpretOptions{..} = do let nL :: M1 S s1 (K1 i1 a1) r nL = undefined @@ -2239,8 +2291,8 @@ nameL <- fmap fieldModifier (getSelName nL) nameR <- fmap fieldModifier (getSelName nR) - let Encoder embedL declaredL = injectWith options - let Encoder embedR declaredR = injectWith options + let Encoder embedL declaredL = injectWith inputNormalizer + let Encoder embedR declaredR = injectWith inputNormalizer let embed (M1 (K1 l) :*: M1 (K1 r)) = RecordLit @@ -2257,7 +2309,7 @@ return (Encoder {..}) instance GenericToDhall U1 where - genericToDhallWith _ = pure (Encoder {..}) + genericToDhallWithNormalizer _ _ = pure (Encoder {..}) where embed _ = RecordLit mempty diff --git a/src/Dhall/Binary.hs b/src/Dhall/Binary.hs --- a/src/Dhall/Binary.hs +++ b/src/Dhall/Binary.hs @@ -44,6 +44,7 @@ , ImportMode(..) , ImportType(..) , MultiLet(..) + , PreferAnnotation(..) , Scheme(..) , URL(..) , Var(..) @@ -65,10 +66,10 @@ import qualified Data.ByteString.Lazy import qualified Data.Sequence import qualified Data.Text as Text -import qualified Dhall.Syntax import qualified Dhall.Crypto import qualified Dhall.Map import qualified Dhall.Set +import qualified Dhall.Syntax as Syntax import qualified Text.Printf as Printf {-| Supported version strings @@ -306,7 +307,7 @@ 6 -> return TextAppend 7 -> return ListAppend 8 -> return (Combine Nothing) - 9 -> return Prefer + 9 -> return (Prefer PreferFromSource) 10 -> return CombineTypes 11 -> return ImportAlt 12 -> return Equivalent @@ -759,7 +760,7 @@ Combine _ l r -> encodeOperator 8 l r - Prefer l r -> + Prefer _ l r -> encodeOperator 9 l r CombineTypes l r -> @@ -910,7 +911,7 @@ : concatMap encodeBinding (toList as) ++ [ go b₁ ] ) where - MultiLet as b₁ = Dhall.Syntax.multiLet a₀ b₀ + MultiLet as b₁ = Syntax.multiLet a₀ b₀ encodeBinding (Binding _ x _ mA₀ _ a) = [ Encoding.encodeString x @@ -939,6 +940,9 @@ (go t) (go _T) + a@With{} -> + go (Syntax.desugarWith a) + Note _ b -> go b @@ -1104,7 +1108,7 @@ Nothing -> Encoding.encodeNull Just h -> - encodeExpressionInternal encodeImport (Dhall.Syntax.denote h) + encodeExpressionInternal encodeImport (Syntax.denote h) scheme₁ = case scheme₀ of HTTP -> 0 diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -24,6 +24,7 @@ , Binding(..) , makeBinding , Chunks(..) + , PreferAnnotation(..) , Expr(..) -- * Normalization @@ -66,6 +67,7 @@ , Eval.textShow , censorExpression , censorText + , Syntax.desugarWith ) where import Control.Exception (Exception) @@ -82,8 +84,9 @@ import Prelude hiding (succ) import qualified Control.Exception -import qualified Dhall.Eval as Eval import qualified Data.Text +import qualified Dhall.Eval as Eval +import qualified Dhall.Syntax as Syntax -- | Pretty-print a value pretty :: Pretty a => a -> Text diff --git a/src/Dhall/Deriving.hs b/src/Dhall/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Deriving.hs @@ -0,0 +1,548 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| Newtypes for writing customizable 'FromDhall' and 'ToDhall' instances + through the DerivingVia strategy. + + Inspired by Matt Parson's blog post + [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html), + but applied to Dhall instead of JSON. + + This module is intended to be used with + [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia) + so it's only available for GHC >= v8.6.1. + + Check the section /Letting DerivingVia do the work/ if you want to see this module in action. (Click "Dhall.Deriving#derivingVia" to jump there) + +-} + +module Dhall.Deriving + ( + -- * Introduction + -- $introduction + + -- * Writing FromDhall instances by hand + -- $instancesByHand + + -- * Letting DerivingVia do the work + -- $derivingVia + + -- * Behind the scenes of Codec + -- $behindTheScenes + + -- * DerivingVia newtype + Codec (..) + + -- * Type-level functions on InterpretOptions + , ModifyOptions (..) + , Field + , Constructor + , SetSingletonConstructors + + -- * Type-level functions on Text + , TextFunction (..) + , DropPrefix + , TitleCase + , CamelCase + , PascalCase + , SnakeCase + , SpinalCase + , TrainCase + + -- * Type-level versions of SingletonConstructors + , ToSingletonConstructors + , Bare + , Wrapped + , Smart + + -- * Identity and Composition for ModifyOptions and TextFunction + , AsIs + , type (<<<) + + -- * Helper function on Text + , dropPrefix + + -- * InterpretOptions setters + , addFieldModifier + , addConstructorModifier + , setSingletonConstructors + + ) where + +import Data.Proxy (Proxy (..)) +import Dhall +import GHC.Generics (Generic (Rep)) +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) + +import qualified Data.Text as Text +import qualified Data.Text.Manipulate as Case + +-- | Intended for use on @deriving via@ clauses for types with a +-- 'Generic' instance. The @tag@ argument is used to construct an +-- 'InterpretOptions' value which is used as the first argument +-- to 'genericAutoWith'. +newtype Codec tag a = Codec { unCodec :: a } + +instance (Generic a, GenericFromDhall (Rep a), ModifyOptions tag) => FromDhall (Codec tag a) where + autoWith _ = Codec <$> genericAutoWith (modifyOptions @tag defaultInterpretOptions) + +instance (Generic a, GenericToDhall (Rep a), ModifyOptions tag) => ToDhall (Codec tag a) where + injectWith _ = unCodec >$< genericToDhallWith (modifyOptions @tag defaultInterpretOptions) + +-- | Convert a type into a @InterpretOptions -> InterpretOptions@ function +class ModifyOptions a where + modifyOptions :: InterpretOptions -> InterpretOptions + + +-- | The identity for functions on 'InterpretOptions' and on @Text@. +-- Useful for deriving @FromDhall@ and @ToDhall@ with the default options. +type AsIs = () + +instance ModifyOptions AsIs where + modifyOptions = id + +instance TextFunction AsIs where + textFunction = id + + +-- | Composition for functions on 'InterpretOptions' and on @Text@. +-- We use @<<<@ since @.@ isn't a valid type operator yet +-- (it will be valid starting from ghc-8.8.1) +data a <<< b +infixr 1 <<< + +instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where + modifyOptions = modifyOptions @a . modifyOptions @b + +instance (TextFunction a, TextFunction b) => TextFunction (a <<< b) where + textFunction = textFunction @a . textFunction @b + + +-- | @Field t@ post-composes the @fieldModifier@ from @options@ with the +-- value-level version of @t@, obtained with @TextFunction@ +data Field a +instance TextFunction a => ModifyOptions (Field a) where + modifyOptions = addFieldModifier (textFunction @a) + +-- | @Constructor t@ post-composes the @constructorModifier@ from @options@ +-- with the value-level version of @t@, obtained with @TextFunction@ +data Constructor a +instance TextFunction a => ModifyOptions (Constructor a) where + modifyOptions = addConstructorModifier (textFunction @a) + + +-- * Text Functions + +-- | Convert a type into a @Text -> Text@ function +class TextFunction a where + textFunction :: Text -> Text + +-- | @DropPrefix prefix@ corresponds to the value level +-- function @'dropPrefix' prefix@ +data DropPrefix (s :: Symbol) +instance KnownSymbol s => TextFunction (DropPrefix s) where + textFunction = dropPrefix (Text.pack (symbolVal @s Proxy)) + +-- | Convert casing to @Title Cased Phrase@ +data TitleCase +instance TextFunction TitleCase where + textFunction = Case.toTitle + +-- | Convert casing to @camelCasedPhrase@ +data CamelCase +instance TextFunction CamelCase where + textFunction = Case.toCamel + +-- | Convert casing to @PascalCasedPhrase@ +data PascalCase +instance TextFunction PascalCase where + textFunction = Case.toPascal + +-- | Convert casing to @snake_cased_phrase@ +data SnakeCase +instance TextFunction SnakeCase where + textFunction = Case.toSnake + +-- | Convert casing to @spinal-cased-phrase@ +data SpinalCase +instance TextFunction SpinalCase where + textFunction = Case.toSpinal + +-- | Convert casing to @Train-Cased-Phrase@ +data TrainCase +instance TextFunction TrainCase where + textFunction = Case.toTrain + + +-- | @SetSingletonConstructors t@ replaces the @singletonConstructors@ +-- from @options@ with the value-level version of @t@. +data SetSingletonConstructors a +instance ToSingletonConstructors a => ModifyOptions (SetSingletonConstructors a) where + modifyOptions = setSingletonConstructors (asSingletonConstructors @a) + +-- | Convert a type of kind @SingletonConstructors@ +-- into a value of type @SingletonConstructors@ +class ToSingletonConstructors (a :: SingletonConstructors) where + asSingletonConstructors :: SingletonConstructors + +-- | Type-level version of 'Dhall.Bare'. +-- Never wrap the field of a singleton constructor in a record +type Bare = 'Bare +instance ToSingletonConstructors Bare where + asSingletonConstructors = Bare + +-- | Type-level version of 'Dhall.Wrapped' +-- Always wrap the field of a singleton constructor in a record +type Wrapped = 'Wrapped +instance ToSingletonConstructors Wrapped where + asSingletonConstructors = Wrapped + +-- | Type-level version of 'Dhall.Smart' +-- Wrap the field of a singleton constructor in a record +-- only if the field is named +type Smart = 'Smart +instance ToSingletonConstructors Smart where + asSingletonConstructors = Smart + + +-- * Text helper + +-- | @dropPrefix prefix text@ returns the suffix of @text@ if its prefix +-- matches @prefix@, or the entire @text@ otherwise +dropPrefix :: Text -> (Text -> Text) +dropPrefix prefix text = case Text.stripPrefix prefix text of + Just stripped -> stripped + Nothing -> text + +-- * InterpretOptions setters + +-- | @addFieldModifier f options@ post-composes the @fieldModifier@ +-- from @options@ with @f@. +addFieldModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions +addFieldModifier f options = options + { fieldModifier = f . fieldModifier options } + +-- | @addConstructorModifier f options@ post-composes the @constructorModifier@ +-- from @options@ with @f@. +addConstructorModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions +addConstructorModifier f options = options + { constructorModifier = f . constructorModifier options } + +-- | @setSingletonConstructors v options@ replaces the @singletonConstructors@ +-- from @options@ with @v@. +setSingletonConstructors :: SingletonConstructors -> InterpretOptions -> InterpretOptions +setSingletonConstructors v options = options + { singletonConstructors = v } + +{- $introduction + +Let's take the following Haskell data types: + +>>> :set -XDerivingStrategies + +>>> :{ +newtype Name = Name { getName :: Text } + deriving stock (Show) +:} + +>>> :{ +data Font = Arial | ComicSans | Helvetica | TimesNewRoman + deriving stock (Show) +:} + +>>> :{ +data Person = Person + { personName :: Name + , personFavoriteFont :: Font + } + deriving stock (Show) +:} + +And assume we want to read the following Dhall file as a @Person@: + +@ +-- ./simon.dhall +let Name = Text +let Font = \< Arial | `Comic Sans` | Helvetica | `Times New Roman` \> +let Person = { name : Name, favoriteFont : Font } +in { name = \"Simon\", favoriteFont = Font.`Comic Sans` } : Person +@ + +Usually, you would build a 'Decoder' by hand, like this + +>>> :{ +font :: Decoder Font +font = + union + ( (Arial <$ constructor "Arial" unit) + <> (ComicSans <$ constructor "Comic Sans" unit) + <> (Helvetica <$ constructor "Helvetica" unit) + <> (TimesNewRoman <$ constructor "Times New Roman" unit) + ) +:} + +>>> :{ +name :: Decoder Name +name = Name <$> strictText +:} + +>>> :{ +person :: Decoder Person +person = + record + ( Person <$> field "name" name + <*> field "favoriteFont" font + ) +:} + +and then you use it like this + +>>> input person "./simon.dhall" +Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans} + +So, it works! However, this is quite mechanic, and the compiler has pretty +much all the information it needs to do it for you. Besides, you'd like to +provide an instance of 'FromDhall' so you can use the polymorphic 'Decoder' +'auto' instead of explicitly calling @person@. +-} + +{- $instancesByHand +"Aha!," you think, "I'll write an empty @instance 'FromDhall' Person@". +That in turn requires you to add two other instances for @Font@ and for @Name@, +plus 'Generic' instances for each of those, but that's okay. + +>>> :set -XStandaloneDeriving +>>> :set -XDeriveGeneric + +>>> :{ +deriving stock instance Generic Name +deriving stock instance Generic Font +deriving stock instance Generic Person +:} + +>>> :{ +instance FromDhall Name +instance FromDhall Font +instance FromDhall Person +:} + +However, when you try to read the same file with 'auto', you get this: + +>>> input auto "./simon.dhall" :: IO Person +*** Exception: +...Error...: Expression doesn't match annotation +... +{ - personFavoriteFont : … +, - personName : … +, + favoriteFont : … +, + name : … +} +... +1│ ./simon.dhall : { personName : { getName : Text } +2│ , personFavoriteFont : < Arial | ComicSans | Helvetica | TimesNewRoman > +3│ } +... + +What happened? The field names don't quite match, since we're using prefixed +field names in Haskell but no prefixes in Dhall. "Okay," you think, +"I can write a custom instance which builds on 'Generic' thanks to +'genericAutoWith', I only need to supply a function to drop the prefixes +and @camelCase@ the rest". So, using 'Data.Text.Manipulate.toCamel': + +>>> import Data.Text.Manipulate (toCamel) +>>> import qualified Data.Text as Text +>>> :{ +instance FromDhall Person where + autoWith _ = + genericAutoWith defaultInterpretOptions + { fieldModifier = toCamel . Text.drop (Text.length "person") } +:} + +Let's try to read that again: + +>>> input auto "./simon.dhall":: IO Person +*** Exception: +...Error...: Expression doesn't match annotation +... +{ favoriteFont : < - ComicSans : … + | - TimesNewRoman : … + | + `Comic Sans` : … + | + `Times New Roman` : … + | … + > +, name : - { … : … } + + Text +} +... +1│ ./simon.dhall : { name : { getName : Text } +2│ , favoriteFont : < Arial | ComicSans | Helvetica | TimesNewRoman > +3│ } +... + +Okay, we're almost there. We have two things to solve now. +First, the @Font@ constructors are @PascalCased@ in Haskell, +but @Title Cased@ in Dhall. We can communicate this to our +'FromDhall' instance using 'Data.Text.Manipulate.toTitle': + +>>> import Data.Text.Manipulate (toTitle) +>>> :{ +instance FromDhall Font where + autoWith _ = + genericAutoWith defaultInterpretOptions + { constructorModifier = toTitle } +:} + +Second, we defined the @Name@ type in Haskell as a newtype over @Text@, with a +@getName@ field for unwrapping. In Dhall, however, @Name@ is a synonym of +'Text', which is why 'input' above was expecting a record. +The 'Dhall.Bare' option for 'singletonConstructors' is a perfect fit here: +it translates Haskell singleton constructors into the Dhall version of the +nested type, without wrapping it into a record. +We can then tweak our 'FromDhall' instance like this: + +>>> :{ +instance FromDhall Name where + autoWith _ = + genericAutoWith defaultInterpretOptions + { singletonConstructors = Bare } +:} + +Since we're running this interactively, we also need to update the +instance for @Person@, but it's the same as before. + +>>> :{ +instance FromDhall Person where + autoWith _ = + genericAutoWith defaultInterpretOptions + { fieldModifier = toCamel . Text.drop (Text.length "person") } +:} + +Now, for the moment of truth: + +>>> input auto "./simon.dhall":: IO Person +Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans} + +That took a bit more work than we wanted, though, and a lot of it was just +boilerplate for defining the instances through `genericAutoWith`, tweaking +a single parameter at a time. Even worse, if we also wanted to provide +'ToDhall' instances we would need to keep the options in sync between both +instances, since otherwise the values wouldn't be able to round-trip from +Dhall to Dhall through Haskell. + +-} + +{- $derivingVia + #derivingVia# + +Starting with this dhall file: + +@ +-- ./simon.dhall +let Name = Text +let Font = \< Arial | `Comic Sans` | Helvetica | `Times New Roman` \> +let Person = { name : Name, favoriteFont : Font } +in { name = \"Simon\", favoriteFont = Font.`Comic Sans` } : Person +@ + +We can define the equivalent Haskell types as follows. Note that we +derive the 'FromDhall' and 'ToDhall' instances @via 'Codec' tag TheType@, +using a different @tag@ depending on the transformations we need to apply to +the Haskell type to get the Dhall equivalent: + +>>> :set -XDataKinds +>>> :set -XDeriveGeneric +>>> :set -XDerivingVia +>>> :set -XTypeOperators + +>>> :{ +newtype Name = Name { getName :: Text } + deriving stock (Generic, Show) + deriving (FromDhall, ToDhall) + via Codec (SetSingletonConstructors Bare) Name +:} + +>>> :{ +data Font = Arial | ComicSans | Helvetica | TimesNewRoman + deriving stock (Generic, Show) + deriving (FromDhall, ToDhall) + via Codec (Constructor TitleCase) Font +:} + +>>> :{ +data Person = Person + { personName :: Name + , personFavoriteFont :: Font + } + deriving stock (Generic, Show) + deriving (FromDhall, ToDhall) + via Codec (Field (CamelCase <<< DropPrefix "person")) Person +:} + +we can then read the file using 'auto': + +>>> simon <- input auto "./simon.dhall":: IO Person +>>> print simon +Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans} + +And using 'inject' we can get @simon@ back as a Dhall value: + +>>> import qualified Data.Text.IO as Text +>>> import Dhall.Core (pretty) +>>> Text.putStrLn . pretty . embed inject $ simon +{ name = "Simon" +, favoriteFont = + < Arial | `Comic Sans` | Helvetica | `Times New Roman` >.`Comic Sans` +} + +-} + +{- $behindTheScenes + +@'Codec' tag a@ is really just a newtype over @a@, equipped with a +phantom @tag@. The 'FromDhall' instance for 'Codec' uses the generic +representation of @a@, together with the 'InterpretOptions' defined by @tag@ as +a series of modifications to be applied on 'defaultInterpretOptions'. + +For the default behavior, using 'AsIs' (a synonym for @()@) as the @tag@ +leaves the interpret options alone, so it's equivalent to the empty instance +we first tried to use. + +@'Field' a@ and @'Constructor' a@ can be used to modify, respectively, the +'fieldModifier' and 'constructorModifier' options of 'InterpretOptions', by +post-composing the modifier with @'textFunction' \@a@, that is, the value-level +equivalent of @a@, obtained through the 'TextFunction' class. + +In the case of @Person@, we used + +@ + Codec (Field (CamelCase <<< DropPrefix "person")) Person +@ + +which means that the @Text -> Text@ version of + +@ + CamelCase <<< DropPrefix "person" +@ + +was used to modify the @fieldModifier@ option. + +In the value level, this translates to composing ('<<<') +'Data.Text.Manipulate.toCamel' ('CamelCase') with @'dropPrefix' "person"@ +(@'DropPrefix' "person"@). + +Finally, @'SetSingletonConstructors' a@ can be used to set the +'singletonConstructors' option of 'InterpretOptions', by replacing the option +with the value-level equivalent of @a@. +-} + +{- $setup +>>> :set -XOverloadedStrings +-} diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -31,15 +31,16 @@ import Dhall.Pretty.Internal (Ann) import Numeric.Natural (Natural) -import qualified Data.Algorithm.Diff as Algo.Diff +import qualified Data.Algorithm.Diff as Algo.Diff import qualified Data.List.NonEmpty import qualified Data.Set import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Dhall.Normalize +import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Dhall.Map +import qualified Dhall.Normalize as Normalize +import qualified Dhall.Pretty.Internal as Internal import qualified Dhall.Set -import qualified Dhall.Pretty.Internal as Internal +import qualified Dhall.Syntax as Syntax {-| This type is a `Doc` enriched with a `same` flag to efficiently track if any difference was detected @@ -158,8 +159,8 @@ diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff diffNormalized l0 r0 = Dhall.Diff.diff l1 r1 where - l1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize l0) - r1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize r0) + l1 = Normalize.alphaNormalize (Normalize.normalize l0) + r1 = Normalize.alphaNormalize (Normalize.normalize r0) diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff diffPrimitive f l r @@ -619,6 +620,12 @@ <> ignore <> " " <> rbrace +skeleton (With {}) = + ignore + <> " " + <> keyword "with" + <> " " + <> ignore skeleton x = token (Pretty.pretty x) mismatch :: Pretty a => Expr s a -> Expr s a -> Diff @@ -729,8 +736,8 @@ where doc = keyword "merge" <> " " - <> format " " (diffImportExpression aL aR) - <> format " " (diffImportExpression bL bR) + <> format " " (diffWithExpression aL aR) + <> format " " (diffWithExpression bL bR) <> diffMaybe (colon <> " ") diffApplicationExpression cL cR diffAnnotatedExpression l@(Merge {}) r = mismatch l r @@ -740,7 +747,7 @@ where doc = keyword "toMap" <> " " - <> format " " (diffImportExpression aL aR) + <> format " " (diffWithExpression aL aR) <> diffMaybe (colon <> " ") diffApplicationExpression bL bR diffAnnotatedExpression l@(ToMap {}) r = mismatch l r @@ -897,7 +904,7 @@ diffPreferExpression l@(Prefer {}) r@(Prefer {}) = enclosed' " " (operator "⫽" <> " ") (docs l r) where - docs (Prefer aL bL) (Prefer aR bR) = + docs (Prefer _ aL bL) (Prefer _ aR bR) = Data.List.NonEmpty.cons (diffCombineTypesExpression aL aR) (docs bL bR) docs aL aR = pure (diffCombineTypesExpression aL aR) @@ -989,26 +996,36 @@ enclosed' mempty mempty (Data.List.NonEmpty.reverse (docs l r)) where docs (App aL bL) (App aR bR) = - Data.List.NonEmpty.cons (diffImportExpression bL bR) (docs aL aR) + Data.List.NonEmpty.cons (diffWithExpression bL bR) (docs aL aR) docs (Some aL) (Some aR) = - diffImportExpression aL aR :| [ builtin "Some" ] + diffWithExpression aL aR :| [ builtin "Some" ] docs aL aR@(Some {}) = pure (mismatch aL aR) docs aL@(Some {}) aR = pure (mismatch aL aR) docs aL aR = - pure (diffImportExpression aL aR) + pure (diffWithExpression aL aR) diffApplicationExpression l@(App {}) r = mismatch l r diffApplicationExpression l r@(App {}) = mismatch l r diffApplicationExpression (Some l) (Some r) = - enclosed' mempty mempty (builtin "Some" :| [ diffImportExpression l r ]) + enclosed' mempty mempty (builtin "Some" :| [ diffWithExpression l r ]) diffApplicationExpression l@(Some {}) r = mismatch l r diffApplicationExpression l r@(Some {}) = mismatch l r diffApplicationExpression l r = + diffWithExpression l r + +diffWithExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff +diffWithExpression l@With{} r@With{} = + diffWithExpression (Syntax.desugarWith l) (Syntax.desugarWith r) +diffWithExpression l r@With{} = + mismatch l r +diffWithExpression l@With{} r = + mismatch l r +diffWithExpression l r = diffImportExpression l r diffImportExpression :: (Eq a, Pretty a) => Expr Void a -> Expr Void a -> Diff diff --git a/src/Dhall/DirectoryTree.hs b/src/Dhall/DirectoryTree.hs --- a/src/Dhall/DirectoryTree.hs +++ b/src/Dhall/DirectoryTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,7 @@ , FilesystemError(..) ) where +import Control.Applicative (empty) import Control.Exception (Exception) import Data.Monoid ((<>)) import Data.Void (Void) @@ -15,18 +17,22 @@ import System.FilePath (()) import qualified Control.Exception as Exception +import qualified Data.Foldable as Foldable +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty -import qualified Dhall.Util as Util import qualified Dhall.Map as Map import qualified Dhall.Pretty +import qualified Dhall.Util as Util import qualified System.Directory as Directory -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO +import qualified System.FilePath as FilePath {-| Attempt to transform a Dhall record into a directory tree where: * Records are translated into directories + * @Map@s are also translated into directories + * @Text@ values or fields are translated into files * @Optional@ values are omitted if @None@ @@ -77,17 +83,20 @@ This utility does not take care of type-checking and normalizing the provided expression. This will raise a `FilesystemError` exception upon - encountering an expression that is not a `TextLit` or `RecordLit`. + encountering an expression that cannot be converted as-is. -} toDirectoryTree :: FilePath -> Expr Void Void -> IO () toDirectoryTree path expression = case expression of RecordLit keyValues -> do - let process key value = do - Directory.createDirectoryIfMissing False path + Map.unorderedTraverseWithKey_ process keyValues - toDirectoryTree (path Text.unpack key) value + ListLit (Just (Record [ ("mapKey", Text), ("mapValue", _) ])) [] -> do + return () - Map.unorderedTraverseWithKey_ process keyValues + ListLit _ records + | not (null records) + , Just keyValues <- extract (Foldable.toList records) -> do + Foldable.traverse_ (uncurry process) keyValues TextLit (Chunks [] text) -> do Text.IO.writeFile path text @@ -99,10 +108,30 @@ return () _ -> do - let unexpectedExpression = expression + die + where + extract [] = do + return [] - Exception.throwIO FilesystemError{..} + extract (RecordLit [("mapKey", TextLit (Chunks [] key)), ("mapValue", value)]:records) = do + fmap ((key, value) :) (extract records) + extract _ = do + empty + + process key value = do + if Text.isInfixOf (Text.pack [ FilePath.pathSeparator ]) key + then die + else return () + + Directory.createDirectoryIfMissing False path + + toDirectoryTree (path Text.unpack key) value + + die = Exception.throwIO FilesystemError{..} + where + unexpectedExpression = expression + {- | This error indicates that you supplied an invalid Dhall expression to the `directoryTree` function. The Dhall expression could not be translated to a directory tree. @@ -118,10 +147,10 @@ Util._ERROR <> ": Not a valid directory tree expression\n\ \ \n\ \Explanation: Only a subset of Dhall expressions can be converted to a directory \n\ - \tree. Specifically, record literals can be converted to directories, ❰Text❱ \n\ - \literals can be converted to files, and ❰Optional❱ values are included if ❰Some❱\n\ - \and omitted if ❰None❱. No other type of value can be translated to a directory \n\ - \tree. \n\ + \tree. Specifically, record literals or maps can be converted to directories, \n\ + \❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if\n\ + \❰Some❱ and omitted if ❰None❱. No other type of value can be translated to a \n\ + \directory tree. \n\ \ \n\ \For example, this is a valid expression that can be translated to a directory \n\ \tree: \n\ @@ -141,11 +170,26 @@ \ └───────────────────────┘ \n\ \ \n\ \ \n\ + \Note that key names cannot contain path separators: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────┐ \n\ + \ │ { `directory/example.txt` = \"ABC\" │ Invalid: Key contains a forward slash \n\ + \ └───────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \Instead, you need to refactor the expression to use nested records instead: \n\ + \ \n\ + \ \n\ + \ ┌───────────────────────────────────────────┐ \n\ + \ │ { directory = { `example.txt` = \"ABC\" } } │ \n\ + \ └───────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ \You tried to translate the following expression to a directory tree: \n\ \ \n\ \" <> Util.insert unexpectedExpression <> "\n\ \ \n\ - \... which is neither a ❰Text❱ literal, a record literal, nor an ❰Optional❱ \n\ - \value. \n" + \... which is not an expression that can be translated to a directory tree. \n" instance Exception FilesystemError diff --git a/src/Dhall/Eval.hs b/src/Dhall/Eval.hs --- a/src/Dhall/Eval.hs +++ b/src/Dhall/Eval.hs @@ -57,6 +57,10 @@ import Data.Sequence (Seq, ViewL(..), ViewR(..)) import Data.Text (Text) import Data.Void (Void) +import Dhall.Map (Map) +import Dhall.Set (Set) +import GHC.Natural (Natural) +import Prelude hiding (succ) import Dhall.Syntax ( Binding(..) @@ -64,14 +68,10 @@ , Chunks(..) , Const(..) , DhallDouble(..) + , PreferAnnotation(..) , Var(..) ) -import Dhall.Map (Map) -import Dhall.Set (Set) -import GHC.Natural (Natural) -import Prelude hiding (succ) - import qualified Data.Char import qualified Data.Sequence as Sequence import qualified Data.Set @@ -688,10 +688,10 @@ vCombine mk (eval env t) (eval env u) CombineTypes t u -> vCombineTypes (eval env t) (eval env u) - Prefer t u -> + Prefer _ t u -> vPrefer env (eval env t) (eval env u) RecordCompletion t u -> - eval env (Annot (Prefer (Field t "default") u) (Field t "Type")) + eval env (Annot (Prefer PreferFromCompletion (Field t "default") u) (Field t "Type")) Merge x y ma -> case (eval env x, eval env y, fmap (eval env) ma) of (VRecordLit m, VInject _ k mt, _) @@ -736,6 +736,8 @@ VAssert (eval env t) Equivalent t u -> VEquivalent (eval env t) (eval env u) + e@With{} -> + eval env (Syntax.desugarWith e) Note _ e -> eval env e ImportAlt t _ -> @@ -1117,7 +1119,7 @@ VCombineTypes t u -> CombineTypes (quote env t) (quote env u) VPrefer t u -> - Prefer (quote env t) (quote env u) + Prefer PreferFromSource (quote env t) (quote env u) VMerge t u ma -> Merge (quote env t) (quote env u) (fmap (quote env) ma) VToMap t ma -> @@ -1296,8 +1298,8 @@ Combine m (go t) (go u) CombineTypes t u -> CombineTypes (go t) (go u) - Prefer t u -> - Prefer (go t) (go u) + Prefer b t u -> + Prefer b (go t) (go u) RecordCompletion t u -> RecordCompletion (go t) (go u) Merge x y ma -> @@ -1312,6 +1314,8 @@ Assert (go t) Equivalent t u -> Equivalent (go t) (go u) + With e k v -> + With (go e) k (go v) Note s e -> Note s (go e) ImportAlt t u -> diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -164,6 +164,7 @@ , ImportType(..) , ImportMode(..) , Import(..) + , PreferAnnotation(..) , URL(..) , bindingExprs , chunkExprs @@ -989,7 +990,7 @@ let referentiallySane = not (local child) || local parent - if referentiallySane + if importMode import₀ == Location || referentiallySane then return () else throwMissingImport (Imported _stack (ReferentiallyOpaque import₀)) @@ -1080,7 +1081,12 @@ Union a -> Union <$> mapM (mapM loadWith) a 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 + Prefer a b c -> Prefer <$> a' <*> loadWith b <*> loadWith c + where + a' = case a of + PreferFromSource -> pure PreferFromSource + PreferFromWith e -> PreferFromWith <$> loadWith e + PreferFromCompletion -> pure PreferFromCompletion RecordCompletion a b -> RecordCompletion <$> loadWith a <*> loadWith b Merge a b c -> Merge <$> loadWith a <*> loadWith b <*> mapM loadWith c ToMap a b -> ToMap <$> loadWith a <*> mapM loadWith b @@ -1088,6 +1094,7 @@ Project a b -> Project <$> loadWith a <*> mapM loadWith b Assert a -> Assert <$> loadWith a Equivalent a b -> Equivalent <$> loadWith a <*> loadWith b + With a b c -> With <$> loadWith a <*> pure b <*> loadWith c Note a b -> do let handler e = throwM (SourcedException a (e :: MissingImports)) diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs --- a/src/Dhall/Main.hs +++ b/src/Dhall/Main.hs @@ -159,7 +159,24 @@ | ListTransitiveDependencies | ListImmediateDependencies +-- | Groups of subcommands +data Group + = Manipulate + | Generate + | Interpret + | Convert + | Miscellaneous + | Debugging +groupDescription :: Group -> String +groupDescription group = case group of + Manipulate -> "Manipulate Dhall code" + Generate -> "Generate other formats from Dhall" + Interpret -> "Interpret Dhall" + Convert -> "Convert Dhall to and from its binary representation" + Miscellaneous -> "Miscellaneous" + Debugging -> "Debugging this interpreter" + -- | `Parser` for the `Options` type parseOptions :: Parser Options parseOptions = @@ -181,12 +198,12 @@ f True = Censor f False = NoCensor -subcommand' :: Bool -> String -> String -> Parser a -> Parser a -subcommand' internal name description parser = +subcommand :: Group -> String -> String -> Parser a -> Parser a +subcommand group name description parser = Options.Applicative.hsubparser ( Options.Applicative.command name parserInfo <> Options.Applicative.metavar name - <> if internal then Options.Applicative.internal else mempty + <> Options.Applicative.commandGroup (groupDescription group) ) where parserInfo = @@ -195,75 +212,85 @@ <> Options.Applicative.progDesc description ) -subcommand :: String -> String -> Parser a -> Parser a -subcommand = subcommand' False - -internalSubcommand :: String -> String -> Parser a -> Parser a -internalSubcommand = subcommand' True - parseMode :: Parser Mode parseMode = subcommand - "version" - "Display version" - (pure Version) + Manipulate + "format" + "Standard code formatter for the Dhall language" + (Format <$> parseInplace <*> parseCheck) <|> subcommand + Manipulate + "freeze" + "Add integrity checks to remote import statements of an expression" + (Freeze <$> parseInplace <*> parseAllFlag <*> parseCacheFlag <*> parseCheck) + <|> subcommand + Manipulate + "lint" + "Improve Dhall code by using newer language features and removing dead code" + (Lint <$> parseInplace <*> parseCheck) + <|> subcommand + Generate + "text" + "Render a Dhall expression that evaluates to a Text literal" + (Text <$> parseFile) + <|> subcommand + Generate + "to-directory-tree" + "Convert nested records of Text literals into a directory tree" + (DirectoryTree <$> parseFile <*> parseDirectoryTreeOutput) + <|> subcommand + Interpret "resolve" "Resolve an expression's imports" (Resolve <$> parseFile <*> parseResolveMode <*> parseSemanticCacheMode) <|> subcommand + Interpret "type" "Infer an expression's type" (Type <$> parseFile <*> parseQuiet <*> parseSemanticCacheMode) <|> subcommand + Interpret "normalize" "Normalize an expression" (Normalize <$> parseFile <*> parseAlpha) <|> subcommand + Convert + "encode" + "Encode a Dhall expression to binary" + (Encode <$> parseFile <*> parseJSONFlag) + <|> subcommand + Convert + "decode" + "Decode a Dhall expression from binary" + (Decode <$> parseFile <*> parseJSONFlag) + <|> subcommand + Miscellaneous "repl" "Interpret expressions in a REPL" (pure Repl) <|> subcommand + Miscellaneous "diff" "Render the difference between the normal form of two expressions" (Diff <$> argument "expr1" <*> argument "expr2") <|> subcommand + Miscellaneous "hash" "Compute semantic hashes for Dhall expressions" (Hash <$> parseFile) <|> subcommand - "lint" - "Improve Dhall code by using newer language features and removing dead code" - (Lint <$> parseInplace <*> parseCheck) - <|> subcommand + Miscellaneous "tags" "Generate etags file" (Tags <$> parseInput <*> parseTagsOutput <*> parseSuffixes <*> parseFollowSymlinks) <|> subcommand - "format" - "Standard code formatter for the Dhall language" - (Format <$> parseInplace <*> parseCheck) - <|> subcommand - "freeze" - "Add integrity checks to remote import statements of an expression" - (Freeze <$> parseInplace <*> parseAllFlag <*> parseCacheFlag <*> parseCheck) - <|> subcommand - "encode" - "Encode a Dhall expression to binary" - (Encode <$> parseFile <*> parseJSONFlag) - <|> subcommand - "decode" - "Decode a Dhall expression from binary" - (Decode <$> parseFile <*> parseJSONFlag) - <|> subcommand - "text" - "Render a Dhall expression that evaluates to a Text literal" - (Text <$> parseFile) + Miscellaneous + "version" + "Display version" + (pure Version) <|> subcommand - "to-directory-tree" - "Convert nested records of Text literals into a directory tree" - (DirectoryTree <$> parseFile <*> parseDirectoryTreeOutput) - <|> internalSubcommand + Debugging "haskell-syntax-tree" "Output the parsed syntax tree (for debugging)" (SyntaxTree <$> parseFile) diff --git a/src/Dhall/Normalize.hs b/src/Dhall/Normalize.hs --- a/src/Dhall/Normalize.hs +++ b/src/Dhall/Normalize.hs @@ -24,10 +24,19 @@ import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..), ViewR(..)) import Data.Traversable -import Dhall.Syntax (Expr(..), Var(..), Binding(Binding), Chunks(..), DhallDouble(..), Const(..)) import Instances.TH.Lift () import Prelude hiding (succ) +import Dhall.Syntax + ( Expr(..) + , Var(..) + , Binding(Binding) + , Chunks(..) + , DhallDouble(..) + , Const(..) + , PreferAnnotation(..) + ) + import qualified Data.Sequence import qualified Data.Set import qualified Data.Text @@ -240,10 +249,10 @@ where a' = shift d v a b' = shift d v b -shift d v (Prefer a b) = Prefer a' b' +shift d v (Prefer a b c) = Prefer a b' c' where - a' = shift d v a b' = shift d v b + c' = shift d v c shift d v (RecordCompletion a b) = RecordCompletion a' b' where a' = shift d v a @@ -271,6 +280,10 @@ where a' = shift d v a b' = fmap (shift d v) b +shift d v (With a b c) = With a' b c' + where + a' = shift d v a + c' = shift d v c shift d v (Note a b) = Note a b' where b' = shift d v b @@ -415,10 +428,10 @@ where a' = subst x e a b' = subst x e b -subst x e (Prefer a b) = Prefer a' b' +subst x e (Prefer a b c) = Prefer a b' c' where - a' = subst x e a b' = subst x e b + c' = subst x e c subst x e (RecordCompletion a b) = RecordCompletion a' b' where a' = subst x e a @@ -446,6 +459,10 @@ where a' = subst x e a b' = subst x e b +subst x e (With a b c) = With a' b c' + where + a' = subst x e a + c' = subst x e c subst x e (Note a b) = Note a b' where b' = subst x e b @@ -884,7 +901,7 @@ Record (Dhall.Map.unionWith decide m n) decide l r = CombineTypes l r - Prefer x y -> decide <$> loop x <*> loop y + Prefer _ x y -> decide <$> loop x <*> loop y where decide (RecordLit m) r | Data.Foldable.null m = r @@ -895,9 +912,9 @@ decide l r | Eval.judgmentallyEqual l r = l decide l r = - Prefer l r + Prefer PreferFromSource l r RecordCompletion x y -> do - loop (Annot (Prefer (Field x "default") y) (Field x "Type")) + loop (Annot (Prefer PreferFromCompletion (Field x "default") y) (Field x "Type")) Merge x y t -> do x' <- loop x y' <- loop y @@ -966,10 +983,10 @@ Just v -> pure v Nothing -> Field <$> (RecordLit <$> traverse loop kvs) <*> pure x Project r_ _ -> loop (Field r_ x) - Prefer (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of - Just v -> pure (Field (Prefer (singletonRecordLit v) r_) x) + Prefer _ (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of + Just v -> pure (Field (Prefer PreferFromSource (singletonRecordLit v) r_) x) Nothing -> loop (Field r_ x) - Prefer l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of + Prefer _ l (RecordLit kvs) -> case Dhall.Map.lookup x kvs of Just v -> pure v Nothing -> loop (Field l x) Combine m (RecordLit kvs) r_ -> case Dhall.Map.lookup x kvs of @@ -987,11 +1004,11 @@ pure (RecordLit (Dhall.Map.restrictKeys kvs fieldsSet)) Project y _ -> loop (Project y (Left fields)) - Prefer l (RecordLit rKvs) -> do + Prefer _ l (RecordLit rKvs) -> do let rKs = Dhall.Map.keysSet rKvs let l' = Project l (Left (Dhall.Set.fromSet (Data.Set.difference fieldsSet rKs))) let r' = RecordLit (Dhall.Map.restrictKeys rKvs fieldsSet) - loop (Prefer l' r') + loop (Prefer PreferFromSource l' r') _ | null fields -> pure (RecordLit mempty) | otherwise -> pure (Project x' (Left (Dhall.Set.sort fields))) Project r (Right e1) -> do @@ -1012,6 +1029,8 @@ r' <- loop r pure (Equivalent l' r') + With e' k v -> do + loop (Syntax.desugarWith (With e' k v)) Note _ e' -> loop e' ImportAlt l _r -> loop l Embed a -> pure (Embed a) @@ -1192,7 +1211,7 @@ decide _ (Record n) | Data.Foldable.null n = False decide (Record _) (Record _) = False decide _ _ = True - Prefer x y -> loop x && loop y && decide x y + Prefer _ x y -> loop x && loop y && decide x y where decide (RecordLit m) _ | Data.Foldable.null m = False decide _ (RecordLit n) | Data.Foldable.null n = False @@ -1213,8 +1232,8 @@ Field r k -> case r of RecordLit _ -> False Project _ _ -> False - Prefer (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r - Prefer _ (RecordLit _) -> False + Prefer _ (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r + Prefer _ _ (RecordLit _) -> False Combine _ (RecordLit m) _ -> Dhall.Map.keys m == [k] && loop r Combine _ _ (RecordLit m) -> Dhall.Map.keys m == [k] && loop r _ -> loop r @@ -1223,13 +1242,14 @@ Left s -> case r of RecordLit _ -> False Project _ _ -> False - Prefer _ (RecordLit _) -> False + Prefer _ _ (RecordLit _) -> False _ -> not (Dhall.Set.null s) && Dhall.Set.isSorted s Right e' -> case e' of Record _ -> False _ -> loop e' Assert t -> loop t Equivalent l r -> loop l && loop r + With{} -> False Note _ e' -> loop e' ImportAlt _ _ -> False Embed _ -> True diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -96,18 +96,17 @@ createHeader = Header . Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n') -{-| Like `exprFromText` but also returns the leading comments and whitespace - (i.e. header) up to the last newline before the code begins - - In other words, if you have a Dhall file of the form: - -> -- Comment 1 -> {- Comment -} 2 - - Then this will preserve @Comment 1@, but not @Comment 2@ - - This is used by @dhall-format@ to preserve leading comments and whitespace --} +-- | Like `exprFromText` but also returns the leading comments and whitespace +-- (i.e. header) up to the last newline before the code begins +-- +-- In other words, if you have a Dhall file of the form: +-- +-- > -- Comment 1 +-- > {- Comment -} 2 +-- +-- Then this will preserve @Comment 1@, but not @Comment 2@ +-- +-- This is used by @dhall-format@ to preserve leading comments and whitespace exprAndHeaderFromText :: String -- ^ User-friendly name describing the input expression, -- used in parsing error messages 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 @@ -11,6 +11,7 @@ import Data.ByteArray.Encoding (Base(..)) import Data.Foldable (foldl') import Data.Functor (void) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Dhall.Syntax @@ -257,7 +258,7 @@ alternative4A <|> alternative4B <|> pure a operatorExpression = - foldr makeOperatorExpression applicationExpression operatorParsers + foldr makeOperatorExpression withExpression operatorParsers makeOperatorExpression operatorParser subExpression = noted (do @@ -277,29 +278,69 @@ 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 Nothing <$ _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 PreferFromSource <$ _prefer <* whitespace + , CombineTypes <$ _combineTypes <* whitespace + , NaturalTimes <$ _times <* whitespace + , BoolEQ <$ _doubleEqual <* whitespace + , BoolNE <$ _notEqual <* whitespace + , Equivalent <$ _equivalent <* whitespace ] + withExpression = noted (do + a <- applicationExpression + + bs <- many (do + try (nonemptyWhitespace *> _with *> nonemptyWhitespace) + + keys <- Combinators.NonEmpty.sepBy1 anyLabel (try (whitespace *> _dot) *> whitespace) + + whitespace + + _equal + + whitespace + + value <- applicationExpression + + return (\e -> With e keys value) ) + + return (foldl (\e f -> f e) a bs) ) + applicationExpression = do - f <- (Some <$ try (_Some <* nonemptyWhitespace)) - <|> return id - a <- noted importExpression_ + let alternative0 = do + _ <- try (_Some <* nonemptyWhitespace) + + return (Some, Just "argument to ❰Some❱") + + let alternative1 = do + _ <- try (_toMap *> nonemptyWhitespace) + + return (\a -> ToMap a Nothing, Just "argument to ❰toMap❱") + + let alternative2 = do + return (id, Nothing) + + (f, maybeMessage) <- alternative0 <|> alternative1 <|> alternative2 + + let adapt parser = + case maybeMessage of + Nothing -> parser + Just message -> parser message + + a <- adapt (noted importExpression_) + bs <- Text.Megaparsec.many . try $ do (sep, _) <- Text.Megaparsec.match nonemptyWhitespace b <- importExpression_ return (sep, b) + return (foldl' app (f a) bs) where app a (sep, b) @@ -359,7 +400,6 @@ , alternative05 , alternative06 , alternative07 - , alternative08 , alternative37 , alternative09 , builtin @@ -411,11 +451,6 @@ b <- importExpression_ "second argument to ❰merge❱" return (Merge a b Nothing) - alternative08 = do - try (_toMap *> nonemptyWhitespace) - a <- importExpression_ - return (ToMap a Nothing) - alternative09 = do a <- try doubleInfinity return (DoubleLit (DhallDouble a)) @@ -730,34 +765,31 @@ let keysValue = do keys <- Combinators.NonEmpty.sepBy1 anyLabel (try (whitespace *> _dot) *> whitespace) - whitespace - - _equal - - whitespace - - value <- expression + let normalRecordEntry = do + try (whitespace *> _equal) - whitespace + whitespace - let cons key (key', values) = - (key, RecordLit [ (key', values) ]) + value <- expression - let nil = (NonEmpty.last keys, value) + whitespace - return (foldr cons nil (NonEmpty.init keys)) + let cons key (key', values) = + (key, RecordLit [ (key', values) ]) - let nonEmptyRecordLiteral = do - (a, b) <- keysValue + let nil = (NonEmpty.last keys, value) - e <- Text.Megaparsec.many (do - _comma + return (foldr cons nil (NonEmpty.init keys)) - whitespace + let punnedEntry = + case keys of + x :| [] -> return (x, Var (V x 0)) + _ -> empty - (c, d) <- keysValue + normalRecordEntry <|> punnedEntry - return (c, d) ) + let nonEmptyRecordLiteral = do + as <- Text.Megaparsec.sepBy1 keysValue (_comma *> whitespace) {- The `flip` is necessary because `toMapWith` is internally based on `Data.Map.fromListWithKey` which combines keys @@ -765,7 +797,7 @@ -} let combine k = liftA2 (flip (Combine (Just k))) - m <- toMapWith combine ((a, b) : e) + m <- toMapWith combine as 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 @@ -105,6 +105,7 @@ _forall, _arrow, _doubleColon, + _with, ) where import Dhall.Parser.Combinators @@ -123,13 +124,16 @@ import qualified Data.Char as Char import qualified Data.Foldable import qualified Data.HashSet +import qualified Data.List as List import qualified Data.List.NonEmpty +import qualified Data.Scientific as Scientific import qualified Data.Text import qualified Dhall.Set import qualified Network.URI.Encode as URI.Encode import qualified Text.Megaparsec import qualified Text.Megaparsec.Char.Lexer import qualified Text.Parser.Char +import qualified Text.Parser.Token import qualified Text.Parser.Combinators import Numeric.Natural (Natural) @@ -189,10 +193,60 @@ -} doubleLiteral :: Parser Double doubleLiteral = (do + -- We don't use `Text.Parser.Token.double` since that consumes trailing + -- whitespace and there is no whitespace-free alternative. See: + -- + -- https://github.com/dhall-lang/dhall-haskell/pull/1646 + -- https://github.com/dhall-lang/dhall-haskell/pull/1647 + -- + -- We also don't use `Text.Megaparsec.Char.Lexer.float` because that + -- transitively depends on `Data.Char.toTitle` which is broken on older + -- versions of GHCJS that we still support. See: + -- + -- https://github.com/dhall-lang/dhall-haskell/pull/1681 + -- https://github.com/ghcjs/ghcjs-base/issues/62 + -- + -- Also, hand-writing the parser code for `Double` literals helps to better + -- ensure that we follow the standard exactly as written. sign <- signPrefix <|> pure id - a <- Text.Megaparsec.Char.Lexer.float - return (sign a) ) "literal" + x <- Text.Parser.Token.decimal + + let alternative0 = do + y <- fraction + + e <- exponent' <|> pure 1 + + return ((fromInteger x + y) * e) + + let alternative1 = do + expo <- exponent' + + return (fromInteger x * expo) + + n <- alternative0 <|> alternative1 + + return (sign (Scientific.toRealFloat n)) ) "literal" + where + fraction = do + _ <- Text.Parser.Char.char '.' + + digits <- some Text.Parser.Char.digit + + let snoc y d = + y + Scientific.scientific (fromIntegral (Char.digitToInt d)) (Scientific.base10Exponent y - 1) + + return (List.foldl' snoc 0 digits) + + exponent' = do + _ <- Text.Parser.Char.oneOf "eE" + + sign <- signPrefix <|> pure id + + x <- Text.Parser.Token.decimal + + return (Scientific.scientific 1 (fromInteger (sign x))) + {-| Parse a signed @Infinity@ This corresponds to the @minus-infinity-literal@ and @plus-infinity-literal@ @@ -775,6 +829,10 @@ -} _assert :: Parser () _assert = keyword "assert" + +-- | Parse the @with@ keyword +_with :: Parser () +_with = keyword "with" {-| Parse the @Some@ 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 @@ -178,24 +178,25 @@ Nothing -> "" Just (c, _, _) -> c + sharedSpacePrefix [] = "" + sharedSpacePrefix (l : ls) = foldl' commonPrefix (spacePrefix l) ls + blank = Text.all horizontalSpace newLines = case oldLines of [] -> [] - l0 : [] -> - Pretty.pretty l0 : [] - l0 : l1 : ls -> + l0 : ls -> let sharedPrefix = - foldl' commonPrefix (spacePrefix l1) (map spacePrefix (filter (not . blank) ls)) + sharedSpacePrefix (filter (not . blank) ls) perLine l = case Text.stripPrefix sharedPrefix l of Nothing -> Pretty.pretty l Just l' -> Pretty.pretty l' - in Pretty.pretty l0 : map perLine (l1 : ls) + in Pretty.pretty l0 : map perLine ls f x y = x <> Pretty.hardline <> y renderSrc _ _ = @@ -438,7 +439,7 @@ prettyAnyLabel :: Text -> Doc Ann prettyAnyLabel = prettyLabelShared True -prettyAnyLabels :: NonEmpty Text -> Doc Ann +prettyAnyLabels :: Foldable list => list Text -> Doc Ann prettyAnyLabels = mconcat . Pretty.punctuate dot . fmap prettyAnyLabel . toList @@ -473,6 +474,12 @@ prettyEnvironmentVariable :: Text -> Doc ann prettyEnvironmentVariable t = Pretty.pretty (escapeEnvironmentVariable t) +preserveSource :: Expr Src a -> Maybe (Doc Ann) +preserveSource (Note Src{..} (DoubleLit {})) = Just (Pretty.pretty srcText) +preserveSource (Note Src{..} (IntegerLit {})) = Just (Pretty.pretty srcText) +preserveSource (Note Src{..} (NaturalLit {})) = Just (Pretty.pretty srcText) +preserveSource _ = Nothing + -- | Escape an environment variable if not a valid Bash environment variable escapeEnvironmentVariable :: Text -> Text escapeEnvironmentVariable t @@ -534,8 +541,13 @@ <> (space <> colon <> space) <> prettyExpression b <> rparen - docs (Note _ c) = docs c - docs c = [ prettyExpression c ] + docs c + | Just doc <- preserveSource c = + [ doc ] + | Note _ d <- c = + docs d + | otherwise = + [ prettyExpression c ] prettyExpression a0@(BoolIf _ _ _) = Pretty.group (Pretty.flatAlt long short) where @@ -567,8 +579,13 @@ [ keyword "if" <> " " <> prettyExpression a , prettyExpression b ] - docsLong (Note _ c) = docsLong c - docsLong c = [ prettyExpression c ] + docsLong c + | Just doc <- preserveSource c = + [ doc ] + | Note _ d <- c = + docsLong d + | otherwise = + [ prettyExpression c ] docsShort (BoolIf a b c) = docShort ++ docsShort c @@ -577,8 +594,13 @@ [ keyword "if" <> " " <> prettyExpression a , prettyExpression b ] - docsShort (Note _ c) = docsShort c - docsShort c = [ prettyExpression c ] + docsShort c + | Just doc <- preserveSource c = + [ doc ] + | Note _ d <- c = + docsShort d + | otherwise = + [ prettyExpression c ] prettyExpression (Let a0 b0) = enclose' "" "" space Pretty.hardline (fmap duplicate (fmap docA (toList as)) ++ [ docB ]) @@ -646,8 +668,13 @@ <> space <> colon <> space <> prettyExpression b <> rparen - docs (Note _ c) = docs c - docs c = [ prettyExpression c ] + docs c + | Just doc <- preserveSource c = + [ doc ] + | Note _ d <- c = + docs d + | otherwise = + [ prettyExpression c ] prettyExpression (Assert a) = Pretty.group (Pretty.flatAlt long short) where @@ -658,10 +685,13 @@ ( " " <> keyword "assert" <> Pretty.hardline <> colon <> " " <> prettyExpression a ) - prettyExpression (Note _ a) = - prettyExpression a - prettyExpression a0 = - prettyAnnotatedExpression a0 + prettyExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyExpression b + | otherwise = + prettyAnnotatedExpression a prettyAnnotatedExpression :: Pretty a => Expr Src a -> Doc Ann prettyAnnotatedExpression (Merge a b (Just c)) = @@ -711,16 +741,24 @@ (fmap duplicate (docs a0)) where docs (Annot a b) = prettyOperatorExpression a : docs b - docs (Note _ b) = docs b - docs b = [ prettyExpression b ] + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyExpression a ] prettyAnnotatedExpression (ListLit (Just a) b) = list (map prettyExpression (Data.Foldable.toList b)) <> " : " <> prettyApplicationExpression a - prettyAnnotatedExpression (Note _ a) = - prettyAnnotatedExpression a - prettyAnnotatedExpression a0 = - prettyOperatorExpression a0 + prettyAnnotatedExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyAnnotatedExpression b + | otherwise = + prettyOperatorExpression a prettyOperatorExpression :: Pretty a => Expr Src a -> Doc Ann prettyOperatorExpression = prettyImportAltExpression @@ -743,157 +781,281 @@ prettyOperator "?" (docs a0) where docs (ImportAlt a b) = prettyOrExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyOrExpression b ] - prettyImportAltExpression (Note _ a) = - prettyImportAltExpression a - prettyImportAltExpression a0 = - prettyOrExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyOrExpression a ] + prettyImportAltExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyImportAltExpression b + | otherwise = + prettyOrExpression a prettyOrExpression :: Pretty a => Expr Src a -> Doc Ann prettyOrExpression a0@(BoolOr _ _) = prettyOperator "||" (docs a0) where docs (BoolOr a b) = prettyPlusExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyPlusExpression b ] - prettyOrExpression (Note _ a) = - prettyOrExpression a - prettyOrExpression a0 = - prettyPlusExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyPlusExpression a ] + prettyOrExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyOrExpression b + | otherwise = + prettyPlusExpression a prettyPlusExpression :: Pretty a => Expr Src a -> Doc Ann prettyPlusExpression a0@(NaturalPlus _ _) = prettyOperator "+" (docs a0) where docs (NaturalPlus a b) = prettyTextAppendExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyTextAppendExpression b ] - prettyPlusExpression (Note _ a) = - prettyPlusExpression a - prettyPlusExpression a0 = - prettyTextAppendExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyTextAppendExpression a ] + prettyPlusExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyPlusExpression b + | otherwise = + prettyTextAppendExpression a prettyTextAppendExpression :: Pretty a => Expr Src a -> Doc Ann prettyTextAppendExpression a0@(TextAppend _ _) = prettyOperator "++" (docs a0) where docs (TextAppend a b) = prettyListAppendExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyListAppendExpression b ] - prettyTextAppendExpression (Note _ a) = - prettyTextAppendExpression a - prettyTextAppendExpression a0 = - prettyListAppendExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyListAppendExpression a ] + prettyTextAppendExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyTextAppendExpression b + | otherwise = + prettyListAppendExpression a prettyListAppendExpression :: Pretty a => Expr Src a -> Doc Ann prettyListAppendExpression a0@(ListAppend _ _) = prettyOperator "#" (docs a0) where docs (ListAppend a b) = prettyAndExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyAndExpression b ] - prettyListAppendExpression (Note _ a) = - prettyListAppendExpression a - prettyListAppendExpression a0 = - prettyAndExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyAndExpression a ] + prettyListAppendExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyListAppendExpression b + | otherwise = + prettyAndExpression a prettyAndExpression :: Pretty a => Expr Src a -> Doc Ann prettyAndExpression a0@(BoolAnd _ _) = prettyOperator "&&" (docs a0) where docs (BoolAnd a b) = prettyCombineExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyCombineExpression b ] - prettyAndExpression (Note _ a) = - prettyAndExpression a - prettyAndExpression a0 = - prettyCombineExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyCombineExpression a ] + prettyAndExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyAndExpression b + | otherwise = + prettyCombineExpression a prettyCombineExpression :: Pretty a => Expr Src a -> Doc Ann 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 ] - prettyCombineExpression (Note _ a) = - prettyCombineExpression a - prettyCombineExpression a0 = - prettyPreferExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyPreferExpression a ] + prettyCombineExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyCombineExpression b + | otherwise = + prettyPreferExpression a prettyPreferExpression :: Pretty a => Expr Src a -> Doc Ann - prettyPreferExpression a0@(Prefer _ _) = + prettyPreferExpression a0@(Prefer {}) = prettyOperator (prefer characterSet) (docs a0) where - docs (Prefer a b) = prettyCombineTypesExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyCombineTypesExpression b ] - prettyPreferExpression (Note _ a) = - prettyPreferExpression a - prettyPreferExpression a0 = - prettyCombineTypesExpression a0 + docs (Prefer _ a b) = prettyCombineTypesExpression b : docs a + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyCombineTypesExpression a ] + prettyPreferExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyPreferExpression b + | otherwise = + prettyCombineTypesExpression a prettyCombineTypesExpression :: Pretty a => Expr Src a -> Doc Ann prettyCombineTypesExpression a0@(CombineTypes _ _) = prettyOperator (combineTypes characterSet) (docs a0) where docs (CombineTypes a b) = prettyTimesExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyTimesExpression b ] - prettyCombineTypesExpression (Note _ a) = - prettyCombineTypesExpression a - prettyCombineTypesExpression a0 = - prettyTimesExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyTimesExpression a ] + prettyCombineTypesExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyCombineTypesExpression b + | otherwise = + prettyTimesExpression a prettyTimesExpression :: Pretty a => Expr Src a -> Doc Ann prettyTimesExpression a0@(NaturalTimes _ _) = prettyOperator "*" (docs a0) where docs (NaturalTimes a b) = prettyEqualExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyEqualExpression b ] - prettyTimesExpression (Note _ a) = - prettyTimesExpression a - prettyTimesExpression a0 = - prettyEqualExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyEqualExpression a ] + prettyTimesExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyTimesExpression b + | otherwise = + prettyEqualExpression a prettyEqualExpression :: Pretty a => Expr Src a -> Doc Ann prettyEqualExpression a0@(BoolEQ _ _) = prettyOperator "==" (docs a0) where docs (BoolEQ a b) = prettyNotEqualExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyNotEqualExpression b ] - prettyEqualExpression (Note _ a) = - prettyEqualExpression a - prettyEqualExpression a0 = - prettyNotEqualExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyNotEqualExpression a ] + prettyEqualExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyEqualExpression b + | otherwise = + prettyNotEqualExpression a prettyNotEqualExpression :: Pretty a => Expr Src a -> Doc Ann prettyNotEqualExpression a0@(BoolNE _ _) = prettyOperator "!=" (docs a0) where docs (BoolNE a b) = prettyEquivalentExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyEquivalentExpression b ] - prettyNotEqualExpression (Note _ a) = - prettyNotEqualExpression a - prettyNotEqualExpression a0 = - prettyEquivalentExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyEquivalentExpression a ] + prettyNotEqualExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyNotEqualExpression b + | otherwise = + prettyEquivalentExpression a prettyEquivalentExpression :: Pretty a => Expr Src a -> Doc Ann prettyEquivalentExpression a0@(Equivalent _ _) = prettyOperator (equivalent characterSet) (docs a0) where docs (Equivalent a b) = prettyApplicationExpression b : docs a - docs (Note _ b) = docs b - docs b = [ prettyApplicationExpression b ] - prettyEquivalentExpression (Note _ a) = - prettyEquivalentExpression a - prettyEquivalentExpression a0 = - prettyApplicationExpression a0 + docs a + | Just doc <- preserveSource a = + [ doc ] + | Note _ b <- a = + docs b + | otherwise = + [ prettyApplicationExpression a ] + prettyEquivalentExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyEquivalentExpression b + | otherwise = + prettyWithExpression a + prettyWithExpression :: Pretty a => Expr Src a -> Doc Ann + prettyWithExpression (With a b c) = + prettyWithExpression a + <> Pretty.flatAlt long short + where + short = " " <> keyword "with" <> " " <> update + + long = Pretty.hardline + <> " " + <> Pretty.align (keyword "with" <> " " <> update) + + (update, _ ) = prettyKeyValue prettyAnyLabels equals (b, c) + prettyWithExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyWithExpression b + | otherwise = + prettyApplicationExpression a + prettyApplicationExpression :: Pretty a => Expr Src a -> Doc Ann prettyApplicationExpression = go [] where @@ -902,9 +1064,14 @@ Some a -> app (builtin "Some") (a : args) Merge a b Nothing -> app (keyword "merge") (a : b : args) ToMap a Nothing -> app (keyword "toMap") (a : args) - Note _ b -> go args b - e | null args -> prettyImportExpression e -- just a performance optimization - | otherwise -> app (prettyImportExpression e) args + e | Note _ b <- e -> + go args b + | null args -> + prettyImportExpression e -- just a performance optimization + | Just doc <- preserveSource e -> + app doc args + | otherwise -> + app (prettyImportExpression e) args app f args = enclose' @@ -916,10 +1083,13 @@ prettyImportExpression :: Pretty a => Expr Src a -> Doc Ann prettyImportExpression (Embed a) = Pretty.pretty a - prettyImportExpression (Note _ a) = - prettyImportExpression a - prettyImportExpression a0 = - prettyCompletionExpression a0 + prettyImportExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyImportExpression b + | otherwise = + prettyCompletionExpression a prettyCompletionExpression :: Pretty a => Expr Src a -> Doc Ann prettyCompletionExpression (RecordCompletion a b) = @@ -933,11 +1103,13 @@ _ -> prettySelectorExpression a <> doubleColon <> prettySelectorExpression b - - prettyCompletionExpression (Note _ a) = - prettyCompletionExpression a - prettyCompletionExpression a0 = - prettySelectorExpression a0 + prettyCompletionExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyCompletionExpression b + | otherwise = + prettySelectorExpression a prettySelectorExpression :: Pretty a => Expr Src a -> Doc Ann prettySelectorExpression (Field a b) = @@ -950,10 +1122,13 @@ <> lparen <> prettyExpression b <> rparen - prettySelectorExpression (Note _ b) = - prettySelectorExpression b - prettySelectorExpression a0 = - prettyPrimitiveExpression a0 + prettySelectorExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettySelectorExpression b + | otherwise = + prettyPrimitiveExpression a prettyPrimitiveExpression :: Pretty a => Expr Src a -> Doc Ann prettyPrimitiveExpression (Var a) = @@ -1043,10 +1218,13 @@ prettyUnion a prettyPrimitiveExpression (ListLit Nothing b) = list (map prettyExpression (Data.Foldable.toList b)) - prettyPrimitiveExpression (Note _ b) = - prettyPrimitiveExpression b - prettyPrimitiveExpression a = - Pretty.group (Pretty.flatAlt long short) + prettyPrimitiveExpression a + | Just doc <- preserveSource a = + doc + | Note _ b <- a = + prettyPrimitiveExpression b + | otherwise = + Pretty.group (Pretty.flatAlt long short) where long = Pretty.align @@ -1055,7 +1233,11 @@ short = lparen <> prettyExpression a <> rparen prettyKeyValue - :: Pretty a => (k -> Doc Ann) -> Doc Ann -> (k, Expr Src a) -> (Doc Ann, Doc Ann) + :: 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 @@ -1085,14 +1267,22 @@ <> case shallowDenote val' of RecordCompletion _T r -> completion _T r + + RecordLit _ -> + Pretty.hardline + <> " " + <> prettyImportExpression val' + ListLit _ xs | not (null xs) -> Pretty.hardline <> " " <> prettyExpression val' + _ -> Pretty.hardline <> " " <> prettyImportExpression val' + ToMap val' Nothing -> " " <> keyword "toMap" <> case shallowDenote val' of @@ -1101,13 +1291,21 @@ _ -> Pretty.hardline <> " " <> prettyImportExpression val' + RecordCompletion _T r -> completion _T r + + RecordLit _ -> + Pretty.hardline + <> " " + <> prettyExpression val + ListLit _ xs | not (null xs) -> Pretty.hardline <> " " <> prettyExpression val + _ -> Pretty.hardline <> " " diff --git a/src/Dhall/Syntax.hs b/src/Dhall/Syntax.hs --- a/src/Dhall/Syntax.hs +++ b/src/Dhall/Syntax.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -25,6 +26,7 @@ , makeBinding , Chunks(..) , DhallDouble(..) + , PreferAnnotation(..) , Expr(..) -- ** 'Let'-blocks @@ -62,6 +64,9 @@ , longestSharedWhitespacePrefix , linesLiteral , unlinesLiteral + + -- * Desugaring + , desugarWith ) where import Control.DeepSeq (NFData) @@ -91,10 +96,11 @@ import qualified Control.Monad import qualified Data.HashSet -import qualified Data.List.NonEmpty +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Dhall.Crypto +import qualified Dhall.Optics as Optics import qualified Language.Haskell.TH.Syntax as Syntax import qualified Network.URI as URI @@ -260,6 +266,22 @@ instance IsString (Chunks s a) where fromString str = Chunks [] (fromString str) +-- | Used to record the origin of a @//@ operator (i.e. from source code or a +-- product of desugaring) +data PreferAnnotation s a + = PreferFromSource + | PreferFromWith (Expr s a) + -- ^ Stores the original @with@ expression + | PreferFromCompletion + deriving (Data, Eq, Foldable, Functor, Generic, NFData, Ord, Show, Traversable) + +instance Bifunctor PreferAnnotation where + first _ PreferFromSource = PreferFromSource + first f (PreferFromWith e ) = PreferFromWith (first f e) + first _ PreferFromCompletion = PreferFromCompletion + + second = fmap + {-| Syntax tree for expressions The @s@ type parameter is used to track the presence or absence of `Src` @@ -348,9 +370,9 @@ | Integer -- | > IntegerLit n ~ ±n | IntegerLit Integer - -- | IntegerClamp ~ Integer/clamp + -- | > IntegerClamp ~ Integer/clamp | IntegerClamp - -- | IntegerNegate ~ Integer/negate + -- | > IntegerNegate ~ Integer/negate | IntegerNegate -- | > IntegerShow ~ Integer/show | IntegerShow @@ -428,8 +450,11 @@ | 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 - | Prefer (Expr s a) (Expr s a) + -- | > Prefer False x y ~ x ⫽ y + -- + -- The first field is a `True` when the `Prefer` operator is introduced as a + -- result of desugaring a @with@ expression + | Prefer (PreferAnnotation s a) (Expr s a) (Expr s a) -- | > RecordCompletion x y ~ x::y | RecordCompletion (Expr s a) (Expr s a) -- | > Merge x y (Just t ) ~ merge x y : t @@ -441,12 +466,14 @@ -- | > Field e x ~ e.x | Field (Expr s a) Text -- | > Project e (Left xs) ~ e.{ xs } - -- | > Project e (Right t) ~ e.(t) + -- > Project e (Right t) ~ e.(t) | Project (Expr s a) (Either (Set Text) (Expr s a)) -- | > Assert e ~ assert : e | Assert (Expr s a) -- | > Equivalent x y ~ x ≡ y | Equivalent (Expr s a) (Expr s a) + -- | > With x y ~ x with y + | With (Expr s a) (NonEmpty Text) (Expr s a) -- | > Note s x ~ e | Note s (Expr s a) -- | > ImportAlt ~ e1 ? e2 @@ -537,7 +564,7 @@ fmap f (Union u) = Union (fmap (fmap (fmap f)) u) 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 (Prefer a e1 e2) = Prefer (fmap f a) (fmap f e1) (fmap f e2) fmap f (RecordCompletion e1 e2) = RecordCompletion (fmap f e1) (fmap f e2) fmap f (Merge e1 e2 maybeE) = Merge (fmap f e1) (fmap f e2) (fmap (fmap f) maybeE) fmap f (ToMap e maybeE) = ToMap (fmap f e) (fmap (fmap f) maybeE) @@ -545,6 +572,7 @@ fmap f (Project e1 vs) = Project (fmap f e1) (fmap (fmap f) vs) fmap f (Assert t) = Assert (fmap f t) fmap f (Equivalent e1 e2) = Equivalent (fmap f e1) (fmap f e2) + fmap f (With e k v) = With (fmap f e) k (fmap f v) fmap f (Note s e1) = Note s (fmap f e1) fmap f (ImportAlt e1 e2) = ImportAlt (fmap f e1) (fmap f e2) fmap f (Embed a) = Embed (f a) @@ -622,7 +650,12 @@ Union a >>= k = Union (fmap (fmap (>>= k)) a) 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) + Prefer a b c >>= k = Prefer a' (b >>= k) (c >>= k) + where + a' = case a of + PreferFromSource -> PreferFromSource + PreferFromWith e -> PreferFromWith (e >>= k) + PreferFromCompletion -> PreferFromCompletion RecordCompletion a b >>= k = RecordCompletion (a >>= k) (b >>= k) Merge a b c >>= k = Merge (a >>= k) (b >>= k) (fmap (>>= k) c) ToMap a b >>= k = ToMap (a >>= k) (fmap (>>= k) b) @@ -630,6 +663,7 @@ Project a b >>= k = Project (a >>= k) (fmap (>>= k) b) Assert a >>= k = Assert (a >>= k) Equivalent a b >>= k = Equivalent (a >>= k) (b >>= k) + With a b c >>= k = With (a >>= k) b (c >>= k) Note a b >>= k = Note a (b >>= k) ImportAlt a b >>= k = ImportAlt (a >>= k) (b >>= k) Embed a >>= k = k a @@ -694,7 +728,7 @@ first k (Union a ) = Union (fmap (fmap (first k)) a) 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 (Prefer a b c ) = Prefer (first k a) (first k b) (first k c) first k (RecordCompletion a b) = RecordCompletion (first k a) (first k b) first k (Merge a b c ) = Merge (first k a) (first k b) (fmap (first k) c) first k (ToMap a b ) = ToMap (first k a) (fmap (first k) b) @@ -702,6 +736,7 @@ first k (Assert a ) = Assert (first k a) first k (Equivalent a b ) = Equivalent (first k a) (first k b) first k (Project a b ) = Project (first k a) (fmap (first k) b) + first k (With a b c ) = With (first k a) b (first k c) first k (Note a b ) = Note (k a) (first k b) first k (ImportAlt a b ) = ImportAlt (first k a) (first k b) first _ (Embed a ) = Embed a @@ -746,7 +781,7 @@ multiLet b0 = \case Let b1 e1 -> let MultiLet bs e = multiLet b1 e1 - in MultiLet (Data.List.NonEmpty.cons b0 bs) e + in MultiLet (NonEmpty.cons b0 bs) e e -> MultiLet (b0 :| []) e {-| Wrap let-'Binding's around an 'Expr'. @@ -827,7 +862,7 @@ subExpressions f (Union a) = Union <$> traverse (traverse f) a 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 (Prefer a b c) = Prefer <$> pure a <*> f b <*> f c subExpressions f (RecordCompletion a b) = RecordCompletion <$> f a <*> f b subExpressions f (Merge a b t) = Merge <$> f a <*> f b <*> traverse f t subExpressions f (ToMap a t) = ToMap <$> f a <*> traverse f t @@ -835,6 +870,7 @@ subExpressions f (Project a b) = Project <$> f a <*> traverse f b subExpressions f (Assert a) = Assert <$> f a subExpressions f (Equivalent a b) = Equivalent <$> f a <*> f b +subExpressions f (With a b c) = With <$> f a <*> pure b <*> f c subExpressions f (Note a b) = Note a <$> f b subExpressions f (ImportAlt l r) = ImportAlt <$> f l <*> f r subExpressions _ (Embed a) = pure (Embed a) @@ -1133,7 +1169,12 @@ denote (Union a ) = Union (fmap (fmap denote) a) 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 (Prefer a b c ) = Prefer a' (denote b) (denote c) + where + a' = case a of + PreferFromSource -> PreferFromSource + PreferFromWith e -> PreferFromWith (denote e) + PreferFromCompletion -> PreferFromCompletion denote (RecordCompletion a b) = RecordCompletion (denote a) (denote b) denote (Merge a b c ) = Merge (denote a) (denote b) (fmap denote c) denote (ToMap a b ) = ToMap (denote a) (fmap denote b) @@ -1141,6 +1182,7 @@ denote (Project a b ) = Project (denote a) (fmap denote b) denote (Assert a ) = Assert (denote a) denote (Equivalent a b ) = Equivalent (denote a) (denote b) +denote (With a b c ) = With (denote a) b (denote c) denote (ImportAlt a b ) = ImportAlt (denote a) (denote b) denote (Embed a ) = Embed a @@ -1178,6 +1220,7 @@ , "toMap" , "assert" , "forall" + , "with" -- Builtins according to the `builtin` rule in the grammar , "Natural/fold" @@ -1234,21 +1277,21 @@ fmap (Chunks []) (splitOn "\n" suffix) linesLiteral (Chunks ((prefix, interpolation) : pairs₀) suffix₀) = foldr - Data.List.NonEmpty.cons + NonEmpty.cons (Chunks ((lastLine, interpolation) : pairs₁) suffix₁ :| chunks) (fmap (Chunks []) initLines) where splitLines = splitOn "\n" prefix - initLines = Data.List.NonEmpty.init splitLines - lastLine = Data.List.NonEmpty.last splitLines + initLines = NonEmpty.init splitLines + lastLine = NonEmpty.last splitLines Chunks pairs₁ suffix₁ :| chunks = linesLiteral (Chunks pairs₀ suffix₀) -- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a unlinesLiteral chunks = - Data.Foldable.fold (Data.List.NonEmpty.intersperse "\n" chunks) + Data.Foldable.fold (NonEmpty.intersperse "\n" chunks) -- | Returns `True` if the `Chunks` represents a blank line emptyLine :: Chunks s a -> Bool @@ -1285,9 +1328,9 @@ -- for the last line filteredLines = newInit <> pure oldLast where - oldInit = Data.List.NonEmpty.init literals + oldInit = NonEmpty.init literals - oldLast = Data.List.NonEmpty.last literals + oldLast = NonEmpty.last literals newInit = filter (not . emptyLine) oldInit @@ -1310,3 +1353,18 @@ longestSharedPrefix = longestSharedWhitespacePrefix literals indent = Data.Text.length longestSharedPrefix + +-- | Desugar all @with@ expressions +desugarWith :: Expr s a -> Expr s a +desugarWith = Optics.rewriteOf subExpressions rewrite + where + rewrite e@(With record (key :| []) value) = + Just (Prefer (PreferFromWith e) record (RecordLit [ (key, value) ])) + rewrite e@(With record (key0 :| key1 : keys) value) = + Just + (Prefer (PreferFromWith e) record + (RecordLit + [ (key0, With (Field record key0) (key1 :| keys) value) ] + ) + ) + rewrite _ = Nothing diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs --- a/src/Dhall/TH.hs +++ b/src/Dhall/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -17,6 +18,8 @@ import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty) import Dhall.Syntax (Expr(..)) +import Dhall (FromDhall, ToDhall) +import GHC.Generics (Generic) import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility. import Language.Haskell.TH.Syntax @@ -28,6 +31,12 @@ , Bang(..) , SourceStrictness(..) , SourceUnpackedness(..) +#if MIN_VERSION_template_haskell(2,12,0) + , DerivClause(..) + , DerivStrategy(..) +#else + , Pred +#endif ) import qualified Data.List as List @@ -140,8 +149,8 @@ , "• ❰Integer❱ \n" , "• ❰Natural❱ \n" , "• ❰Text❱ \n" - , "• ❰List a❱ (where ❰a❱ is also a simple type) \n" - , "• ❰Optional a❱ (where ❰a❱ is also a simple type) \n" + , "• ❰List a❱ (where ❰a❱ is also a valid nested type) \n" + , "• ❰Optional a❱ (where ❰a❱ is also a valid nested type) \n" , "• Another matching datatype declaration \n" , " \n" , "The Haskell datatype generation logic encountered the following Dhall type: \n" @@ -158,6 +167,17 @@ predicate haskellType = Core.judgmentallyEqual (code haskellType) dhallType +#if MIN_VERSION_template_haskell(2,12,0) +derivingClauses :: [DerivClause] +derivingClauses = + [ DerivClause (Just StockStrategy) [ ConT ''Generic ] + , DerivClause (Just AnyclassStrategy) [ ConT ''FromDhall, ConT ''ToDhall ] + ] +#else +derivingClauses :: [Pred] +derivingClauses = [ ConT ''Generic, ConT ''FromDhall, ConT ''ToDhall ] +#endif + -- | Convert a Dhall type to the corresponding Haskell datatype declaration toDeclaration :: (Eq a, Pretty a) @@ -171,7 +191,7 @@ constructors <- traverse (toConstructor haskellTypes) (Dhall.Map.toList kts ) - return (DataD [] name [] Nothing constructors []) + return (DataD [] name [] Nothing constructors derivingClauses) _ -> do let document = @@ -220,7 +240,7 @@ constructor <- toConstructor haskellTypes (constructorName, Just code) - return (DataD [] name [] Nothing [constructor] []) + return (DataD [] name [] Nothing [constructor] derivingClauses) -- | Convert a Dhall type to the corresponding Haskell constructor toConstructor @@ -318,6 +338,12 @@ -- -- ... this Template Haskell splice: -- +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE DerivingStrategies #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > -- > Dhall.TH.makeHaskellTypes -- > [ MultipleConstructors "Department" "./tests/th/Department.dhall" -- > , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall" @@ -326,21 +352,34 @@ -- ... generates this Haskell code: -- -- > data Department = Engineering | Marketing | Sales +-- > deriving stock (GHC.Generics.Generic) +-- > deriving anyclass (Dhall.FromDhall, Dhall.ToDhall) -- > -- > data Employee -- > = MakeEmployee {department :: Department, -- > name :: Data.Text.Internal.Text} +-- > deriving stock (GHC.Generics.Generic) +-- > deriving anyclass (Dhall.FromDhall, Dhall.ToDhall) -- -- 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: +-- This Template Haskell splice requires you to enable the following extensions: -- +-- * @DeriveGeneric@ +-- * @DerivingAnyClass@ +-- * @DerivingStrategies@ +-- +-- By default, the generated types only derive `GHC.Generics.Generic`, +-- `Dhall.FromDhall`, and `Dhall.ToDhall`. To add any desired instances (such +-- as `Eq`\/`Ord`\/`Show`), you can use the `StandaloneDeriving` language +-- extension, like this: +-- -- > {-# LANGUAGE DeriveAnyClass #-} -- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE DerivingStrategies #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE StandaloneDeriving #-} -- > {-# LANGUAGE TemplateHaskell #-} @@ -350,11 +389,13 @@ -- > , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall" -- > ] -- > --- > deriving instance Generic Department --- > deriving instance FromDhall Department +-- > deriving instance Eq Department +-- > deriving instance Ord Department +-- > deriving instance Show Department -- > --- > deriving instance Generic Employee --- > deriving instance FromDhall Employee +-- > deriving instance Eq Employee +-- > deriving instance Ord Employee +-- > deriving instance Show Employee makeHaskellTypes :: [HaskellType Text] -> Q [Dec] makeHaskellTypes haskellTypes = do Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -544,8 +544,16 @@ -- > } -- > } -- --- You can access a field of a record using the following syntax: +-- You can specify nested fields using dot-separated keys, like this: -- +-- > { foo = 1, bar.baz = 2.0, bar.qux = True } +-- +-- ... which is equivalent to: +-- +-- > { foo = 1, bar = { baz = 2.0, qux = True } } +-- +-- You can also access a field of a record using the following syntax: +-- -- > record.fieldName -- -- ... which means to access the value of the field named @fieldName@ from the @@ -827,6 +835,24 @@ -- -- Note that the order of record fields does not matter. The compiler -- automatically sorts the fields. +-- +-- If you need to set or add a deeply nested field you can use the @with@ +-- keyword, like this: +-- +-- > $ dhall <<< '{ x.y = 1 } with x.z = True' +-- > { x = { y = 1, z = True } } +-- +-- > $ dhall <<< '{ x.y = 1 } with x.y = 2' +-- > { x.y = 2 } +-- +-- The @with@ keyword is syntactic sugar for the @//@ operator which follows +-- these rules: +-- +-- > -- Nested case +-- > record with k.ks… = value ⇒ record // { k = record.k with ks… = value } +-- > +-- > -- Base case +-- > record with k = value ⇒ record // { k = value } -- -- The @(/\\)@ operator (or @(∧)@ U+2227) also lets you combine records, but -- behaves differently if the records share fields in common. The operator diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -41,13 +41,20 @@ import Data.Typeable (Typeable) import Data.Void (Void, absurd) import Dhall.Context (Context) -import Dhall.Syntax (Binding(..), Const(..), Chunks(..), Expr(..), Var(..)) -import Dhall.Eval - (Environment(..), Names(..), Val(..), (~>)) +import Dhall.Eval (Environment(..), Names(..), Val(..), (~>)) import Dhall.Pretty (Ann) import Dhall.Src (Src) import Lens.Family (over) +import Dhall.Syntax + ( Binding(..) + , Const(..) + , Chunks(..) + , Expr(..) + , PreferAnnotation(..) + , Var(..) + ) + import qualified Data.Foldable import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map @@ -62,9 +69,10 @@ import qualified Dhall.Diff import qualified Dhall.Eval as Eval import qualified Dhall.Map -import qualified Dhall.Set import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal +import qualified Dhall.Set +import qualified Dhall.Syntax as Syntax import qualified Dhall.Util import qualified Lens.Family @@ -298,7 +306,7 @@ else do let _A₀'' = quote names _A₀' let _A₁'' = quote names _A₁' - die (AnnotMismatch a₀ _A₀'' _A₁'') + Left (TypeError context a₀ (AnnotMismatch a₀ _A₀'' _A₁'')) return (addTypeValue x _A₀' a₀' ctx) @@ -600,8 +608,6 @@ -- to just the offending element let err = MismatchedListElements (i+1) _T₀'' t₁ _T₁'' - let context = ctxToContext ctx - Left (TypeError context t₁ err) traverseWithIndex_ process ts₁ @@ -808,6 +814,12 @@ Combine mk l r -> do _L' <- loop ctx l + let l'' = quote names (eval values l) + + _R' <- loop ctx r + + let r'' = quote names (eval values l) + xLs' <- case _L' of VRecord xLs' -> do return xLs' @@ -816,11 +828,9 @@ let _L'' = quote names _L' case mk of - Nothing -> die (MustCombineARecord '∧' l _L'') + Nothing -> die (MustCombineARecord '∧' l'' _L'') Just t -> die (InvalidDuplicateField t l _L'') - _R' <- loop ctx r - xRs' <- case _R' of VRecord xRs' -> do return xRs' @@ -829,7 +839,7 @@ let _R'' = quote names _R' case mk of - Nothing -> die (MustCombineARecord '∧' r _R'') + Nothing -> die (MustCombineARecord '∧' r'' _R'') Just t -> die (InvalidDuplicateField t r _R'') let combineTypes xs xLs₀' xRs₀' = do @@ -897,19 +907,35 @@ return (VConst c) - Prefer l r -> do + Prefer a l r -> do _L' <- loop ctx l + _R' <- loop ctx r + xLs' <- case _L' of VRecord xLs' -> return xLs' - _ -> die (MustCombineARecord '⫽' l r) - _R' <- loop ctx r + _ -> do + let _L'' = quote names _L' + let l'' = quote names (eval values l) + + case a of + PreferFromWith withExpression -> + die (MustUpdateARecord withExpression l'' _L'') + _ -> + die (MustCombineARecord '⫽' l'' _L'') + xRs' <- case _R' of VRecord xRs' -> return xRs' - _ -> die (MustCombineARecord '⫽' l r) + _ -> do + let _R'' = quote names _R' + + let r'' = quote names (eval values r) + + die (MustCombineARecord '⫽' r'' _R'') + return (VRecord (Dhall.Map.union xRs' xLs')) RecordCompletion l r -> do @@ -922,7 +948,7 @@ | not (Dhall.Map.member "Type" xLs') -> die (InvalidRecordCompletion "Type" l) | otherwise - -> loop ctx (Annot (Prefer (Field l "default") r) (Field l "Type")) + -> loop ctx (Annot (Prefer PreferFromCompletion (Field l "default") r) (Field l "Type")) _ -> die (CompletionSchemaMustBeARecord l (quote names _L')) Merge t u mT₁ -> do @@ -1261,6 +1287,9 @@ return (VConst Type) + e@With{} -> do + loop ctx (Syntax.desugarWith e) + Note s e -> case loop ctx e of Left (TypeError ctx' (Note s' e') m) -> @@ -1277,9 +1306,9 @@ return (eval values (typer p)) where die err = Left (TypeError context expression err) - where - context = ctxToContext ctx + context = ctxToContext ctx + names = typesToNames types eval vs e = Eval.eval vs (Dhall.Core.denote e) @@ -1315,6 +1344,7 @@ | InvalidAlternativeType Text (Expr s a) | AlternativeAnnotationMismatch Text (Expr s a) Const Text (Expr s a) Const | ListAppendMismatch (Expr s a) (Expr s a) + | MustUpdateARecord (Expr s a) (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) @@ -2763,14 +2793,68 @@ txt0 = insert expr0 txt1 = pretty fieldName -prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..} +prettyTypeMessage (MustUpdateARecord withExpression expression typeExpression) = + ErrorMessages {..} where - short = "You can only combine records" + short = "You can only update records" long = - "Explanation: You can combine records using the ❰" <> op <> "❱ operator, like this:\n\ + "Explanation: You can update records using the ❰with❱ keyword, like this: \n\ \ \n\ \ \n\ + \ ┌────────────────────────────────┐ \n\ + \ │ { x = { y = 1 } } with x.y = 2 │ \n\ + \ └────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \ ┌────────────────────────────────────────────────────────────┐ \n\ + \ │ λ(r : { foo : { bar : Bool } }) → r with foo.bar = False } │ \n\ + \ └────────────────────────────────────────────────────────────┘ \n\ + \ \n\ + \ \n\ + \... but you cannot update values that are not records. \n\ + \ \n\ + \For example, the following expression is " <> _NOT <> " valid: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────┐ \n\ + \ │ 1 with x = True │ \n\ + \ └─────────────────┘ \n\ + \ ⇧ \n\ + \ Invalid: Not a record \n\ + \ \n\ + \ \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ + \ \n\ + \The following expression is not permitted: \n\ + \ \n\ + \" <> insert withExpression' <> "\n\ + \ \n\ + \... because the left argument to ❰with❱: \n\ + \ \n\ + \" <> insert expression <> "\n\ + \ \n\ + \... is not a record, but is actually a: \n\ + \ \n\ + \" <> insert typeExpression <> "\n" + where + withExpression' = case withExpression of + With record keys value -> With (Dhall.Core.normalize record) keys value + _ -> withExpression + +prettyTypeMessage (MustCombineARecord c expression typeExpression) = + ErrorMessages {..} + where + action = case c of + '∧' -> "combine" + _ -> "override" + + short = "You can only " <> action <> " records" + + long = + "Explanation: You can " <> action <> " records using the ❰" <> op <> "❱ operator, like this:\n\ + \ \n\ + \ \n\ \ ┌───────────────────────────────────────────┐ \n\ \ │ { foo = 1, bar = \"ABC\" } " <> op <> " { baz = True } │ \n\ \ └───────────────────────────────────────────┘ \n\ @@ -2781,7 +2865,7 @@ \ └─────────────────────────────────────────────┘ \n\ \ \n\ \ \n\ - \... but you cannot combine values that are not records. \n\ + \... but you cannot " <> action <> " values that are not records. \n\ \ \n\ \For example, the following expressions are " <> _NOT <> " valid: \n\ \ \n\ @@ -2807,17 +2891,17 @@ \ Invalid: This is a union type and not a record \n\ \ \n\ \ \n\ - \You tried to combine the following value: \n\ + \────────────────────────────────────────────────────────────────────────────────\n\ \ \n\ - \" <> txt0 <> "\n\ + \You supplied this expression as one of the arguments: \n\ \ \n\ + \" <> insert expression <> "\n\ + \ \n\ \... which is not a record, but is actually a: \n\ \ \n\ - \" <> txt1 <> "\n" + \" <> insert typeExpression <> "\n" where - op = pretty c - txt0 = insert expr0 - txt1 = insert expr1 + op = pretty c prettyTypeMessage (InvalidDuplicateField k expr0 expr1) = ErrorMessages {..} @@ -4598,6 +4682,8 @@ ListAppendMismatch <$> f a <*> f b InvalidDuplicateField a b c -> InvalidDuplicateField a <$> f b <*> f c + MustUpdateARecord a b c -> + MustUpdateARecord <$> f a <*> f b <*> f c MustCombineARecord a b c -> MustCombineARecord <$> pure a <*> f b <*> f c InvalidRecordCompletion a l -> diff --git a/tests/Dhall/Test/Dhall.hs b/tests/Dhall/Test/Dhall.hs --- a/tests/Dhall/Test/Dhall.hs +++ b/tests/Dhall/Test/Dhall.hs @@ -24,7 +24,7 @@ import Data.Vector (Vector) import Dhall (ToDhall, FromDhall) import Dhall.Core (Expr(..)) -import GHC.Generics (Generic) +import GHC.Generics (Generic, Rep) import Numeric.Natural (Natural) import Test.Tasty import Test.Tasty.HUnit @@ -311,23 +311,33 @@ Dhall.defaultInterpretOptions { Dhall.singletonConstructors = Dhall.Wrapped } + functionWithOptions + :: ( Generic a + , Dhall.GenericToDhall (Rep a) + , Generic b + , Dhall.GenericFromDhall (Rep b) + ) + => Dhall.InterpretOptions -> Dhall.Decoder (a -> b) + functionWithOptions options = + Dhall.function (Dhall.genericToDhallWith options) (Dhall.genericAutoWith options) + code `shouldPassThroughWrapped` values = testCase "Pass through" $ do - f <- Dhall.input (Dhall.autoWith wrappedOptions) code + f <- Dhall.input (functionWithOptions wrappedOptions) code values @=? map f values code `shouldPassThroughSmart` values = testCase "Pass through" $ do - f <- Dhall.input (Dhall.autoWith smartOptions) code + f <- Dhall.input (functionWithOptions smartOptions) code values @=? map f values code `shouldMarshalIntoWrapped` expectedValue = testCase "Marshal" $ do - actualValue <- Dhall.input (Dhall.autoWith wrappedOptions) code + actualValue <- Dhall.input (Dhall.genericAutoWith wrappedOptions) code expectedValue @=? actualValue code `shouldMarshalIntoSmart` expectedValue = testCase "Marshal" $ do - actualValue <- Dhall.input (Dhall.autoWith smartOptions) code + actualValue <- Dhall.input (Dhall.genericAutoWith smartOptions) code expectedValue @=? actualValue @@ -336,14 +346,14 @@ resolvedExpression <- Dhall.Import.assertNoImports parsedExpression - Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.injectWith wrappedOptions) value + Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.genericToDhallWith wrappedOptions) value value `shouldEmbedAsSmart` expectedCode = testCase "ToDhall" $ do parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText "(test)" expectedCode) resolvedExpression <- Dhall.Import.assertNoImports parsedExpression - Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.injectWith smartOptions) value + Dhall.Core.denote resolvedExpression @=? Dhall.embed (Dhall.genericToDhallWith smartOptions) value shouldConvertDhallToHaskellCorrectly :: TestTree shouldConvertDhallToHaskellCorrectly = diff --git a/tests/Dhall/Test/Import.hs b/tests/Dhall/Test/Import.hs --- a/tests/Dhall/Test/Import.hs +++ b/tests/Dhall/Test/Import.hs @@ -2,6 +2,7 @@ module Dhall.Test.Import where +import Control.Exception (SomeException) import Data.Monoid ((<>)) import Data.Text (Text) import Dhall.Import (MissingImports(..)) @@ -61,8 +62,12 @@ let directoryString = FilePath.takeDirectory pathString - Tasty.HUnit.testCase pathString (do + let expectedFailures = + [ importDirectory "success/unit/asLocation/HashA.dhall" + ] + Test.Util.testCase path expectedFailures (do + text <- Text.IO.readFile pathString actualExpr <- Core.throws (Parser.exprFromText mempty text) @@ -75,14 +80,20 @@ let load = State.evalStateT (Test.Util.loadWith actualExpr) (Import.emptyStatus directoryString) - if Turtle.filename (Turtle.fromText path) == "hashFromCacheA.dhall" - then do - setCache - _ <- load - unsetCache - else do - _ <- load - return () + let runTest = do + if Turtle.filename (Turtle.fromText path) == "hashFromCacheA.dhall" + then do + setCache + _ <- load + unsetCache + else do + _ <- load + return () + + let handler :: SomeException -> IO () + handler exception = Tasty.HUnit.assertFailure (show exception) + + Exception.handle handler runTest return () ) diff --git a/tests/Dhall/Test/Main.hs b/tests/Dhall/Test/Main.hs --- a/tests/Dhall/Test/Main.hs +++ b/tests/Dhall/Test/Main.hs @@ -71,6 +71,8 @@ System.Environment.setEnv "XDG_CACHE_HOME" (pwd ".cache") + System.Environment.setEnv "DHALL_TEST_VAR" "6 * 7" + allTests <- getAllTests Test.Tasty.defaultMain allTests 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 @@ -29,6 +29,7 @@ , ImportHashed(..) , ImportMode(..) , ImportType(..) + , PreferAnnotation(..) , Scheme(..) , URL(..) , Var(..) @@ -219,6 +220,14 @@ shrink = genericShrink +instance (Arbitrary s, Arbitrary a) => Arbitrary (PreferAnnotation s a) where + arbitrary = + Test.QuickCheck.oneof + [ pure PreferFromSource + , PreferFromWith <$> arbitrary + , pure PreferFromCompletion + ] + instance (Arbitrary s, Arbitrary a) => Arbitrary (Expr s a) where arbitrary = Test.QuickCheck.suchThat @@ -313,6 +322,7 @@ % (7 :: W "Project") % (1 :: W "Assert") % (1 :: W "Equivalent") + % (1 :: W "With") % (0 :: W "Note") % (7 :: W "ImportAlt") % (7 :: W "Embed") @@ -321,11 +331,22 @@ shrink expression = filter standardizedExpression (genericShrink expression) standardizedExpression :: Expr s a -> Bool -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 +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 With{} = + False +standardizedExpression (Prefer PreferFromCompletion _ _) = + False +standardizedExpression (Prefer (PreferFromWith _) _ _) = + False +standardizedExpression _ = + True instance Arbitrary File where arbitrary = lift2 File 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 @@ -1,14 +1,17 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE DerivingStrategies #-} +#endif + module Dhall.Test.TH where -import Dhall (FromDhall(..)) import Dhall.TH (HaskellType(..)) -import GHC.Generics import Test.Tasty (TestTree) import qualified Dhall @@ -18,25 +21,19 @@ Dhall.TH.makeHaskellTypeFromUnion "T" "./tests/th/example.dhall" -deriving instance Eq T -deriving instance Show T -deriving instance Generic T -deriving instance FromDhall T +deriving instance Eq T +deriving instance Show 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 Department +deriving instance Show Department -deriving instance Eq Employee -deriving instance Show Employee -deriving instance Generic Employee -deriving instance FromDhall Employee +deriving instance Eq Employee +deriving instance Show Employee tests :: TestTree tests = Tasty.testGroup "Template Haskell" [ makeHaskellTypeFromUnion ] 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Dhall.Test.TypeInference where @@ -44,7 +45,15 @@ successTest :: Text -> TestTree successTest prefix = do - let expectedFailures = [] + let expectedFailures = + [] + +#ifdef WITH_HTTP +#else + ++ [ typeInferenceDirectory "success/CacheImports" + , typeInferenceDirectory "success/CacheImportsCanonicalize" + ] +#endif Test.Util.testCase prefix expectedFailures $ do let prefixFP = Text.unpack prefix diff --git a/tests/format/doubleRoundB.dhall b/tests/format/doubleRoundB.dhall --- a/tests/format/doubleRoundB.dhall +++ b/tests/format/doubleRoundB.dhall @@ -1,37 +1,37 @@ -[ 1.0 -, 1.0 -, 1.0000000000000002 +[ 1.0000000000000000 +, 1.0000000000000001 , 1.0000000000000002 -, 1.0000000000000004 +, 1.0000000000000003 , 1.0000000000000004 -, 1.0000000000000007 +, 1.0000000000000005 +, 1.0000000000000006 , 1.0000000000000007 -, 1.0000000000000009 +, 1.0000000000000008 , 1.0000000000000009 -, 1.0e64 -, 1.0000000000000002e64 +, 1.0000000000000000e64 +, 1.0000000000000001e64 , 1.0000000000000002e64 , 1.0000000000000003e64 -, 1.0000000000000005e64 +, 1.0000000000000004e64 , 1.0000000000000005e64 , 1.0000000000000006e64 -, 1.0000000000000008e64 +, 1.0000000000000007e64 , 1.0000000000000008e64 , 1.0000000000000009e64 -, 1.0e100 -, 1.0e100 -, 1.0000000000000002e100 +, 1.0000000000000000e100 +, 1.0000000000000001e100 , 1.0000000000000002e100 -, 1.0000000000000004e100 +, 1.0000000000000003e100 , 1.0000000000000004e100 +, 1.0000000000000005e100 , 1.0000000000000006e100 -, 1.0000000000000008e100 +, 1.0000000000000007e100 , 1.0000000000000008e100 -, 1.000000000000001e100 -, 1.7976931348623157e308 -, 1.7976931348623157e308 -, 1.7976931348623155e308 -, -1.7976931348623157e308 -, -1.7976931348623157e308 -, -1.7976931348623155e308 +, 1.0000000000000009e100 +, 179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791.0 +, 179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945.0 +, 179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944.0 +, -179769313486231580793728971405303415079934132710037826936173778980444968292764750946649017977587207096330286416692887910946555547851940402630657488671505820681908902000708383676273854845817711531764475730270069855571366959622842914819860834936475292719074168444365510704342711559699508093042880177904174497791.0 +, -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218945.0 +, -179769313486231560835325876058105298516207002341652166261661174625869553267292326574530099287946549246750631490335877017522087105926987962906277604735569213290190919152394180476217125334960946356387261286640198029037799514183602981511756283727771403830521483963923935633133642802139091669457927874464075218944.0 ] diff --git a/tests/format/issue1687A.dhall b/tests/format/issue1687A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1687A.dhall @@ -0,0 +1,7 @@ +let {- foo + + bar -} + x = + 1 + +in x diff --git a/tests/format/issue1687B.dhall b/tests/format/issue1687B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/issue1687B.dhall @@ -0,0 +1,7 @@ +let {- foo + + bar -} + x = + 1 + +in x diff --git a/tests/format/largeExponentB.dhall b/tests/format/largeExponentB.dhall --- a/tests/format/largeExponentB.dhall +++ b/tests/format/largeExponentB.dhall @@ -1,1 +1,1 @@ -[ 1.0, 1.0e100, 1.0e-100 ] +[ 1.0, 1e100, 1e-100 ] diff --git a/tests/format/numericLiteralsA.dhall b/tests/format/numericLiteralsA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/numericLiteralsA.dhall @@ -0,0 +1,1 @@ +{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20 } diff --git a/tests/format/numericLiteralsB.dhall b/tests/format/numericLiteralsB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/numericLiteralsB.dhall @@ -0,0 +1,1 @@ +{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20 } diff --git a/tests/format/withA.dhall b/tests/format/withA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/withA.dhall @@ -0,0 +1,5 @@ +r with a = Some { b = 1, c = 1, d = 1, e = 1, f = 1, g = 1, h = 1, i = 1, j = 1, k = 1, l = 1 } + with b = T::{ b = 1, c = 1, d = 1, e = 1, f = 1, g = 1, h = 1, i = 1, j = 1, k = 1, l = 1 } + with c = [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ] + with d = 1 + with e = 111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 diff --git a/tests/format/withB.dhall b/tests/format/withB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/withB.dhall @@ -0,0 +1,58 @@ +r + with a = Some + { b = 1 + , c = 1 + , d = 1 + , e = 1 + , f = 1 + , g = 1 + , h = 1 + , i = 1 + , j = 1 + , k = 1 + , l = 1 + } + with b = T::{ + , b = 1 + , c = 1 + , d = 1 + , e = 1 + , f = 1 + , g = 1 + , h = 1 + , i = 1 + , j = 1 + , k = 1 + , l = 1 + } + with c = + [ 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + ] + with d = 1 + with e = + 111111111111111111111111111111111111111111111111111111111111111111111111111111111111111