From d9d8a565efad81c3b8de3f8105d95d967924df38 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Tue, 18 Apr 2023 20:07:15 -0700 Subject: [PATCH 01/16] =?UTF-8?q?Version=201.41.2=20=E2=86=92=201.42.0=20(?= =?UTF-8?q?#2510)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- dhall-bash/dhall-bash.cabal | 4 +-- dhall-csv/CHANGELOG.md | 4 +++ dhall-csv/dhall-csv.cabal | 4 +-- dhall-docs/CHANGELOG.md | 6 ++++ dhall-docs/dhall-docs.cabal | 4 +-- dhall-json/CHANGELOG.md | 4 +++ dhall-json/dhall-json.cabal | 4 +-- dhall-lsp-server/dhall-lsp-server.cabal | 4 +-- dhall-nix/dhall-nix.cabal | 4 +-- dhall-nixpkgs/dhall-nixpkgs.cabal | 4 +-- dhall-openapi/dhall-openapi.cabal | 4 +-- dhall-toml/CHANGELOG.md | 4 +++ dhall-toml/dhall-toml.cabal | 4 +-- dhall-yaml/CHANGELOG.md | 2 ++ dhall-yaml/dhall-yaml.cabal | 4 +-- dhall/CHANGELOG.md | 37 +++++++++++++++++++++++-- dhall/dhall-lang | 2 +- dhall/dhall.cabal | 2 +- 18 files changed, 77 insertions(+), 24 deletions(-) diff --git a/dhall-bash/dhall-bash.cabal b/dhall-bash/dhall-bash.cabal index 2ed643cd4..6ac38b859 100644 --- a/dhall-bash/dhall-bash.cabal +++ b/dhall-bash/dhall-bash.cabal @@ -1,5 +1,5 @@ Name: dhall-bash -Version: 1.0.40 +Version: 1.0.41 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -30,7 +30,7 @@ Library base >= 4.11.0.0 && < 5 , bytestring < 0.12, containers < 0.7 , - dhall >= 1.41.0 && < 1.42, + dhall >= 1.42.0 && < 1.43, neat-interpolation < 0.6 , shell-escape < 0.3 , text >= 0.2 && < 2.1 diff --git a/dhall-csv/CHANGELOG.md b/dhall-csv/CHANGELOG.md index 07fec790d..fe120dc3a 100644 --- a/dhall-csv/CHANGELOG.md +++ b/dhall-csv/CHANGELOG.md @@ -1,3 +1,7 @@ +1.0.4 + +* Build against `dhall-1.42.0` + 1.0.3 * Builds against newer dependencies diff --git a/dhall-csv/dhall-csv.cabal b/dhall-csv/dhall-csv.cabal index 28bd99d41..9458d493c 100644 --- a/dhall-csv/dhall-csv.cabal +++ b/dhall-csv/dhall-csv.cabal @@ -1,5 +1,5 @@ Name: dhall-csv -Version: 1.0.3 +Version: 1.0.4 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -38,7 +38,7 @@ Library containers >= 0.5.9 && < 0.7 , either , exceptions >= 0.8.3 && < 0.11, - dhall >= 1.39.0 && < 1.42, + dhall >= 1.39.0 && < 1.43, filepath < 1.5 , optparse-applicative , prettyprinter >= 1.7.0 && < 1.8 , diff --git a/dhall-docs/CHANGELOG.md b/dhall-docs/CHANGELOG.md index 34b5d8ec7..015ef923a 100644 --- a/dhall-docs/CHANGELOG.md +++ b/dhall-docs/CHANGELOG.md @@ -1,3 +1,9 @@ +1.0.11 + +* Build against `dhall-1.42` +* [Build against `turtle-1.6`](https://github.com/dhall-lang/dhall-haskell/pull/2465) +* [Build against `transformers-0.6` and `mtl-2.3`](https://github.com/dhall-lang/dhall-haskell/pull/2471) + 1.0.10 * [Index non-`.dhall` files](https://github.com/dhall-lang/dhall-haskell/pull/2407) diff --git a/dhall-docs/dhall-docs.cabal b/dhall-docs/dhall-docs.cabal index 8edb0c777..4882644f0 100644 --- a/dhall-docs/dhall-docs.cabal +++ b/dhall-docs/dhall-docs.cabal @@ -1,5 +1,5 @@ Name: dhall-docs -Version: 1.0.10 +Version: 1.0.11 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -69,7 +69,7 @@ Library containers , cryptohash-sha256 , directory >= 1.3.0.0 && < 1.4 , - dhall >= 1.38.0 && < 1.42, + dhall >= 1.38.0 && < 1.43, file-embed >= 0.0.10.0 , filepath >= 1.4 && < 1.5 , lens-family-core >= 1.0.0 && < 2.2 , diff --git a/dhall-json/CHANGELOG.md b/dhall-json/CHANGELOG.md index e7e9d4ef4..c9bc8d9f9 100644 --- a/dhall-json/CHANGELOG.md +++ b/dhall-json/CHANGELOG.md @@ -1,3 +1,7 @@ +1.7.12 + +* Build against `dhall-1.42` + 1.7.11 * [Add new `--preserve-header` option](https://github.com/dhall-lang/dhall-haskell/pull/2433) diff --git a/dhall-json/dhall-json.cabal b/dhall-json/dhall-json.cabal index 6fe62951c..77145a149 100644 --- a/dhall-json/dhall-json.cabal +++ b/dhall-json/dhall-json.cabal @@ -1,5 +1,5 @@ Name: dhall-json -Version: 1.7.11 +Version: 1.7.12 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -43,7 +43,7 @@ Library aeson-yaml >= 1.1.0 && < 1.2 , bytestring < 0.12, containers >= 0.5.9 && < 0.7 , - dhall >= 1.41.0 && < 1.42, + dhall >= 1.42.0 && < 1.43, exceptions >= 0.8.3 && < 0.11, filepath < 1.5 , lens-family-core >= 1.0.0 && < 2.2 , diff --git a/dhall-lsp-server/dhall-lsp-server.cabal b/dhall-lsp-server/dhall-lsp-server.cabal index d070e1701..802dd6a24 100644 --- a/dhall-lsp-server/dhall-lsp-server.cabal +++ b/dhall-lsp-server/dhall-lsp-server.cabal @@ -1,5 +1,5 @@ name: dhall-lsp-server -Version: 1.1.2 +Version: 1.1.3 cabal-version: 1.12 synopsis: Language Server Protocol (LSP) server for Dhall homepage: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-lsp-server#readme @@ -49,7 +49,7 @@ library , containers >= 0.5.11.0 && < 0.7 , data-default >= 0.7.1.1 && < 0.8 , directory >= 1.2.2.0 && < 1.4 - , dhall >= 1.38.0 && < 1.42 + , dhall >= 1.38.0 && < 1.43 , dhall-json >= 1.4 && < 1.8 , filepath >= 1.4.2 && < 1.5 , lsp >= 1.2.0.0 && < 1.5 diff --git a/dhall-nix/dhall-nix.cabal b/dhall-nix/dhall-nix.cabal index 389ac0252..ca09112cc 100644 --- a/dhall-nix/dhall-nix.cabal +++ b/dhall-nix/dhall-nix.cabal @@ -1,5 +1,5 @@ Name: dhall-nix -Version: 1.1.25 +Version: 1.1.26 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -29,7 +29,7 @@ Library base >= 4.11.0.0 && < 5 , containers < 0.7 , data-fix < 0.4 , - dhall >= 1.41 && < 1.42, + dhall >= 1.42 && < 1.43, hnix >= 0.16 && < 0.17, lens-family-core >= 1.0.0 && < 2.2 , neat-interpolation < 0.6 , diff --git a/dhall-nixpkgs/dhall-nixpkgs.cabal b/dhall-nixpkgs/dhall-nixpkgs.cabal index b13447743..9ab77a4c4 100644 --- a/dhall-nixpkgs/dhall-nixpkgs.cabal +++ b/dhall-nixpkgs/dhall-nixpkgs.cabal @@ -1,4 +1,4 @@ -Version: 1.0.9 +Version: 1.0.10 Cabal-Version: >=1.10 Name: dhall-nixpkgs Synopsis: Convert Dhall projects to Nix packages @@ -22,7 +22,7 @@ Executable dhall-to-nixpkgs , base64-bytestring >= 1.1.0.0 , bytestring < 0.12 , data-fix - , dhall >= 1.32.0 && < 1.42 + , dhall >= 1.42.0 && < 1.43 , foldl < 1.5 , hnix >= 0.10.1 && < 0.17 , lens-family-core >= 1.0.0 && < 2.2 diff --git a/dhall-openapi/dhall-openapi.cabal b/dhall-openapi/dhall-openapi.cabal index 2b4948dd3..5c8fd3be2 100644 --- a/dhall-openapi/dhall-openapi.cabal +++ b/dhall-openapi/dhall-openapi.cabal @@ -1,6 +1,6 @@ Cabal-Version: 1.11 Name: dhall-openapi -Version: 1.0.5 +Version: 1.0.6 Homepage: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-openapi#dhall-openapi Author: Fabrizio Ferrai Maintainer: GenuineGabriella@gmail.com @@ -79,7 +79,7 @@ Library base >= 4.11.0.0 && < 5 , aeson >= 1.0.0.0 && < 2.2 , containers >= 0.5.8.0 && < 0.7 , - dhall >= 1.38.0 && < 1.42 , + dhall >= 1.38.0 && < 1.43 , prettyprinter >= 1.7.0 && < 1.8 , scientific >= 0.3.0.0 && < 0.4 , sort >= 1.0 && < 1.1 , diff --git a/dhall-toml/CHANGELOG.md b/dhall-toml/CHANGELOG.md index a0972735a..1cf80824f 100644 --- a/dhall-toml/CHANGELOG.md +++ b/dhall-toml/CHANGELOG.md @@ -1,3 +1,7 @@ +1.0.3 + +* [Support `Integer`s](https://github.com/dhall-lang/dhall-haskell/pull/2469) + 1.0.2 * [Improve command-line interface](https://github.com/dhall-lang/dhall-haskell/pull/2355) diff --git a/dhall-toml/dhall-toml.cabal b/dhall-toml/dhall-toml.cabal index e5c80d7ab..385e83108 100644 --- a/dhall-toml/dhall-toml.cabal +++ b/dhall-toml/dhall-toml.cabal @@ -1,5 +1,5 @@ Name: dhall-toml -Version: 1.0.2 +Version: 1.0.3 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 @@ -35,7 +35,7 @@ Library Hs-Source-Dirs: src Build-Depends: base >= 4.12 && < 5 , - dhall >= 1.39.0 && < 1.42 , + dhall >= 1.39.0 && < 1.43 , tomland >= 1.3.2.0 && < 1.4 , text >= 0.11.1.0 && < 2.1 , containers >= 0.5.9 && < 0.7 , diff --git a/dhall-yaml/CHANGELOG.md b/dhall-yaml/CHANGELOG.md index 7701255fe..2938ab2ff 100644 --- a/dhall-yaml/CHANGELOG.md +++ b/dhall-yaml/CHANGELOG.md @@ -1,3 +1,5 @@ +* Build against `dhall-1.42` + 1.2.11 * [Add new `--preserve-header` option](https://github.com/dhall-lang/dhall-haskell/pull/2410) diff --git a/dhall-yaml/dhall-yaml.cabal b/dhall-yaml/dhall-yaml.cabal index 0121a8f10..645796622 100644 --- a/dhall-yaml/dhall-yaml.cabal +++ b/dhall-yaml/dhall-yaml.cabal @@ -1,5 +1,5 @@ Name: dhall-yaml -Version: 1.2.11 +Version: 1.2.12 Cabal-Version: >=1.10 Build-Type: Simple License: GPL-3 @@ -36,7 +36,7 @@ Library base >= 4.11.0.0 && < 5 , aeson >= 1.0.0.0 && < 2.2 , bytestring < 0.12, - dhall >= 1.31.0 && < 1.42, + dhall >= 1.31.0 && < 1.43, dhall-json >= 1.6.0 && < 1.8 , optparse-applicative >= 0.14.0.0 && < 0.18, text >= 0.11.1.0 && < 2.1 , diff --git a/dhall/CHANGELOG.md b/dhall/CHANGELOG.md index 7322fc9a4..fdeea7975 100644 --- a/dhall/CHANGELOG.md +++ b/dhall/CHANGELOG.md @@ -1,5 +1,38 @@ -Unreleased - +1.42.0 + +* [Supports standard version 23.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v23.0.0) + * [BREAKING CHANGE TO THE API AND LANGUAGE: Language support for `Bytes` literals](https://github.com/dhall-lang/dhall-haskell/pull/2499) + * This is a breaking change to the API due to adding new `Bytes` and `BytesLiteral` constructors to the `Expr` type + * This is a breaking change to the language now that `Bytes` is a reserved identifier + * [BREAKING CHANGE TO THE API AND LANGUAGE: New `{Date,Time,TimeZone}/show` builtins](https://github.com/dhall-lang/dhall-haskell/pull/2493) + * This is a breaking change to the API due to adding new `{Date,Time,TimeZone}Show` constructors to the `Expr` type + * This is a breaking change to the language now that `{Date,Time,TimeZone}/show` are not reserved identifiers +* [BREAKING CHANGE: `dhall lint` no longer sorts `let` bindings](https://github.com/dhall-lang/dhall-haskell/pull/2503) + * This had to be removed because the old behavior was not always correct + * The old behavior would sometimes change the behavior of a Dhall program or break the program + * Out of an abundance of caution we're disabling the feature until it can be properly fixed (which is't trivial) +* [BUG FIX: Fix pretty-printing of `Time` literals](https://github.com/dhall-lang/dhall-haskell/pull/2466) + * The pretty-printer was stripping leading zeros from the fractional component + of seconds +* [BUG FIX: Fix custom normalizers to work for things other than functions](https://github.com/dhall-lang/dhall-haskell/pull/2464) + * Before this change you could extend the language with custom functions, but + not custom values (e.g. `foo = 1`) +* [BUG FIX: Don't URL encode path components](https://github.com/dhall-lang/dhall-haskell/pull/2505) + * The pretty-printer was URL-encoding path components, which is not correct (according to the standard) + * URL path components are supposed to be already URL-encoded by the user and left undisturbed by the interpreter (which is now what it correctly does) +* New `dhall package` command: [#2478](https://github.com/dhall-lang/dhall-haskell/pull/2487), [#2508](https://github.com/dhall-lang/dhall-haskell/pull/2508) + * This command makes it easier to turn a directory full of Dhall expressions + into a dhall package (e.g. `package.dhall`) +* [Improved `dhall to-directory-tree` subcommand](https://github.com/dhall-lang/dhall-haskell/pull/2437) + * The `dhall to-directory-tree` subcommand now optionally supports specifying + metadata for generated paths + * For a worked example, see: https://github.com/dhall-lang/dhall-haskell/blob/main/dhall/examples/to-directory-tree.dhall +* `dhall freeze --cache --all` is now idempotent: [#2486](https://github.com/dhall-lang/dhall-haskell/pull/2486), [#2500](https://github.com/dhall-lang/dhall-haskell/pull/2500) + * Before this change a second run would fail due to attempting to resolve + the `missing` import it would generate +* [New Template Haskell options for adding strictness annotations to generated Haskell types](https://github.com/dhall-lang/dhall-haskell/pull/2504) +* [Template Haskell can now generate higher-kinded Haskell types from higher-kinded Dhall types](https://github.com/dhall-lang/dhall-haskell/pull/2506) +* [New `Dhall.Freeze` utilities for working with custom evaluators](https://github.com/dhall-lang/dhall-haskell/pull/2478) * [Add `Data` instances for `Import` and various other types](https://github.com/dhall-lang/dhall-haskell/pull/2462) * [Add `Eq` instances for `InvalidDecoder` and `ExtractError`](https://github.com/dhall-lang/dhall-haskell/pull/2482) diff --git a/dhall/dhall-lang b/dhall/dhall-lang index a3de281a1..25cf020ab 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit a3de281a114c95820ce612bc5383fff717aa507e +Subproject commit 25cf020ab307cb2d66826b0d1ddac8bc89241e27 diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 172ae526e..1594444e2 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.4 Name: dhall -Version: 1.41.2 +Version: 1.42.0 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE From 959faedcfafef1c84f00fc8119715eb6d8977494 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 20 Jun 2023 17:57:07 +0100 Subject: [PATCH 02/16] Relax upper bound to accommodate dependency on ansi-terminal-1.0 (#2521) --- dhall-json/dhall-json.cabal | 2 +- dhall-yaml/dhall-yaml.cabal | 2 +- dhall/dhall.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dhall-json/dhall-json.cabal b/dhall-json/dhall-json.cabal index 77145a149..340df9093 100644 --- a/dhall-json/dhall-json.cabal +++ b/dhall-json/dhall-json.cabal @@ -98,7 +98,7 @@ Executable json-to-dhall Build-Depends: base , aeson , - ansi-terminal >= 0.6.3.1 && < 0.12, + ansi-terminal >= 0.6.3.1 && < 1.1 , bytestring , dhall , dhall-json , diff --git a/dhall-yaml/dhall-yaml.cabal b/dhall-yaml/dhall-yaml.cabal index 645796622..d744aef2c 100644 --- a/dhall-yaml/dhall-yaml.cabal +++ b/dhall-yaml/dhall-yaml.cabal @@ -65,7 +65,7 @@ Executable yaml-to-dhall Build-Depends: base , aeson , - ansi-terminal >= 0.6.3.1 && < 0.12, + ansi-terminal >= 0.6.3.1 && < 1.1 , bytestring , dhall , dhall-json , diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 1594444e2..3732d1c99 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -207,7 +207,7 @@ Common common base >= 4.11.0.0 && < 5 , aeson >= 1.0.0.0 && < 2.2 , aeson-pretty < 0.9 , - ansi-terminal >= 0.6.3.1 && < 0.12, + ansi-terminal >= 0.6.3.1 && < 1.1 , atomic-write >= 0.2.0.7 && < 0.3 , base16-bytestring >= 1.0.0.0 , bytestring < 0.12, From 8d77098dfac2fa33a9b6f41aff9ec693e3d583e0 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Sat, 2 Sep 2023 22:54:08 -0500 Subject: [PATCH 03/16] Disable the tests that use httpbin.org (#2533) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit … so that CI stops failing with various 50X errors --- .github/workflows/main.yml | 2 +- dhall/tests/Dhall/Test/Import.hs | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index a9ef6421a..9c1626f1f 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -31,7 +31,7 @@ jobs: submodules: true - id: setup-haskell-cabal name: "Setup Haskell environment" - uses: haskell/actions/setup@v1.2.1 + uses: haskell/actions/setup@v2.4.6 with: enable-stack: true - name: "Cache" diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 8c581f64f..8a6c0c6bc 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -54,6 +54,24 @@ getTests = do , importDirectory "success/unit/asLocation/RemoteChain2A.dhall" , importDirectory "success/unit/asLocation/RemoteChain3A.dhall" , importDirectory "success/unit/asLocation/RemoteChainMissingA.dhall" + + -- Skip all tests that reference httpbin.org to avoid clobbering + -- their servers. These should eventually be replaced by tests + -- that depend on an equivalent endpoint on test.dhall-lang.org + -- instead of httpbin.org. + , importDirectory "failure/customHeadersUsingBoundVariable.dhall" + , importDirectory "failure/originHeadersFromRemote.dhall" + , importDirectory "failure/originHeadersFromRemoteENV.dhall" + , importDirectory "success/customHeadersA.dhall" + , importDirectory "success/noHeaderForwardingA.dhall" + , importDirectory "success/success/originHeadersA.dhall" + , importDirectory "success/originHeadersENV.dhall" + , importDirectory "success/originHeadersImportA.dhall" + , importDirectory "success/originHeadersImportENV.dhall" + , importDirectory "success/originHeadersImportFromEnvA.dhall" + , importDirectory "success/originHeadersImportFromEnvENV.dhall" + , importDirectory "success/originHeadersOverrideA.dhall" + , importDirectory "success/originHeadersOverrideENV.dhall" ] successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest (do From 48d96ea19c47144d422568c55972ebcca21aad43 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Sun, 10 Sep 2023 12:56:14 -0700 Subject: [PATCH 04/16] Build against `optparse-generic-1.5.0` (#2519) Related to https://github.com/commercialhaskell/stackage/issues/6968 --- dhall-bash/dhall-bash.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall-bash/dhall-bash.cabal b/dhall-bash/dhall-bash.cabal index 6ac38b859..0f59b66be 100644 --- a/dhall-bash/dhall-bash.cabal +++ b/dhall-bash/dhall-bash.cabal @@ -48,7 +48,7 @@ Executable dhall-to-bash bytestring , dhall , dhall-bash , - optparse-generic >= 1.1.1 && < 1.5 , + optparse-generic >= 1.1.1 && < 1.6 , text GHC-Options: -Wall Default-Language: Haskell2010 From 5e817a9c6bccf72123a3c67961af149b32d75c10 Mon Sep 17 00:00:00 2001 From: Deniz Alp Durmaz Date: Tue, 3 Oct 2023 23:33:06 +0300 Subject: [PATCH 05/16] Relax restrictive upper bound on lens (#2539) The nix build is broken due to haskell-updates following lens version 5.2.3 and dhall-lsp-server having this restrictive upper bound on 5.2. --- dhall-lsp-server/dhall-lsp-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall-lsp-server/dhall-lsp-server.cabal b/dhall-lsp-server/dhall-lsp-server.cabal index 802dd6a24..bf8b11b9b 100644 --- a/dhall-lsp-server/dhall-lsp-server.cabal +++ b/dhall-lsp-server/dhall-lsp-server.cabal @@ -55,7 +55,7 @@ library , lsp >= 1.2.0.0 && < 1.5 , rope-utf16-splay >= 0.3.1.0 && < 0.5 , hslogger >= 1.2.10 && < 1.4 - , lens >= 4.16.1 && < 5.2 + , lens >= 4.16.1 && < 5.3 -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 , megaparsec >= 7.0.2 && < 10 , mtl >= 2.2.2 && < 2.3 From 55aff097b49ff85bb4eff1cc4f42c9fe40df3f49 Mon Sep 17 00:00:00 2001 From: lrworth Date: Sat, 7 Oct 2023 02:30:43 +1100 Subject: [PATCH 06/16] Support GHC 9.4 (#2532) * chore: enable CPP in Dhall.DirectoryTree Adding a \ to the escaped newlines appears to make CPP generate valid haskell without getting stuck. * feat: support unix-compat 0.8 In unix-compat 0.7, `getUserEntryForName` threw an exception when called on Windows. unix-compat 0.8 removes it entirely. To increase likelihood of this change being merged, the behaviour of the 0.7 version has been incorporated into Dhall.DirectoryTree. * chore: fix template-haskell bound dhall does not compile with template-haskell >=2.17 due to signature change of Language.Haskell.TH.Syntax.PlainTV. * chore: support template-haskell 2.17 through 2.19 In particular this enables building with GHC 9.4. * chore(dhall): version 1.42.1 * fix: System.Posix.User.getGroupEntryForName does not exist on Windows --- dhall/dhall.cabal | 8 +- dhall/src/Dhall/DirectoryTree.hs | 139 +++++++++++++++++-------------- dhall/src/Dhall/TH.hs | 7 +- 3 files changed, 90 insertions(+), 64 deletions(-) diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 3732d1c99..f36fb2682 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.4 Name: dhall -Version: 1.42.0 +Version: 1.42.1 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -251,10 +251,14 @@ Common common th-lift-instances >= 0.1.13 && < 0.2 , time >= 1.9 && < 1.13, transformers >= 0.5.2.0 && < 0.7 , - unix-compat >= 0.4.2 && < 0.7 , + unix-compat >= 0.4.2 && < 0.8 , unordered-containers >= 0.1.3.0 && < 0.3 , vector >= 0.11.0.0 && < 0.14 + if !os(windows) + Build-Depends: + unix >= 2.7 && < 2.9 , + if flag(with-http) CPP-Options: -DWITH_HTTP diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 405931e9b..fec32bea4 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -54,8 +55,12 @@ import qualified Prettyprinter as Pretty import qualified Prettyprinter.Render.String as Pretty import qualified System.Directory as Directory import qualified System.FilePath as FilePath +#ifdef mingw32_HOST_OS +import System.IO.Error (illegalOperationErrorType, mkIOError) +#else +import qualified System.Posix.User as Posix +#endif import qualified System.PosixCompat.Files as Posix -import qualified System.PosixCompat.User as Posix {-| Attempt to transform a Dhall record into a directory tree where: @@ -263,12 +268,24 @@ makeType = Record . Map.fromList <$> sequenceA -- | Resolve a `User` to a numerical id. getUser :: User -> IO UserID getUser (UserId uid) = return uid -getUser (UserName name) = Posix.userID <$> Posix.getUserEntryForName name +getUser (UserName name) = +#ifdef mingw32_HOST_OS + ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where x = "System.Posix.User.getUserEntryForName: not supported" +#else + Posix.userID <$> Posix.getUserEntryForName name +#endif -- | Resolve a `Group` to a numerical id. getGroup :: Group -> IO GroupID getGroup (GroupId gid) = return gid -getGroup (GroupName name) = Posix.groupID <$> Posix.getGroupEntryForName name +getGroup (GroupName name) = +#ifdef mingw32_HOST_OS + ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where x = "System.Posix.User.getGroupEntryForName: not supported" +#else + Posix.groupID <$> Posix.getGroupEntryForName name +#endif -- | Process a `FilesystemEntry`. Writes the content to disk and apply the -- metadata to the newly created item. @@ -409,57 +426,57 @@ instance Show FilesystemError where Pretty.renderString (Dhall.Pretty.layout message) where message = - 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 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❱. Values of union types can also be converted if \n\ - \they are an alternative which has a non-nullary constructor whose argument is of \n\ - \an otherwise convertible type. Furthermore, there is a more advanced approach to \n\ - \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream \n\ - \documentation of the `toDirectoryTree` function in the Dhall.Directory module for \n\ - \further information on that. \n\ - \No other type of value can be translated to a directory tree. \n\ - \ \n\ - \For example, this is a valid expression that can be translated to a directory \n\ - \tree: \n\ - \ \n\ - \ \n\ - \ ┌──────────────────────────────────┐ \n\ - \ │ { `example.json` = \"[1, true]\" } │ \n\ - \ └──────────────────────────────────┘ \n\ - \ \n\ - \ \n\ - \In contrast, the following expression is not allowed due to containing a \n\ - \❰Natural❱ field, which cannot be translated in this way: \n\ - \ \n\ - \ \n\ - \ ┌───────────────────────┐ \n\ - \ │ { `example.txt` = 1 } │ \n\ - \ └───────────────────────┘ \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\ + 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 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❱. Values of union types can also be converted if \n\\ + \they are an alternative which has a non-nullary constructor whose argument is of \n\\ + \an otherwise convertible type. Furthermore, there is a more advanced approach to \n\\ + \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream \n\\ + \documentation of the `toDirectoryTree` function in the Dhall.Directory module for \n\\ + \further information on that. \n\\ + \No other type of value can be translated to a directory tree. \n\\ + \ \n\\ + \For example, this is a valid expression that can be translated to a directory \n\\ + \tree: \n\\ + \ \n\\ + \ \n\\ + \ ┌──────────────────────────────────┐ \n\\ + \ │ { `example.json` = \"[1, true]\" } │ \n\\ + \ └──────────────────────────────────┘ \n\\ + \ \n\\ + \ \n\\ + \In contrast, the following expression is not allowed due to containing a \n\\ + \❰Natural❱ field, which cannot be translated in this way: \n\\ + \ \n\\ + \ \n\\ + \ ┌───────────────────────┐ \n\\ + \ │ { `example.txt` = 1 } │ \n\\ + \ └───────────────────────┘ \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 not an expression that can be translated to a directory tree. \n" {- | This error indicates that you want to set some metadata for a file or @@ -475,11 +492,11 @@ instance Show MetadataUnsupportedError where Pretty.renderString (Dhall.Pretty.layout message) where message = - Util._ERROR <> ": Setting metadata is not supported on this platform. \n\ - \ \n\ - \Explanation: Your Dhall expression indicates that you intend to set some metadata \n\ - \like ownership or permissions for the following file or directory: \n\ - \ \n\ - \" <> Pretty.pretty metadataForPath <> "\n\ - \ \n\ + Util._ERROR <> ": Setting metadata is not supported on this platform. \n\\ + \ \n\\ + \Explanation: Your Dhall expression indicates that you intend to set some metadata \n\\ + \like ownership or permissions for the following file or directory: \n\\ + \ \n\\ + \" <> Pretty.pretty metadataForPath <> "\n\\ + \ \n\\ \... which is not supported on your platform. \n" diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index ed08d0334..203ec662f 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -263,7 +264,11 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = interpretOptions = generateToInterpretOptions generateOptions typ - toTypeVar (V n i) = Syntax.PlainTV $ Syntax.mkName (Text.unpack n ++ show i) +#if MIN_VERSION_template_haskell(2,17,0) + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) () +#else + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) +#endif toDataD typeName typeParams constructors = do let name = Syntax.mkName (Text.unpack typeName) From dfa82861ed13796f6d7b96b30139a6f11e057e7b Mon Sep 17 00:00:00 2001 From: Daniel Firth Date: Tue, 17 Oct 2023 22:15:18 +0000 Subject: [PATCH 07/16] compatibility with template-haskell-2.21.0 and ghc 9.8 (#2542) --- dhall-bash/dhall-bash.cabal | 4 ++-- dhall/dhall.cabal | 10 +++++----- dhall/src/Dhall/Syntax/Instances/Lift.hs | 5 +++++ dhall/src/Dhall/TH.hs | 4 +++- 4 files changed, 15 insertions(+), 8 deletions(-) diff --git a/dhall-bash/dhall-bash.cabal b/dhall-bash/dhall-bash.cabal index 0f59b66be..4ee8f62f7 100644 --- a/dhall-bash/dhall-bash.cabal +++ b/dhall-bash/dhall-bash.cabal @@ -28,12 +28,12 @@ Library Hs-Source-Dirs: src Build-Depends: base >= 4.11.0.0 && < 5 , - bytestring < 0.12, + bytestring < 0.13, containers < 0.7 , dhall >= 1.42.0 && < 1.43, neat-interpolation < 0.6 , shell-escape < 0.3 , - text >= 0.2 && < 2.1 + text >= 0.2 && < 2.2 Exposed-Modules: Dhall.Bash GHC-Options: -Wall Default-Language: Haskell2010 diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index f36fb2682..16ca7cb06 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -205,19 +205,19 @@ Flag network-tests Common common Build-Depends: base >= 4.11.0.0 && < 5 , - aeson >= 1.0.0.0 && < 2.2 , + aeson >= 1.0.0.0 && < 2.3 , aeson-pretty < 0.9 , ansi-terminal >= 0.6.3.1 && < 1.1 , atomic-write >= 0.2.0.7 && < 0.3 , base16-bytestring >= 1.0.0.0 , - bytestring < 0.12, + bytestring < 0.13, case-insensitive < 1.3 , cborg >= 0.2.0.0 && < 0.3 , cborg-json >= 0.2.2.0 && < 0.3 , containers >= 0.5.8.0 && < 0.7 , contravariant < 1.6 , data-fix < 0.4 , - deepseq < 1.5 , + deepseq < 1.6 , Diff >= 0.2 && < 0.5 , directory >= 1.3.0.0 && < 1.4 , dotgen >= 0.4.2 && < 0.5 , @@ -244,8 +244,8 @@ Common common repline >= 0.4.0.0 && < 0.5 , serialise >= 0.2.0.0 && < 0.3 , scientific >= 0.3.0.0 && < 0.4 , - template-haskell >= 2.13.0.0 && < 2.20, - text >= 0.11.1.0 && < 2.1 , + template-haskell >= 2.13.0.0 && < 2.22, + text >= 0.11.1.0 && < 2.2 , text-manipulate >= 0.2.0.1 && < 0.4 , text-short >= 0.1 && < 0.2 , th-lift-instances >= 0.1.13 && < 0.2 , diff --git a/dhall/src/Dhall/Syntax/Instances/Lift.hs b/dhall/src/Dhall/Syntax/Instances/Lift.hs index 50a0bd163..c19050a96 100644 --- a/dhall/src/Dhall/Syntax/Instances/Lift.hs +++ b/dhall/src/Dhall/Syntax/Instances/Lift.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} @@ -15,13 +16,17 @@ import Dhall.Syntax.Types import Dhall.Syntax.Var import Language.Haskell.TH.Syntax (Lift) +#if !MIN_VERSION_template_haskell(2,21,0) import qualified Data.Fixed as Fixed +#endif import qualified Data.Time as Time deriving instance Lift Time.Day deriving instance Lift Time.TimeOfDay deriving instance Lift Time.TimeZone +#if !MIN_VERSION_template_haskell(2,21,0) deriving instance Lift (Fixed.Fixed a) +#endif deriving instance Lift Const deriving instance Lift Var deriving instance (Lift s, Lift a) => Lift (Binding s a) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index 203ec662f..f1b1ffd79 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -264,7 +264,9 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = interpretOptions = generateToInterpretOptions generateOptions typ -#if MIN_VERSION_template_haskell(2,17,0) +#if MIN_VERSION_template_haskell(2,21,0) + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis +#elif MIN_VERSION_template_haskell(2,17,0) toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) () #else toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) From c566f30af8f19367b995f8300fe9108b2b4b7db1 Mon Sep 17 00:00:00 2001 From: JackKelly-Bellroy <64521034+JackKelly-Bellroy@users.noreply.github.com> Date: Fri, 20 Oct 2023 11:18:00 +1000 Subject: [PATCH 08/16] treewide: Raise bounds on optparse-applicative (#2543) --- dhall-docs/dhall-docs.cabal | 2 +- dhall-json/dhall-json.cabal | 2 +- dhall-nix/dhall-nix.cabal | 4 ++-- dhall-nixpkgs/dhall-nixpkgs.cabal | 2 +- dhall-openapi/dhall-openapi.cabal | 4 ++-- dhall-toml/dhall-toml.cabal | 2 +- dhall-yaml/dhall-yaml.cabal | 2 +- dhall/dhall.cabal | 2 +- 8 files changed, 10 insertions(+), 10 deletions(-) diff --git a/dhall-docs/dhall-docs.cabal b/dhall-docs/dhall-docs.cabal index 4882644f0..ff94fc09f 100644 --- a/dhall-docs/dhall-docs.cabal +++ b/dhall-docs/dhall-docs.cabal @@ -84,7 +84,7 @@ Library text >= 0.11.1.0 && < 2.1 , transformers >= 0.2.0.0 && < 0.7 , mtl >= 2.2.1 && < 2.4 , - optparse-applicative >= 0.14.0.0 && < 0.18 + optparse-applicative >= 0.14.0.0 && < 0.19 Exposed-Modules: Dhall.Docs Dhall.Docs.Core diff --git a/dhall-json/dhall-json.cabal b/dhall-json/dhall-json.cabal index 340df9093..76f3b8080 100644 --- a/dhall-json/dhall-json.cabal +++ b/dhall-json/dhall-json.cabal @@ -47,7 +47,7 @@ Library exceptions >= 0.8.3 && < 0.11, filepath < 1.5 , lens-family-core >= 1.0.0 && < 2.2 , - optparse-applicative >= 0.14.0.0 && < 0.18, + optparse-applicative >= 0.14.0.0 && < 0.19, prettyprinter >= 1.7.0 && < 1.8 , scientific >= 0.3.0.0 && < 0.4 , text >= 0.11.1.0 && < 2.1 , diff --git a/dhall-nix/dhall-nix.cabal b/dhall-nix/dhall-nix.cabal index ca09112cc..8147cdeee 100644 --- a/dhall-nix/dhall-nix.cabal +++ b/dhall-nix/dhall-nix.cabal @@ -40,7 +40,7 @@ Library Default-Language: Haskell2010 if os(windows) Buildable: False - + Executable dhall-to-nix if os(windows) Buildable: False @@ -53,7 +53,7 @@ Executable dhall-to-nix dhall , dhall-nix , hnix , - optparse-generic >= 1.1.1 && < 1.5, + optparse-generic >= 1.1.1 && < 1.6, text GHC-Options: -Wall Default-Language: Haskell2010 diff --git a/dhall-nixpkgs/dhall-nixpkgs.cabal b/dhall-nixpkgs/dhall-nixpkgs.cabal index 9ab77a4c4..2b03c20e2 100644 --- a/dhall-nixpkgs/dhall-nixpkgs.cabal +++ b/dhall-nixpkgs/dhall-nixpkgs.cabal @@ -30,7 +30,7 @@ Executable dhall-to-nixpkgs , megaparsec >= 7.0.0 && < 10 , mmorph < 1.3 , neat-interpolation < 0.6 - , optparse-applicative >= 0.14.0.0 && < 0.18 + , optparse-applicative >= 0.14.0.0 && < 0.19 , prettyprinter >= 1.7.0 && < 1.8 , text >= 0.11.1.0 && < 2.1 , transformers >= 0.2.0.0 && < 0.6 diff --git a/dhall-openapi/dhall-openapi.cabal b/dhall-openapi/dhall-openapi.cabal index 5c8fd3be2..1bd408c0a 100644 --- a/dhall-openapi/dhall-openapi.cabal +++ b/dhall-openapi/dhall-openapi.cabal @@ -45,8 +45,8 @@ Executable openapi-to-dhall filepath >= 1.4 && < 1.5 , -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 megaparsec >= 7.0 && < 10 , - optparse-applicative >= 0.14.3.0 && < 0.18 , - parser-combinators , + optparse-applicative >= 0.14.3.0 && < 0.19 , + parser-combinators , prettyprinter , sort , text , diff --git a/dhall-toml/dhall-toml.cabal b/dhall-toml/dhall-toml.cabal index 385e83108..a61d620de 100644 --- a/dhall-toml/dhall-toml.cabal +++ b/dhall-toml/dhall-toml.cabal @@ -41,7 +41,7 @@ Library containers >= 0.5.9 && < 0.7 , unordered-containers >= 0.2 && < 0.3 , prettyprinter >= 1.7.0 && < 1.8 , - optparse-applicative >= 0.14 && < 0.18 + optparse-applicative >= 0.14 && < 0.19 Exposed-Modules: Dhall.DhallToToml Dhall.TomlToDhall diff --git a/dhall-yaml/dhall-yaml.cabal b/dhall-yaml/dhall-yaml.cabal index d744aef2c..324a7d0a1 100644 --- a/dhall-yaml/dhall-yaml.cabal +++ b/dhall-yaml/dhall-yaml.cabal @@ -38,7 +38,7 @@ Library bytestring < 0.12, dhall >= 1.31.0 && < 1.43, dhall-json >= 1.6.0 && < 1.8 , - optparse-applicative >= 0.14.0.0 && < 0.18, + optparse-applicative >= 0.14.0.0 && < 0.19, text >= 0.11.1.0 && < 2.1 , vector Exposed-Modules: diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 16ca7cb06..a3be524b8 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -234,7 +234,7 @@ Common common mmorph < 1.3 , mtl >= 2.2.1 && < 2.4 , network-uri >= 2.6 && < 2.7 , - optparse-applicative >= 0.14.0.0 && < 0.18, + optparse-applicative >= 0.14.0.0 && < 0.19, parsers >= 0.12.4 && < 0.13, parser-combinators , prettyprinter >= 1.7.0 && < 1.8 , From df8ff09bec285e34eef77942a26df68e0cab234f Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Thu, 19 Oct 2023 19:39:52 -0700 Subject: [PATCH 09/16] Add several new entrypoints to `Dhall` module (#2534) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds the following four new high-level entrypoints: - `interpretExpr` - `interpretExprWithSettings` - `fromExpr` - `fromExprWithSettings` … as well as several new utilities for running each phase one at a time, respecting `InputSettings`: - `parseWithSettings` - `resolveWithSettings` - `typecheckWithSettings` - `expectWithSettings` - `normalizeWithSettings` This also refactors the other utilities to use those new phase-based settings. The motivation behind this change is to make it easier for people to work with raw `Expr`s, so that people don't need to craft strings when trying to assemble ASTs to interpret like in this issue: https://stackoverflow.com/questions/77037023/is-there-an-elegant-way-to-override-dhall-records-in-haskell --- dhall/src/Dhall.hs | 158 +++++++++++++++++++++++++++++++++------------ 1 file changed, 118 insertions(+), 40 deletions(-) diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index e2d11dcbe..310472647 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -24,6 +24,10 @@ module Dhall , inputFileWithSettings , inputExpr , inputExprWithSettings + , interpretExpr + , interpretExprWithSettings + , fromExpr + , fromExprWithSettings , rootDirectory , sourceName , startingContext @@ -43,6 +47,13 @@ module Dhall -- * Encoders , module Dhall.Marshal.Encode + -- * Individual phases + , parseWithSettings + , resolveWithSettings + , typecheckWithSettings + , expectWithSettings + , normalizeWithSettings + -- * Miscellaneous , rawInput ) where @@ -52,7 +63,7 @@ import Data.Either.Validation (Validation (..)) import Data.Void (Void) import Dhall.Import (Imported (..)) import Dhall.Parser (Src (..)) -import Dhall.Syntax (Expr (..)) +import Dhall.Syntax (Expr (..), Import) import Dhall.TypeCheck (DetailedTypeError (..), TypeError) import GHC.Generics import Lens.Family (LensLike', view) @@ -195,6 +206,68 @@ instance HasEvaluateSettings InputSettings where instance HasEvaluateSettings EvaluateSettings where evaluateSettings = id +-- | Parse an expression, using the supplied `InputSettings` +parseWithSettings :: InputSettings -> Text -> IO (Expr Src Import) +parseWithSettings settings text = do + Core.throws (Dhall.Parser.exprFromText (view sourceName settings) text) + +-- | Type-check an expression, using the supplied `InputSettings` +typecheckWithSettings :: InputSettings -> Expr Src Void -> IO () +typecheckWithSettings settings expression = do + _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) expression) + + return () + +{-| Type-check an expression against a `Decoder`'s expected type, using the + supplied `InputSettings` +-} +expectWithSettings :: InputSettings -> Decoder a -> Expr Src Void -> IO () +expectWithSettings settings Decoder{..} expression = do + expected' <- case expected of + Success x -> return x + Failure e -> Control.Exception.throwIO e + + let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' + + let annotated = case expression of + Note (Src begin end bytes) _ -> + Note (Src begin end bytes') (Annot expression expected') + where + bytes' = bytes <> " : " <> suffix + _ -> + Annot expression expected' + + typecheckWithSettings settings annotated + + return () + +{-| Resolve an expression, using the supplied `InputSettings` + + Note that this also applies any substitutions specified in the + `InputSettings` +-} +resolveWithSettings :: InputSettings -> Expr Src Import -> IO (Expr Src Void) +resolveWithSettings settings expression = do + let InputSettings{..} = settings + + let EvaluateSettings{..} = _evaluateSettings + + let transform = + Lens.Family.set Dhall.Import.substitutions _substitutions + . Lens.Family.set Dhall.Import.normalizer _normalizer + . Lens.Family.set Dhall.Import.startingContext _startingContext + + let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) + + resolved <- State.evalStateT (Dhall.Import.loadWith expression) status + + pure (Dhall.Substitution.substitute resolved (view substitutions settings)) + +-- | Normalize an expression, using the supplied `InputSettings` +normalizeWithSettings :: InputSettings -> Expr Src Void -> Expr Src Void +normalizeWithSettings settings = + Core.normalizeWith (view normalizer settings) + {-| Type-check and evaluate a Dhall program, decoding the result into Haskell The first argument determines the type of value that you decode: @@ -236,24 +309,17 @@ inputWithSettings -- ^ The Dhall program -> IO a -- ^ The decoded value in Haskell -inputWithSettings settings (Decoder {..}) txt = do - expected' <- case expected of - Success x -> return x - Failure e -> Control.Exception.throwIO e +inputWithSettings settings decoder@Decoder{..} text = do + parsed <- parseWithSettings settings text - let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' - let annotate substituted = case substituted of - Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot substituted expected') - where - bytes' = bytes <> " : " <> suffix - _ -> - Annot substituted expected' + resolved <- resolveWithSettings settings parsed - normExpr <- inputHelper annotate settings txt + expectWithSettings settings decoder resolved - case extract normExpr of - Success x -> return x + let normalized = normalizeWithSettings settings resolved + + case extract normalized of + Success x -> return x Failure e -> Control.Exception.throwIO e {-| Type-check and evaluate a Dhall program that is read from the @@ -320,39 +386,51 @@ inputExprWithSettings -- ^ The Dhall program -> IO (Expr Src Void) -- ^ The fully normalized AST -inputExprWithSettings = inputHelper id +inputExprWithSettings settings text = do + parsed <- parseWithSettings settings text + + resolved <- resolveWithSettings settings parsed + + _ <- typecheckWithSettings settings resolved + + pure (Core.normalizeWith (view normalizer settings) resolved) -{-| Helper function for the input* function family +{-| Interpret a Dhall Expression -@since 1.30 + This takes care of import resolution, type-checking, and normalization -} -inputHelper - :: (Expr Src Void -> Expr Src Void) - -> InputSettings - -> Text - -- ^ The Dhall program - -> IO (Expr Src Void) - -- ^ The fully normalized AST -inputHelper annotate settings txt = do - expr <- Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) +interpretExpr :: Expr Src Import -> IO (Expr Src Void) +interpretExpr = interpretExprWithSettings defaultInputSettings - let InputSettings {..} = settings +-- | Like `interpretExpr`, but customizable using `InputSettings` +interpretExprWithSettings + :: InputSettings -> Expr Src Import -> IO (Expr Src Void) +interpretExprWithSettings settings parsed = do + resolved <- resolveWithSettings settings parsed - let EvaluateSettings {..} = _evaluateSettings + typecheckWithSettings settings resolved - let transform = - Lens.Family.set Dhall.Import.substitutions _substitutions - . Lens.Family.set Dhall.Import.normalizer _normalizer - . Lens.Family.set Dhall.Import.startingContext _startingContext + pure (Core.normalizeWith (view normalizer settings) resolved) - let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) +{- | Decode a Dhall expression + + This takes care of import resolution, type-checking and normalization +-} +fromExpr :: Decoder a -> Expr Src Import -> IO a +fromExpr = fromExprWithSettings defaultInputSettings + +-- | Like `fromExpr`, but customizable using `InputSettings` +fromExprWithSettings :: InputSettings -> Decoder a -> Expr Src Import -> IO a +fromExprWithSettings settings decoder@Decoder{..} expression = do + resolved <- resolveWithSettings settings expression - expr' <- State.evalStateT (Dhall.Import.loadWith expr) status + expectWithSettings settings decoder resolved - let substituted = Dhall.Substitution.substitute expr' $ view substitutions settings - let annot = annotate substituted - _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) - pure (Core.normalizeWith (view normalizer settings) substituted) + let normalized = Core.normalizeWith (view normalizer settings) resolved + + case extract normalized of + Success x -> return x + Failure e -> Control.Exception.throwIO e -- | Use this function to extract Haskell values directly from Dhall AST. -- The intended use case is to allow easy extraction of Dhall values for From 251cfe758447472ccfd3f56790f08bbaa864ae00 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 25 Oct 2023 17:20:20 +0200 Subject: [PATCH 10/16] Polymorphic entrypoints (#2544) * Added Dhall.checkWithSettings * Allow running some of the individual stages in pure code --- dhall/src/Dhall.hs | 55 +++++++++++++++++++++++++++++----------------- 1 file changed, 35 insertions(+), 20 deletions(-) diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index 310472647..ca4d6a4b0 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -51,6 +51,7 @@ module Dhall , parseWithSettings , resolveWithSettings , typecheckWithSettings + , checkWithSettings , expectWithSettings , normalizeWithSettings @@ -59,6 +60,7 @@ module Dhall ) where import Control.Applicative (Alternative, empty) +import Control.Monad.Catch (MonadThrow, throwM) import Data.Either.Validation (Validation (..)) import Data.Void (Void) import Dhall.Import (Imported (..)) @@ -207,39 +209,52 @@ instance HasEvaluateSettings EvaluateSettings where evaluateSettings = id -- | Parse an expression, using the supplied `InputSettings` -parseWithSettings :: InputSettings -> Text -> IO (Expr Src Import) -parseWithSettings settings text = do - Core.throws (Dhall.Parser.exprFromText (view sourceName settings) text) +parseWithSettings :: MonadThrow m => InputSettings -> Text -> m (Expr Src Import) +parseWithSettings settings text = + either throwM return (Dhall.Parser.exprFromText (view sourceName settings) text) -- | Type-check an expression, using the supplied `InputSettings` -typecheckWithSettings :: InputSettings -> Expr Src Void -> IO () -typecheckWithSettings settings expression = do - _ <- Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) expression) +typecheckWithSettings :: MonadThrow m => InputSettings -> Expr Src Void -> m () +typecheckWithSettings settings expression = + either throwM (return . const ()) (Dhall.TypeCheck.typeWith (view startingContext settings) expression) - return () - -{-| Type-check an expression against a `Decoder`'s expected type, using the - supplied `InputSettings` +{-| Type-check an expression against a type provided as a Dhall expreession, + using the supplied `InputSettings` -} -expectWithSettings :: InputSettings -> Decoder a -> Expr Src Void -> IO () -expectWithSettings settings Decoder{..} expression = do - expected' <- case expected of - Success x -> return x - Failure e -> Control.Exception.throwIO e - - let suffix = Dhall.Pretty.Internal.prettyToStrictText expected' +checkWithSettings :: + MonadThrow m => + -- | The input settings + InputSettings -> + -- | The expected type of the expression + Expr Src Void -> + -- | The expression to check + Expr Src Void -> + m () +checkWithSettings settings type_ expression = do + let suffix = Dhall.Pretty.Internal.prettyToStrictText type_ let annotated = case expression of Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot expression expected') + Note (Src begin end bytes') (Annot expression type_) where bytes' = bytes <> " : " <> suffix _ -> - Annot expression expected' + Annot expression type_ typecheckWithSettings settings annotated - return () +{-| Type-check an expression against a `Decoder`'s expected type, using the + supplied `InputSettings`. + This is equivalent of using the 'expected' type of a @Decoder@ as the second + argument to 'checkWithSettings'. +-} +expectWithSettings :: MonadThrow m => InputSettings -> Decoder a -> Expr Src Void -> m () +expectWithSettings settings Decoder{..} expression = do + expected' <- case expected of + Success x -> return x + Failure e -> throwM e + + checkWithSettings settings expected' expression {-| Resolve an expression, using the supplied `InputSettings` From 2b3a6bc48e85224c930e02bec6c0aae2291e4e90 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Sun, 5 Nov 2023 21:46:26 -0800 Subject: [PATCH 11/16] =?UTF-8?q?Version=201.42.0=20=E2=86=92=201.42.1=20(?= =?UTF-8?q?#2545)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- dhall/CHANGELOG.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/dhall/CHANGELOG.md b/dhall/CHANGELOG.md index fdeea7975..3d0b5289f 100644 --- a/dhall/CHANGELOG.md +++ b/dhall/CHANGELOG.md @@ -1,3 +1,13 @@ +1.42.1 + +* Add several new entrypoints to `Dhall` module [[#2534](https://github.com/dhall-lang/dhall-haskell/pull/2534)] / [[#2544](https://github.com/dhall-lang/dhall-haskell/pull/2544)] +* Build against latest versions of: + * [`ansi-terminal`](https://github.com/dhall-lang/dhall-haskell/pull/2521) + * [`optparse-applicative`](https://github.com/dhall-lang/dhall-haskell/pull/2543) + * [`optparse-generic`](https://github.com/dhall-lang/dhall-haskell/pull/2519) + * [`lens`](https://github.com/dhall-lang/dhall-haskell/pull/2539) + * `template-haskell` [[#2532](https://github.com/dhall-lang/dhall-haskell/pull/2532)] / [[#2542](https://github.com/dhall-lang/dhall-haskell/pull/2542)] + * [`unix-compat`](https://github.com/dhall-lang/dhall-haskell/pull/2532) 1.42.0 * [Supports standard version 23.0.0](https://github.com/dhall-lang/dhall-lang/releases/tag/v23.0.0) From 5d4391ce498ecab73b9b98243fd698c38576266f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Kukie=C5=82a?= <53443372+kukimik@users.noreply.github.com> Date: Mon, 20 Nov 2023 04:38:25 +0100 Subject: [PATCH 12/16] Allow Natural and Integer literals in binary notation (#2540) --- dhall/src/Dhall/Parser/Token.hs | 5 ++++- dhall/tests/format/numericLiteralsA.dhall | 2 +- dhall/tests/format/numericLiteralsB.dhall | 2 +- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/dhall/src/Dhall/Parser/Token.hs b/dhall/src/Dhall/Parser/Token.hs index db7e1a629..e17dff164 100644 --- a/dhall/src/Dhall/Parser/Token.hs +++ b/dhall/src/Dhall/Parser/Token.hs @@ -299,11 +299,14 @@ integerLiteral = (do -} naturalLiteral :: Parser Natural naturalLiteral = (do - a <- try (char '0' >> char 'x' >> Text.Megaparsec.Char.Lexer.hexadecimal) + a <- binary + <|> hexadecimal <|> decimal <|> (char '0' $> 0) return a ) "literal" where + binary = try (char '0' >> char 'b' >> Text.Megaparsec.Char.Lexer.binary) + hexadecimal = try (char '0' >> char 'x' >> Text.Megaparsec.Char.Lexer.hexadecimal) decimal = do n <- headDigit ns <- many tailDigit diff --git a/dhall/tests/format/numericLiteralsA.dhall b/dhall/tests/format/numericLiteralsA.dhall index 578ad271e..7a585a3d7 100644 --- a/dhall/tests/format/numericLiteralsA.dhall +++ b/dhall/tests/format/numericLiteralsA.dhall @@ -1 +1 @@ -{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20 } +{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20, example3 = -0b0111 } diff --git a/dhall/tests/format/numericLiteralsB.dhall b/dhall/tests/format/numericLiteralsB.dhall index 578ad271e..7a585a3d7 100644 --- a/dhall/tests/format/numericLiteralsB.dhall +++ b/dhall/tests/format/numericLiteralsB.dhall @@ -1 +1 @@ -{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20 } +{ example0 = 0x42, example1 = +0x42, example2 = 1.2e20, example3 = -0b0111 } From 53585c984d8bde2206f20f6449d5972d25ace7d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Kukie=C5=82a?= <53443372+kukimik@users.noreply.github.com> Date: Mon, 20 Nov 2023 06:09:06 +0100 Subject: [PATCH 13/16] doc fix: Integers are no longer opaque (#2546) --- dhall/src/Dhall/Tutorial.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/dhall/src/Dhall/Tutorial.hs b/dhall/src/Dhall/Tutorial.hs index 8560d0e2c..ad7cc7ebe 100644 --- a/dhall/src/Dhall/Tutorial.hs +++ b/dhall/src/Dhall/Tutorial.hs @@ -1882,9 +1882,13 @@ import Dhall -- > -- > (input):1:1 -- --- In fact, there are no built-in functions for @Integer@s (or @Double@s) other --- than @Integer/show@ and @Double/show@. As far as the language is concerned --- they are opaque values that can only be shuffled around but not used in any +-- There are no built-in functions for @Integer@ arithmetic; however, conversion +-- to and from @Natural@s is possible usinng @Integer/clamp@, @Integer/negate@ +-- and @Natural/toInteger@. +-- +-- For @Double@s the situation is even more extreme: there are no built-in +-- functions other than @Double/show@. As far as the language is concerned they +-- are opaque values that can only be shuffled around but not used in any -- meaningful way until they have been loaded into Haskell. -- -- Second, the equality @(==)@ and inequality @(!=)@ operators only work on From e8c87905f9d143273052f1cddc069f5c55ea574d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Kukie=C5=82a?= <53443372+kukimik@users.noreply.github.com> Date: Tue, 21 Nov 2023 00:41:46 +0100 Subject: [PATCH 14/16] Import fileAnIssue from Dhall.Docs.Util (#2547) * Import fileAnIssue from Dhall.Docs.Util * Fix typo --- dhall-docs/src/Dhall/Docs/Core.hs | 21 +-------------------- dhall-docs/src/Dhall/Docs/Util.hs | 2 +- 2 files changed, 2 insertions(+), 21 deletions(-) diff --git a/dhall-docs/src/Dhall/Docs/Core.hs b/dhall-docs/src/Dhall/Docs/Core.hs index dabf06243..ad93b516b 100644 --- a/dhall-docs/src/Dhall/Docs/Core.hs +++ b/dhall-docs/src/Dhall/Docs/Core.hs @@ -44,6 +44,7 @@ import Dhall.Docs.Embedded import Dhall.Docs.Html import Dhall.Docs.Markdown import Dhall.Docs.Store +import Dhall.Docs.Util (fileAnIssue) import Dhall.Parser ( Header (..) , ParseError (..) @@ -439,26 +440,6 @@ addHtmlExt :: Path Rel File -> Path Rel File addHtmlExt relFile = Data.Maybe.fromMaybe (fileAnIssue "addHtmlExt") $ Path.addExtension ".html" relFile --- | If you're wondering the GitHub query params for issue creation: --- https://docs.github.com/en/github/managing-your-work-on-github/about-automation-for-issues-and-pull-requests-with-query-parameters -fileAnIssue :: Text -> a -fileAnIssue titleName = - error $ "\ESC[1;31mError\ESC[0m Documentation generator bug\n\n" <> - - "Explanation: This error message means that there is a bug in the " <> - "Dhall Documentation generator. You didn't did anything wrong, but " <> - "if you would like to see this problem fixed then you should report " <> - "the bug at:\n\n" <> - - "https://github.com/dhall-lang/dhall-haskell/issues/new?labels=dhall-docs,bug\n\n" <> - - "explaining your issue and add \"" <> Data.Text.unpack titleName <> "\" as error code " <> - "so we can find the proper location in the source code where the error happened\n\n" <> - - "Please, also include your package in the issue. It can be in:\n\n" <> - "* A compressed archive (zip, tar, etc)\n" <> - "* A git repository, preferably with a commit reference" - {-| Generate all of the docs for a package. This function does all the `IO ()` related tasks to call `generateDocsPure` -} diff --git a/dhall-docs/src/Dhall/Docs/Util.hs b/dhall-docs/src/Dhall/Docs/Util.hs index c661c4cf9..10ee0473c 100644 --- a/dhall-docs/src/Dhall/Docs/Util.hs +++ b/dhall-docs/src/Dhall/Docs/Util.hs @@ -12,7 +12,7 @@ fileAnIssue titleName = error $ "\ESC[1;31mError\ESC[0m Documentation generator bug\n\n" <> "Explanation: This error message means that there is a bug in the " <> - "Dhall Documentation generator. You didn't did anything wrong, but " <> + "Dhall Documentation generator. You didn't do anything wrong, but " <> "if you would like to see this problem fixed then you should report " <> "the bug at:\n\n" <> From c8fbc378674caef9654c9d8a82787bfe7538ea6f Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Tue, 21 Nov 2023 14:54:26 -0800 Subject: [PATCH 15/16] Refactor `dhall-toml` code (#2548) This is a (mostly) behavior-preserving refactor of the `dhall-toml` package since I was planning on working on #2509 and wanted to first refactor the code a bit more to my liking. The only actual change is that the `Show` instance for `CompilerError` is now the derived one and I moved that logic to the `displayException` method. --- dhall-toml/src/Dhall/DhallToToml.hs | 323 +++++++++++++++----------- dhall-toml/src/Dhall/TomlToDhall.hs | 346 ++++++++++++++++------------ 2 files changed, 381 insertions(+), 288 deletions(-) diff --git a/dhall-toml/src/Dhall/DhallToToml.hs b/dhall-toml/src/Dhall/DhallToToml.hs index 2b248e527..12ae146a6 100644 --- a/dhall-toml/src/Dhall/DhallToToml.hs +++ b/dhall-toml/src/Dhall/DhallToToml.hs @@ -103,7 +103,7 @@ module Dhall.DhallToToml , CompileError ) where -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception) import Control.Monad (foldM) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty ((:|))) @@ -111,13 +111,14 @@ import Data.Text (Text) import Data.Version (showVersion) import Data.Void (Void) import Dhall.Core (DhallDouble (..), Expr) +import Dhall.Map (Map) import Dhall.Toml.Utils (fileToDhall, inputToDhall) import Prettyprinter (Pretty) -import Toml.Type.Key (Key (Key, unKey), Piece (Piece)) -import Toml.Type.Printer (pretty) +import Toml.Type.Key (Key(..), Piece (Piece)) +import Toml.Type.AnyValue (AnyValue(..)) import Toml.Type.TOML (TOML) -import qualified Data.Bifunctor as Bifunctor +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO @@ -125,12 +126,13 @@ import qualified Dhall.Core as Core import qualified Dhall.Map as Map import qualified Dhall.Pretty import qualified Dhall.Util -import qualified Options.Applicative as OA +import qualified Options.Applicative as Options import qualified Paths_dhall_toml as Meta import qualified Prettyprinter.Render.Text as Pretty -import qualified Toml.Type.AnyValue as Toml.AnyValue -import qualified Toml.Type.TOML as Toml.TOML -import qualified Toml.Type.Value as Toml.Value +import qualified Toml.Type.AnyValue as AnyValue +import qualified Toml.Type.Printer as Printer +import qualified Toml.Type.TOML as TOML +import qualified Toml.Type.Value as Value -- $setup -- @@ -226,15 +228,15 @@ insert = Text.unpack . Pretty.renderStrict . Dhall.Pretty.layout . Dhall.Util.in >>> import Toml.Type.Printer >>> f = makeRecordField >>> let toml = dhallToToml $ RecordLit [("foo", f $ NaturalLit 1), ("bar", f $ TextLit "ABC")] ->>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Toml.Value.Integer 1)),("bar",AnyValue (Toml.Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []}) +>>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Value.Integer 1)),("bar",AnyValue (Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []}) True >>> fmap Toml.Type.Printer.pretty toml Right "bar = \"ABC\"\nfoo = 1\n" -} dhallToToml :: Expr s Void -> Either CompileError TOML -dhallToToml e0 = do - r <- assertRecordLit (Core.normalize e0) - toTomlTable r +dhallToToml expression = do + record <- assertRecordLit (Core.normalize expression) + toTomlTable record -- empty union alternative like < A | B >.A pattern UnionEmpty :: Text -> Expr s a @@ -243,158 +245,201 @@ pattern UnionEmpty x <- Core.Field (Core.Union _) (Core.FieldSelection _ x _) pattern UnionApp :: Expr s a -> Expr s a pattern UnionApp x <- Core.App (Core.Field (Core.Union _) _) x -assertRecordLit :: Expr Void Void -> Either CompileError (Map.Map Text (Core.RecordField Void Void)) +assertRecordLit + :: Expr Void Void + -> Either CompileError (Map Text (Core.RecordField Void Void)) assertRecordLit (Core.RecordLit r) = Right r assertRecordLit (UnionApp x) = assertRecordLit x assertRecordLit e = Left $ NotARecord e -toTomlTable :: Map.Map Text (Core.RecordField Void Void) -> Either CompileError TOML +toTomlTable :: Map Text (Core.RecordField Void Void) -> Either CompileError TOML toTomlTable r = foldM (toTomlRecordFold []) (mempty :: TOML) (Map.toList r) -toTomlRecordFold :: [Piece] -> TOML -> (Text, Core.RecordField Void Void) -> Either CompileError TOML -toTomlRecordFold curKey toml' (key', val) = toToml toml' newKey (Core.recordFieldValue val) - where - append :: [Piece] -> Piece -> NonEmpty Piece - append [] y = y :| [] - append (x:xs) y = x :| xs ++ [y] - newKey = Key $ append curKey $ Piece key' - - - -toToml :: TOML -> Key -> Expr Void Void -> Either CompileError TOML -toToml toml key expr = case expr of - Core.BoolLit a -> return $ insertPrim (Toml.Value.Bool a) - Core.NaturalLit a -> return $ insertPrim (Toml.Value.Integer $ toInteger a) - Core.IntegerLit a -> return $ insertPrim (Toml.Value.Integer a) - Core.DoubleLit (DhallDouble a) -> return $ insertPrim (Toml.Value.Double a) - Core.TextLit (Core.Chunks [] a) -> return $ insertPrim (Toml.Value.Text a) - Core.App Core.None _ -> return toml - Core.Some a -> toToml toml key a - UnionEmpty a -> return $ insertPrim (Toml.Value.Text a) - UnionApp a -> toToml toml key a +toTomlRecordFold + :: [Piece] + -> TOML + -> (Text, Core.RecordField Void Void) + -> Either CompileError TOML +toTomlRecordFold curKey toml (key, val) = + toToml toml (Piece key :| curKey) (Core.recordFieldValue val) + +toToml :: TOML -> NonEmpty Piece -> Expr Void Void -> Either CompileError TOML +toToml toml pieces expr = case expr of + Core.BoolLit a -> + insertPrim (Value.Bool a) + + Core.NaturalLit a -> + insertPrim (Value.Integer (toInteger a)) + + Core.IntegerLit a -> + insertPrim (Value.Integer a) + + Core.DoubleLit (DhallDouble a) -> + insertPrim (Value.Double a) + + Core.TextLit (Core.Chunks [] a) -> + insertPrim (Value.Text a) + + UnionEmpty a -> + insertPrim (Value.Text a) + + UnionApp a -> + toToml toml pieces a + + Core.Some a -> + toToml toml pieces a + + Core.App Core.None _ -> + return toml + Core.ListLit _ a -> case toList a of - -- empty array - [] -> return $ insertPrim (Toml.Value.Array []) -- TODO: unions need to be handled here as well, it's a bit tricky -- because they also have to be probed for being a "simple" -- array of table union@(UnionApp (Core.RecordLit _)) : unions -> do - tables' <- case mapM assertRecordLit (union :| unions) of - Right x -> mapM toTomlTable x - Left (NotARecord e) -> Left (HeterogeneousArray e) - Left x -> Left x - return $ Toml.TOML.insertTableArrays key tables' toml + insertTables (union :| unions) record@(Core.RecordLit _) : records -> do - tables' <- case mapM assertRecordLit (record :| records) of - Right x -> mapM toTomlTable x - Left (NotARecord e) -> Left (HeterogeneousArray e) - Left x -> Left x - return $ Toml.TOML.insertTableArrays key tables' toml + insertTables (record :| records) + -- inline array - a' -> do - anyList <- mapM toAny a' - let arrayEither = Toml.AnyValue.toMArray anyList - array <- Bifunctor.first (const $ HeterogeneousArray expr) arrayEither - return $ insertPrim array - Core.RecordLit r -> - let - (inline, nested) = Map.partition (isInline . Core.recordFieldValue) r - in - if null inline - -- if the table doesn't have inline elements, don't register - -- the table, only its non-inlined children. Ex: - -- [a] # bad - -- [b] - -- c = 1 - -- [a.b] # good - -- c = 1 - then foldM (toTomlRecordFold $ toList $ unKey key) toml (Map.toList nested) - else do - -- the order here is important, at least for testing, because - -- the PrefixMap inside TOML is dependent on insert order - inlinePairs <- foldM (toTomlRecordFold []) mempty (Map.toList inline) - nestedPairs <- foldM (toTomlRecordFold []) inlinePairs (Map.toList nested) - return $ Toml.TOML.insertTable key nestedPairs toml - _ -> Left $ Unsupported expr - where - insertPrim :: Toml.Value.Value a -> TOML - insertPrim val = Toml.TOML.insertKeyVal key val toml - - -- checks if the value should be represented as an inline key/value - -- pair. Elements that are inlined are those that do not have a - -- [header] or [[header]]. One edge case is tables within multiple - -- arrays, though not currently supported by tomland, can only - -- be represented as inline tables. - isInline v = case v of - Core.BoolLit _ -> True - Core.IntegerLit _ -> True - Core.NaturalLit _ -> True - Core.DoubleLit _ -> True - Core.TextLit _ -> True - Core.ListLit _ s -> case Seq.lookup 0 s of - Nothing -> True - Just (Core.BoolLit _) -> True - Just (Core.NaturalLit _) -> True - Just (Core.DoubleLit _) -> True - Just (Core.TextLit _) -> True - Just (Core.ListLit _ _) -> True - _ -> False - _ -> False - - rightAny = Right . Toml.AnyValue.AnyValue - - -- toAny is a helper function for making lists so it returns a list - -- specific error, in particular tomland's inability to represent - -- tables in multi-dimensional arrays - toAny :: Expr Void Void -> Either CompileError Toml.AnyValue.AnyValue - toAny e = case e of - Core.BoolLit x -> rightAny $ Toml.Value.Bool x - Core.IntegerLit x -> rightAny $ Toml.Value.Integer x - Core.NaturalLit x -> rightAny $ Toml.Value.Integer $ toInteger x - Core.DoubleLit (DhallDouble x) -> rightAny $ Toml.Value.Double x - Core.TextLit (Core.Chunks [] x) -> rightAny $ Toml.Value.Text x - UnionEmpty x -> rightAny $ Toml.Value.Text x - UnionApp x -> toAny x - Core.ListLit _ x -> do - anyList <- mapM toAny $ toList x - case Toml.AnyValue.toMArray anyList of - Right x' -> rightAny x' - Left _ -> Left $ HeterogeneousArray expr - Core.RecordLit _ -> Left $ UnsupportedArray e - _ -> Left $ Unsupported e + expressions -> do + anyValues <- mapM toAnyValue expressions + + case AnyValue.toMArray anyValues of + Left _ -> Left (HeterogeneousArray expr) + Right array -> insertPrim array + + Core.RecordLit r -> do + let (inline, nested) = + Map.partition (isInline . Core.recordFieldValue) r + + -- the order here is important, at least for testing, because the + -- PrefixMap inside TOML is dependent on insert order + let pairs = Map.toList inline <> Map.toList nested + + if null inline + -- if the table doesn't have inline elements, don't register the table, + -- only its non-inlined children. Ex: + -- [a] # bad + -- [b] + -- c = 1 + -- [a.b] # good + -- c = 1 + then do + foldM (toTomlRecordFold (toList pieces)) toml pairs + else do + newPairs <- foldM (toTomlRecordFold []) mempty pairs + return (TOML.insertTable key newPairs toml) + _ -> + Left (Unsupported expr) + where + key :: Key + key = Key (NonEmpty.reverse pieces) + + insertPrim :: Value.Value a -> Either CompileError TOML + insertPrim val = return (TOML.insertKeyVal key val toml) + + insertTables :: NonEmpty (Expr Void Void) -> Either CompileError TOML + insertTables expressions = do + tables <- case mapM assertRecordLit expressions of + Right x -> mapM toTomlTable x + Left (NotARecord e) -> Left (HeterogeneousArray e) + Left x -> Left x + return (TOML.insertTableArrays key tables toml) + + -- checks if the value should be represented as an inline key/value pair. + -- Elements that are inlined are those that do not have a [header] or + -- [[header]]. One edge case is tables within multiple arrays, though not + -- currently supported by tomland, can only be represented as inline tables. + isInline v = case v of + Core.BoolLit _ -> True + Core.IntegerLit _ -> True + Core.NaturalLit _ -> True + Core.DoubleLit _ -> True + Core.TextLit _ -> True + Core.ListLit _ s -> case Seq.lookup 0 s of + Nothing -> True + Just (Core.BoolLit _) -> True + Just (Core.NaturalLit _) -> True + Just (Core.DoubleLit _) -> True + Just (Core.TextLit _) -> True + Just (Core.ListLit _ _) -> True + _ -> False + _ -> False + + -- toAnyValue is a helper function for making lists so it returns a list + -- specific error, in particular tomland's inability to represent tables in + -- multi-dimensional arrays + toAnyValue :: Expr Void Void -> Either CompileError AnyValue + toAnyValue expression = case expression of + Core.BoolLit x -> + Right (AnyValue (Value.Bool x)) + Core.IntegerLit x -> + Right (AnyValue (Value.Integer x)) + Core.NaturalLit x -> + Right (AnyValue (Value.Integer (toInteger x))) + Core.DoubleLit (DhallDouble x) -> + Right (AnyValue (Value.Double x)) + Core.TextLit (Core.Chunks [] x) -> + Right (AnyValue (Value.Text x)) + UnionEmpty x -> + Right (AnyValue (Value.Text x)) + UnionApp x -> + toAnyValue x + Core.ListLit _ x -> do + anyList <- mapM toAnyValue (toList x) + case AnyValue.toMArray anyList of + Right x' -> Right (AnyValue x') + Left _ -> Left (HeterogeneousArray expr) + Core.RecordLit _ -> + Left (UnsupportedArray expression) + _ -> + Left (Unsupported expression) data Options = Options { input :: Maybe FilePath , output :: Maybe FilePath } -parserInfo :: OA.ParserInfo Options -parserInfo = OA.info - (OA.helper <*> versionOption <*> optionsParser) - (OA.fullDesc <> OA.progDesc "Convert Dhall to TOML") +parserInfo :: Options.ParserInfo Options +parserInfo = Options.info + (Options.helper <*> versionOption <*> optionsParser) + (Options.fullDesc <> Options.progDesc "Convert Dhall to TOML") where - versionOption = OA.infoOption (showVersion Meta.version) $ - OA.long "version" <> OA.help "Display version" + versionOption = + Options.infoOption (showVersion Meta.version) + (Options.long "version" <> Options.help "Display version") + optionsParser = do - input <- OA.optional . OA.strOption $ - OA.long "file" - <> OA.help "Read Dhall from file instead of standard input" - <> fileOpts - output <- OA.optional . OA.strOption $ - OA.long "output" - <> OA.help "Write TOML to a file instead of standard output" - <> fileOpts - pure Options {..} - fileOpts = OA.metavar "FILE" <> OA.action "file" + input <- (Options.optional . Options.strOption) + ( Options.long "file" + <> Options.help "Read Dhall from file instead of standard input" + <> Options.metavar "FILE" + <> Options.action "file" + ) + + output <- (Options.optional . Options.strOption) + ( Options.long "output" + <> Options.help "Write TOML to a file instead of standard output" + <> Options.metavar "FILE" + <> Options.action "file" + ) + + pure Options{..} {-| Runs the @dhall-to-toml@ command -} dhallToTomlMain :: IO () dhallToTomlMain = do - Options {..} <- OA.execParser parserInfo + Options{..} <- Options.execParser parserInfo + resolvedExpression <- maybe inputToDhall fileToDhall input - toml <- case dhallToToml resolvedExpression of - Left err -> throwIO err - Right toml -> return toml - maybe Text.IO.putStrLn Text.IO.writeFile output $ pretty toml + + toml <- Core.throws (dhallToToml resolvedExpression) + + let text = Printer.pretty toml + + case output of + Just file -> Text.IO.writeFile file text + Nothing -> Text.IO.putStrLn text diff --git a/dhall-toml/src/Dhall/TomlToDhall.hs b/dhall-toml/src/Dhall/TomlToDhall.hs index d189b7ab9..c545b3446 100644 --- a/dhall-toml/src/Dhall/TomlToDhall.hs +++ b/dhall-toml/src/Dhall/TomlToDhall.hs @@ -118,35 +118,34 @@ module Dhall.TomlToDhall , CompileError ) where -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception(..)) +import Data.Bifunctor (first) import Data.Either (rights) -import Data.Foldable (foldl', toList) +import Data.Foldable (fold, toList) +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Text (Text) import Data.Version (showVersion) import Data.Void (Void) import Dhall.Core (DhallDouble (..), Expr) import Dhall.Parser (Src) import Dhall.Toml.Utils (fileToDhall) import Toml.Parser (TomlParseError) -import Toml.Type.AnyValue (AnyValue (AnyValue)) -import Toml.Type.Key (Key (Key), Piece (Piece)) -import Toml.Type.PrefixTree (PrefixTree) +import Toml.Type.AnyValue (AnyValue(..)) +import Toml.Type.Key (Key(..), Piece(..)) +import Toml.Type.PrefixTree (PrefixMap, PrefixTree(..)) import Toml.Type.TOML (TOML) import Toml.Type.Value (Value) import qualified Data.HashMap.Strict as HashMap import qualified Data.Sequence as Seq -import qualified Data.Text +import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Core as Core import qualified Dhall.Map as Map -import qualified Options.Applicative as OA +import qualified Options.Applicative as Options import qualified Paths_dhall_toml as Meta import qualified Toml.Parser -import qualified Toml.Type.AnyValue as Toml.AnyValue -import qualified Toml.Type.PrefixTree as Toml.PrefixTree -import qualified Toml.Type.TOML as Toml.TOML +import qualified Toml.Type.TOML as TOML import qualified Toml.Type.Value as Value data CompileError @@ -155,150 +154,186 @@ data CompileError | InvalidToml TomlParseError | InternalError String | MissingKey String + deriving (Show) -instance Show CompileError where - show (Unimplemented s) = "unimplemented: " ++ s - show (Incompatible e toml) = "incompatible: " ++ (show e) ++ " with " ++ (show toml) - show (InvalidToml e) = "invalid TOML:\n" ++ (Data.Text.unpack $ Toml.Parser.unTomlParseError e) - show (InternalError e) = "internal error: " ++ show e - show (MissingKey e) = "missing key: " ++ show e - -instance Exception CompileError +instance Exception CompileError where + displayException exception = case exception of + Unimplemented s -> + "unimplemented: " <> s + Incompatible e toml -> + "incompatible: " <> show e <> " with " <> show toml + InvalidToml e -> + "invalid TOML:\n" <> Text.unpack (Toml.Parser.unTomlParseError e) + InternalError e -> + "internal error: " <> show e + MissingKey e -> + "missing key: " <> show e tomlToDhall :: Expr Src Void -> TOML -> Either CompileError (Expr Src Void) -tomlToDhall schema toml = toDhall (Core.normalize schema) (tomlToObject toml) - -tomlValueToDhall :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void) -tomlValueToDhall exprType v = case (exprType, v) of - (Core.Bool , Value.Bool a ) -> Right $ Core.BoolLit a - (Core.Integer , Value.Integer a) -> Right $ Core.IntegerLit a - (Core.Natural , Value.Integer a) -> Right $ Core.NaturalLit $ fromInteger a - (Core.Double , Value.Double a ) -> Right $ Core.DoubleLit $ DhallDouble a - (Core.Text , Value.Text a ) -> Right $ Core.TextLit $ Core.Chunks [] a - (_ , Value.Zoned _ ) -> Left $ Unimplemented "toml time values" - (_ , Value.Local _ ) -> Left $ Unimplemented "toml time values" - (_ , Value.Day _ ) -> Left $ Unimplemented "toml time values" - (t@(Core.App Core.List _) , Value.Array [] ) -> Right $ Core.ListLit (Just t) [] - (Core.App Core.Optional t , a ) -> do - o <- tomlValueToDhall t a - return $ Core.Some o - (Core.App Core.List t , Value.Array a ) -> do - l <- mapM (tomlValueToDhall t) a - return $ Core.ListLit Nothing (Seq.fromList l) +tomlToDhall schema toml = objectToDhall (Core.normalize schema) (tomlToObject toml) - -- TODO: allow different types of matching (ex. first, strict, none) - -- currently we just pick the first enum that matches - (Core.Union m , _) -> let - f key maybeType = case maybeType of - Just ty -> do - expr <- tomlValueToDhall ty v - return $ Core.App (Core.Field exprType $ Core.makeFieldSelection key) expr - Nothing -> case v of - Value.Text a | a == key -> - return $ Core.Field exprType (Core.makeFieldSelection a) - _ -> Left $ Incompatible exprType (Prim (AnyValue v)) - - in case rights (toList (Map.mapWithKey f m)) of - [] -> Left $ Incompatible exprType (Prim (AnyValue v)) - x:_ -> Right $ x - - _ -> Left $ Incompatible exprType (Prim (AnyValue v)) +valueToDhall + :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void) +valueToDhall type_ value = case (type_, value) of + (Core.Bool, Value.Bool a) -> + Right (Core.BoolLit a) --- TODO: keep track of the path for more helpful error messages -toDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void) -toDhall exprType value = case (exprType, value) of - (_, Invalid) -> Left $ InternalError "invalid object" + (Core.Integer, Value.Integer a) -> + Right (Core.IntegerLit a) - -- TODO: allow different types of matching (ex. first, strict, none) - -- currently we just pick the first enum that matches - (Core.Union m , _) -> let - f key maybeType = case maybeType of - Just ty -> do - expr <- toDhall ty value - return $ Core.App (Core.Field exprType $ Core.makeFieldSelection key) expr - Nothing -> case value of - Prim (AnyValue (Value.Text a)) | a == key -> - return $ Core.Field exprType (Core.makeFieldSelection a) - _ -> Left $ Incompatible exprType value + (Core.Natural, Value.Integer a) -> + Right (Core.NaturalLit (fromInteger a)) - in case rights (toList (Map.mapWithKey f m)) of - [] -> Left $ Incompatible exprType value - x:_ -> Right $ x + (Core.Double, Value.Double a) -> + Right (Core.DoubleLit (DhallDouble a)) - (Core.App Core.List t, Array []) -> Right $ Core.ListLit (Just t) [] + (Core.Text, Value.Text a) -> + Right (Core.TextLit (Core.Chunks [] a)) - (Core.App Core.List t, Array a) -> do - l <- mapM (toDhall t) a - return $ Core.ListLit Nothing (Seq.fromList l) + (_, Value.Zoned _) -> + Left (Unimplemented "toml time values") - (Core.Record r, Table t) -> let - f :: Text -> (Expr Src Void) -> Either CompileError (Expr Src Void) - f k ty | Just val <- HashMap.lookup (Piece k) t = toDhall ty val - | Core.App Core.Optional ty' <- ty = Right $ (Core.App Core.None ty') - | Core.App Core.List _ <- ty = Right $ Core.ListLit (Just ty) [] - | otherwise = Left $ MissingKey $ Data.Text.unpack k - in do - values <- Map.traverseWithKey f (Core.recordFieldValue <$> r) - return $ Core.RecordLit (Core.makeRecordField <$> values) + (_, Value.Local _) -> + Left (Unimplemented "toml time values") - (_, Prim (AnyValue v)) -> tomlValueToDhall exprType v + (_, Value.Day _) -> + Left (Unimplemented "toml time values") - (ty, obj) -> Left $ Incompatible ty obj + (Core.App Core.List _, Value.Array [] ) -> + Right (Core.ListLit (Just type_) []) + (Core.App Core.Optional t, a) -> do + o <- valueToDhall t a + return (Core.Some o) + + (Core.App Core.List elementType, Value.Array elements) -> do + expressions <- mapM (valueToDhall elementType) elements + return (Core.ListLit Nothing (Seq.fromList expressions)) + + -- TODO: allow different types of matching (ex. first, strict, none) + -- currently we just pick the first enum that matches + (Core.Union m, _) -> do + let f key maybeAlternativeType = case maybeAlternativeType of + Just alternativeType -> do + expression <- valueToDhall alternativeType value + return (Core.App (Core.Field type_ (Core.makeFieldSelection key)) expression) + Nothing -> case value of + Value.Text a | a == key -> + return (Core.Field type_ (Core.makeFieldSelection a)) + _ -> Left (Incompatible type_ (Prim (AnyValue value))) + + case rights (toList (Map.mapWithKey f m)) of + [] -> Left (Incompatible type_ (Prim (AnyValue value))) + x : _ -> Right x + + _ -> + Left (Incompatible type_ (Prim (AnyValue value))) + +-- TODO: keep track of the path for more helpful error messages +objectToDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void) +objectToDhall type_ object = case (type_, object) of + (_, Invalid) -> Left (InternalError "invalid object") + + -- TODO: allow different types of matching (ex. first, strict, none) + -- currently we just pick the first enum that matches + (Core.Union m, _) -> do + let f key maybeAlternativeType = case maybeAlternativeType of + Just alternativeType -> do + expression <- objectToDhall alternativeType object + return (Core.App (Core.Field type_ (Core.makeFieldSelection key)) expression) + Nothing -> case object of + Prim (AnyValue (Value.Text a)) | a == key -> + return (Core.Field type_ (Core.makeFieldSelection a)) + _ -> Left (Incompatible type_ object) + + case rights (toList (Map.mapWithKey f m)) of + [] -> Left (Incompatible type_ object) + x : _ -> Right x + + (Core.App Core.List t, Array []) -> + Right (Core.ListLit (Just t) []) + + (Core.App Core.List t, Array elements) -> do + expressions <- mapM (objectToDhall t) elements + return (Core.ListLit Nothing (Seq.fromList expressions)) + + (Core.Record record, Table table) -> do + let process key fieldType + | Just nestedObject <- HashMap.lookup (Piece key) table = + objectToDhall fieldType nestedObject + | Core.App Core.Optional innerType <- fieldType = + Right (Core.App Core.None innerType) + | Core.App Core.List _ <- fieldType = + Right (Core.ListLit (Just fieldType) []) + | otherwise = + Left (MissingKey (Text.unpack key)) + + expressions <- Map.traverseWithKey process (fmap Core.recordFieldValue record) + + return (Core.RecordLit (fmap Core.makeRecordField expressions)) + + (_, Prim (AnyValue value)) -> + valueToDhall type_ value + + (_, obj) -> + Left (Incompatible type_ obj) -- | An intermediate object created from a 'TOML' before an 'Expr'. -- It does two things, firstly joining the tomlPairs, tomlTables, -- and tomlTableArrays parts of the TOML. Second, it turns the dense -- paths (ex. a.b.c = 1) into sparse paths (ex. a = { b = { c = 1 }}). data Object - = Prim Toml.AnyValue.AnyValue + = Prim AnyValue | Array [Object] - | Table (HashMap.HashMap Piece Object) + | Table (HashMap Piece Object) | Invalid deriving (Show) instance Semigroup Object where - (Table ls) <> (Table rs) = Table (ls <> rs) + Table ls <> Table rs = Table (ls <> rs) -- this shouldn't happen because tomland has already verified correctness -- of the toml object _ <> _ = Invalid +instance Monoid Object where + mempty = Table HashMap.empty + -- | Creates an arbitrarily nested object sparseObject :: Key -> Object -> Object -sparseObject (Key (piece :| [])) value = Table $ HashMap.singleton piece value -sparseObject (Key (piece :| rest:rest')) value - = Table $ HashMap.singleton piece (sparseObject (Key $ rest :| rest') value) - -pairsToObject :: HashMap.HashMap Key Toml.AnyValue.AnyValue -> Object -pairsToObject pairs - = foldl' (<>) (Table HashMap.empty) - $ HashMap.mapWithKey sparseObject - $ fmap Prim pairs - -tablesToObject :: Toml.PrefixTree.PrefixMap TOML -> Object -tablesToObject tables - = foldl' (<>) (Table HashMap.empty) - $ map prefixTreeToObject - $ HashMap.elems tables +sparseObject (Key (piece :| [])) value = + Table (HashMap.singleton piece value) +sparseObject (Key (piece :| piece' : pieces)) value = + Table (HashMap.singleton piece (sparseObject (Key (piece' :| pieces)) value)) -prefixTreeToObject :: PrefixTree TOML -> Object -prefixTreeToObject (Toml.PrefixTree.Leaf key toml) - = sparseObject key (tomlToObject toml) -prefixTreeToObject (Toml.PrefixTree.Branch prefix _ toml) - = sparseObject prefix (tablesToObject toml) +tablesToObject :: PrefixMap TOML -> Object +tablesToObject = fold . map prefixTreeToObject . HashMap.elems -tableArraysToObject :: HashMap.HashMap Key (NonEmpty TOML) -> Object -tableArraysToObject arrays - = foldl' (<>) (Table HashMap.empty) - $ HashMap.mapWithKey sparseObject - $ fmap (Array . fmap tomlToObject . toList) arrays +prefixTreeToObject :: PrefixTree TOML -> Object +prefixTreeToObject (Leaf key toml) = + sparseObject key (tomlToObject toml) +prefixTreeToObject (Branch prefix _ toml) = + sparseObject prefix (tablesToObject toml) tomlToObject :: TOML -> Object -tomlToObject toml = pairs <> tables <> tableArrays - where - pairs = pairsToObject $ Toml.TOML.tomlPairs toml - tables = tablesToObject $ Toml.TOML.tomlTables toml - tableArrays = tableArraysToObject $ Toml.TOML.tomlTableArrays toml +tomlToObject = pairs <> tables <> tableArrays + where + pairs = + fold + . HashMap.mapWithKey sparseObject + . fmap Prim + . TOML.tomlPairs + + tables = + fold + . map prefixTreeToObject + . HashMap.elems + . TOML.tomlTables + + tableArrays = + fold + . HashMap.mapWithKey sparseObject + . fmap (Array . fmap tomlToObject . toList) + . TOML.tomlTableArrays data Options = Options { input :: Maybe FilePath @@ -306,38 +341,51 @@ data Options = Options , schemaFile :: FilePath } -parserInfo :: OA.ParserInfo Options -parserInfo = OA.info - (OA.helper <*> versionOption <*> optionsParser) - (OA.fullDesc <> OA.progDesc "Convert TOML to Dhall") +parserInfo :: Options.ParserInfo Options +parserInfo = Options.info + (Options.helper <*> versionOption <*> optionsParser) + (Options.fullDesc <> Options.progDesc "Convert TOML to Dhall") where - versionOption = OA.infoOption (showVersion Meta.version) $ - OA.long "version" <> OA.help "Display version" + versionOption = + Options.infoOption (showVersion Meta.version) + (Options.long "version" <> Options.help "Display version") + optionsParser = do - input <- OA.optional . OA.strOption $ - OA.long "file" - <> OA.help "Read TOML from file instead of standard input" - <> fileOpts - output <- OA.optional . OA.strOption $ - OA.long "output" - <> OA.help "Write Dhall to a file instead of standard output" - <> fileOpts - schemaFile <- OA.strArgument $ - OA.help "Path to Dhall schema file" - <> OA.action "file" - <> OA.metavar "SCHEMA" + input <- (Options.optional . Options.strOption) + ( Options.long "file" + <> Options.help "Read TOML from file instead of standard input" + <> Options.metavar "FILE" + <> Options.action "file" + ) + output <- (Options.optional . Options.strOption) + ( Options.long "output" + <> Options.help "Write Dhall to a file instead of standard output" + <> Options.metavar "FILE" + <> Options.action "file" + ) + schemaFile <- Options.strArgument + ( Options.help "Path to Dhall schema file" + <> Options.action "file" + <> Options.metavar "SCHEMA" + ) pure Options {..} - fileOpts = OA.metavar "FILE" <> OA.action "file" tomlToDhallMain :: IO () tomlToDhallMain = do - Options {..} <- OA.execParser parserInfo - text <- maybe Text.IO.getContents Text.IO.readFile input - toml <- case Toml.Parser.parse text of - Left tomlErr -> throwIO (InvalidToml tomlErr) - Right toml -> return toml + Options{..} <- Options.execParser parserInfo + + inputText <- case input of + Just file -> Text.IO.readFile file + Nothing -> Text.IO.getContents + + toml <- Core.throws (first InvalidToml (Toml.Parser.parse inputText)) + schema <- fileToDhall schemaFile - dhall <- case tomlToDhall schema toml of - Left err -> throwIO err - Right dhall -> return dhall - maybe Text.IO.putStrLn Text.IO.writeFile output $ Core.pretty dhall + + dhall <- Core.throws (tomlToDhall schema toml) + + let outputText = Core.pretty dhall + + case output of + Just file -> Text.IO.writeFile file outputText + Nothing -> Text.IO.putStrLn outputText From cd60fc28c2eeae8b77ca4e3d87dc0393a5277cbc Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Thu, 23 Nov 2023 10:32:11 -0800 Subject: [PATCH 16/16] dhall-toml: Add support for Prelude.Map.Type (#2549) Fixes https://github.com/dhall-lang/dhall-haskell/issues/2509 This adds `dhall-to-toml` and `toml-to-dhall` support for the `Prelude.Map.Type` type which is translated to and from TOML tables. --- dhall-toml/src/Dhall/DhallToToml.hs | 72 ++++++++++++------- dhall-toml/src/Dhall/TomlToDhall.hs | 42 ++++++++--- dhall-toml/tasty/Main.hs | 5 ++ .../tasty/data/map-complex-schema.dhall | 1 + dhall-toml/tasty/data/map-complex.dhall | 1 + dhall-toml/tasty/data/map-complex.toml | 2 + dhall-toml/tasty/data/map-empty-schema.dhall | 1 + dhall-toml/tasty/data/map-empty.dhall | 1 + dhall-toml/tasty/data/map-empty.toml | 0 dhall-toml/tasty/data/map-simple-schema.dhall | 1 + dhall-toml/tasty/data/map-simple.dhall | 1 + dhall-toml/tasty/data/map-simple.toml | 1 + 12 files changed, 93 insertions(+), 35 deletions(-) create mode 100644 dhall-toml/tasty/data/map-complex-schema.dhall create mode 100644 dhall-toml/tasty/data/map-complex.dhall create mode 100644 dhall-toml/tasty/data/map-complex.toml create mode 100644 dhall-toml/tasty/data/map-empty-schema.dhall create mode 100644 dhall-toml/tasty/data/map-empty.dhall create mode 100644 dhall-toml/tasty/data/map-empty.toml create mode 100644 dhall-toml/tasty/data/map-simple-schema.dhall create mode 100644 dhall-toml/tasty/data/map-simple.dhall create mode 100644 dhall-toml/tasty/data/map-simple.toml diff --git a/dhall-toml/src/Dhall/DhallToToml.hs b/dhall-toml/src/Dhall/DhallToToml.hs index 12ae146a6..c790ff8cd 100644 --- a/dhall-toml/src/Dhall/DhallToToml.hs +++ b/dhall-toml/src/Dhall/DhallToToml.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {-| This module exports the `dhallToToml` function for translating a Dhall syntax tree to a TOML syntax tree (`TOML`) for the @tomland@ @@ -81,6 +84,11 @@ > [r.nested] > c = 3 + … and @Prelude.Map.Type@ also translates to a TOML table: + +> $ dhall-to-toml <<< '[ { mapKey = "foo", mapValue = 1 } ]' +> foo = 1 + Dhall unions translate to the wrapped value, or a string if the alternative is empty: > $ dhall-to-toml <<< '{ u = < A | B >.A }' @@ -248,9 +256,21 @@ pattern UnionApp x <- Core.App (Core.Field (Core.Union _) _) x assertRecordLit :: Expr Void Void -> Either CompileError (Map Text (Core.RecordField Void Void)) -assertRecordLit (Core.RecordLit r) = Right r -assertRecordLit (UnionApp x) = assertRecordLit x -assertRecordLit e = Left $ NotARecord e +assertRecordLit (Core.RecordLit r) = + Right r +assertRecordLit (UnionApp x) = + assertRecordLit x +assertRecordLit (Core.ListLit _ expressions) + | Just keyValues <- traverse toKeyValue (toList expressions) = + Right (Map.fromList keyValues) + where + toKeyValue + (Core.RecordLit [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] key)), ("mapValue", value) ]) = + Just (key, value) + toKeyValue _ = + Nothing +assertRecordLit e = + Left (NotARecord e) toTomlTable :: Map Text (Core.RecordField Void Void) -> Either CompileError TOML toTomlTable r = foldM (toTomlRecordFold []) (mempty :: TOML) (Map.toList r) @@ -292,24 +312,6 @@ toToml toml pieces expr = case expr of Core.App Core.None _ -> return toml - Core.ListLit _ a -> case toList a of - -- TODO: unions need to be handled here as well, it's a bit tricky - -- because they also have to be probed for being a "simple" - -- array of table - union@(UnionApp (Core.RecordLit _)) : unions -> do - insertTables (union :| unions) - - record@(Core.RecordLit _) : records -> do - insertTables (record :| records) - - -- inline array - expressions -> do - anyValues <- mapM toAnyValue expressions - - case AnyValue.toMArray anyValues of - Left _ -> Left (HeterogeneousArray expr) - Right array -> insertPrim array - Core.RecordLit r -> do let (inline, nested) = Map.partition (isInline . Core.recordFieldValue) r @@ -331,6 +333,28 @@ toToml toml pieces expr = case expr of else do newPairs <- foldM (toTomlRecordFold []) mempty pairs return (TOML.insertTable key newPairs toml) + + _ | Right keyValues <- assertRecordLit expr -> + toToml toml pieces (Core.RecordLit keyValues) + + Core.ListLit _ a -> case toList a of + -- TODO: unions need to be handled here as well, it's a bit tricky + -- because they also have to be probed for being a "simple" + -- array of table + union@(UnionApp (Core.RecordLit _)) : unions -> do + insertTables (union :| unions) + + record@(Core.RecordLit _) : records -> do + insertTables (record :| records) + + -- inline array + expressions -> do + anyValues <- mapM toAnyValue expressions + + case AnyValue.toMArray anyValues of + Left _ -> Left (HeterogeneousArray expr) + Right array -> insertPrim array + _ -> Left (Unsupported expr) where diff --git a/dhall-toml/src/Dhall/TomlToDhall.hs b/dhall-toml/src/Dhall/TomlToDhall.hs index c545b3446..aadcd506d 100644 --- a/dhall-toml/src/Dhall/TomlToDhall.hs +++ b/dhall-toml/src/Dhall/TomlToDhall.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-| This module exports the `tomlToDhall` function for translating a TOML syntax tree from @tomland@ to a Dhall syntax tree. For now, @@ -250,13 +253,6 @@ objectToDhall type_ object = case (type_, object) of [] -> Left (Incompatible type_ object) x : _ -> Right x - (Core.App Core.List t, Array []) -> - Right (Core.ListLit (Just t) []) - - (Core.App Core.List t, Array elements) -> do - expressions <- mapM (objectToDhall t) elements - return (Core.ListLit Nothing (Seq.fromList expressions)) - (Core.Record record, Table table) -> do let process key fieldType | Just nestedObject <- HashMap.lookup (Piece key) table = @@ -272,6 +268,30 @@ objectToDhall type_ object = case (type_, object) of return (Core.RecordLit (fmap Core.makeRecordField expressions)) + (Core.App Core.List (Core.Record [("mapKey", Core.recordFieldValue -> Core.Text), ("mapValue", Core.recordFieldValue -> valueType)]), Table table) -> do + hashMap <- traverse (objectToDhall valueType) table + + let expressions = Seq.fromList do + (Piece key, value) <- HashMap.toList hashMap + + let newKey = + Core.makeRecordField (Core.TextLit (Core.Chunks [] key)) + + let newValue = Core.makeRecordField value + + pure (Core.RecordLit [("mapKey", newKey), ("mapValue", newValue)]) + + let listType = if Seq.null expressions then Just type_ else Nothing + + return (Core.ListLit listType expressions) + + (Core.App Core.List t, Array []) -> + Right (Core.ListLit (Just t) []) + + (Core.App Core.List t, Array elements) -> do + expressions <- mapM (objectToDhall t) elements + return (Core.ListLit Nothing (Seq.fromList expressions)) + (_, Prim (AnyValue value)) -> valueToDhall type_ value diff --git a/dhall-toml/tasty/Main.hs b/dhall-toml/tasty/Main.hs index 46d39bedf..6b0d87570 100644 --- a/dhall-toml/tasty/Main.hs +++ b/dhall-toml/tasty/Main.hs @@ -46,6 +46,9 @@ testTree = , "./tasty/data/union-typed" , "./tasty/data/union-nested" , "./tasty/data/optional" + , "./tasty/data/map-simple" + , "./tasty/data/map-complex" + , "./tasty/data/map-empty" ] tomlToDhallTests = map testTomlToDhall [ "./tasty/data/empty" @@ -59,6 +62,8 @@ testTree = , "./tasty/data/union-empty" , "./tasty/data/union-typed" , "./tasty/data/optional" + , "./tasty/data/map-simple" + , "./tasty/data/map-empty" ] testDhallToToml :: String -> TestTree diff --git a/dhall-toml/tasty/data/map-complex-schema.dhall b/dhall-toml/tasty/data/map-complex-schema.dhall new file mode 100644 index 000000000..2b0a4d8fc --- /dev/null +++ b/dhall-toml/tasty/data/map-complex-schema.dhall @@ -0,0 +1 @@ +{ foo : List { mapKey : Text, mapValue : { baz : Natural } } } diff --git a/dhall-toml/tasty/data/map-complex.dhall b/dhall-toml/tasty/data/map-complex.dhall new file mode 100644 index 000000000..8696a2516 --- /dev/null +++ b/dhall-toml/tasty/data/map-complex.dhall @@ -0,0 +1 @@ +{ foo = [ { mapValue = { baz = 1 }, mapKey = "bar" } ] } diff --git a/dhall-toml/tasty/data/map-complex.toml b/dhall-toml/tasty/data/map-complex.toml new file mode 100644 index 000000000..405a92428 --- /dev/null +++ b/dhall-toml/tasty/data/map-complex.toml @@ -0,0 +1,2 @@ +[foo.bar] + baz = 1 diff --git a/dhall-toml/tasty/data/map-empty-schema.dhall b/dhall-toml/tasty/data/map-empty-schema.dhall new file mode 100644 index 000000000..4a9542d74 --- /dev/null +++ b/dhall-toml/tasty/data/map-empty-schema.dhall @@ -0,0 +1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-empty.dhall b/dhall-toml/tasty/data/map-empty.dhall new file mode 100644 index 000000000..05d70a8a8 --- /dev/null +++ b/dhall-toml/tasty/data/map-empty.dhall @@ -0,0 +1 @@ +[] : List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-empty.toml b/dhall-toml/tasty/data/map-empty.toml new file mode 100644 index 000000000..e69de29bb diff --git a/dhall-toml/tasty/data/map-simple-schema.dhall b/dhall-toml/tasty/data/map-simple-schema.dhall new file mode 100644 index 000000000..4a9542d74 --- /dev/null +++ b/dhall-toml/tasty/data/map-simple-schema.dhall @@ -0,0 +1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-simple.dhall b/dhall-toml/tasty/data/map-simple.dhall new file mode 100644 index 000000000..22748d28e --- /dev/null +++ b/dhall-toml/tasty/data/map-simple.dhall @@ -0,0 +1 @@ +[ { mapKey = "foo", mapValue = 1 } ] diff --git a/dhall-toml/tasty/data/map-simple.toml b/dhall-toml/tasty/data/map-simple.toml new file mode 100644 index 000000000..c4e5bcc80 --- /dev/null +++ b/dhall-toml/tasty/data/map-simple.toml @@ -0,0 +1 @@ +foo = 1