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-bash/dhall-bash.cabal b/dhall-bash/dhall-bash.cabal index 2ed643cd4..4ee8f62f7 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 @@ -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.41.0 && < 1.42, + 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 @@ -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 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..ff94fc09f 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 , @@ -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-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" <> 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..76f3b8080 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,11 +43,11 @@ 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 , - 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 , @@ -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-lsp-server/dhall-lsp-server.cabal b/dhall-lsp-server/dhall-lsp-server.cabal index d070e1701..bf8b11b9b 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,13 +49,13 @@ 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 , 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 diff --git a/dhall-nix/dhall-nix.cabal b/dhall-nix/dhall-nix.cabal index 389ac0252..8147cdeee 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 , @@ -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 b13447743..2b03c20e2 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 @@ -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 2b4948dd3..1bd408c0a 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 @@ -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 , @@ -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..a61d620de 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,13 +35,13 @@ 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 , 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-toml/src/Dhall/DhallToToml.hs b/dhall-toml/src/Dhall/DhallToToml.hs index 2b248e527..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 }' @@ -103,7 +111,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 +119,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 +134,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 +236,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 +253,217 @@ 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 (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 +assertRecordLit + :: Expr Void Void + -> Either CompileError (Map Text (Core.RecordField Void Void)) +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) -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.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) + + _ | Right keyValues <- assertRecordLit expr -> + toToml toml pieces (Core.RecordLit keyValues) + 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 + + _ -> + 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..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, @@ -118,35 +121,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 +157,203 @@ 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) + +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) + + (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") + + (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 , _) -> 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)) + (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 -toDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void) -toDhall exprType value = case (exprType, value) of - (_, Invalid) -> Left $ InternalError "invalid object" +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 , _) -> 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.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.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) - in case rights (toList (Map.mapWithKey f m)) of - [] -> Left $ Incompatible exprType value - x:_ -> Right $ x + return (Core.RecordLit (fmap Core.makeRecordField expressions)) - (Core.App Core.List t, Array []) -> Right $ Core.ListLit (Just t) [] + (Core.App Core.List (Core.Record [("mapKey", Core.recordFieldValue -> Core.Text), ("mapValue", Core.recordFieldValue -> valueType)]), Table table) -> do + hashMap <- traverse (objectToDhall valueType) table - (Core.App Core.List t, Array a) -> do - l <- mapM (toDhall t) a - return $ Core.ListLit Nothing (Seq.fromList l) + let expressions = Seq.fromList do + (Piece key, value) <- HashMap.toList hashMap - (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) + let newKey = + Core.makeRecordField (Core.TextLit (Core.Chunks [] key)) - (_, Prim (AnyValue v)) -> tomlValueToDhall exprType v + let newValue = Core.makeRecordField value - (ty, obj) -> Left $ Incompatible ty obj + 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 + + (_, 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 +361,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 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 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..324a7d0a1 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,9 +36,9 @@ 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, + optparse-applicative >= 0.14.0.0 && < 0.19, text >= 0.11.1.0 && < 2.1 , vector Exposed-Modules: @@ -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/CHANGELOG.md b/dhall/CHANGELOG.md index 7322fc9a4..3d0b5289f 100644 --- a/dhall/CHANGELOG.md +++ b/dhall/CHANGELOG.md @@ -1,5 +1,48 @@ -Unreleased - +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) + * [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..a3be524b8 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.1 Build-Type: Simple License: BSD-3-Clause License-File: LICENSE @@ -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 && < 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, + 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 , @@ -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 , @@ -244,17 +244,21 @@ 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 , 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.hs b/dhall/src/Dhall.hs index e2d11dcbe..ca4d6a4b0 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,16 +47,25 @@ module Dhall -- * Encoders , module Dhall.Marshal.Encode + -- * Individual phases + , parseWithSettings + , resolveWithSettings + , typecheckWithSettings + , checkWithSettings + , expectWithSettings + , normalizeWithSettings + -- * Miscellaneous , rawInput ) 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 (..)) 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 +208,81 @@ instance HasEvaluateSettings InputSettings where instance HasEvaluateSettings EvaluateSettings where evaluateSettings = id +-- | Parse an expression, using the supplied `InputSettings` +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 :: MonadThrow m => InputSettings -> Expr Src Void -> m () +typecheckWithSettings settings expression = + either throwM (return . const ()) (Dhall.TypeCheck.typeWith (view startingContext settings) expression) + +{-| Type-check an expression against a type provided as a Dhall expreession, + using the supplied `InputSettings` +-} +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 type_) + where + bytes' = bytes <> " : " <> suffix + _ -> + Annot expression type_ + + typecheckWithSettings settings annotated + +{-| 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` + + 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 +324,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 + + expectWithSettings settings decoder resolved - normExpr <- inputHelper annotate settings txt + let normalized = normalizeWithSettings settings resolved - case extract normExpr of - Success x -> return x + 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 +401,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 -{-| Helper function for the input* function family + _ <- typecheckWithSettings settings resolved -@since 1.30 + pure (Core.normalizeWith (view normalizer settings) resolved) + +{-| Interpret a Dhall Expression + + 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 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/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/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 f1f86ddf9..9c399773d 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 #-} @@ -331,7 +332,13 @@ 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,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)) +#endif toDataD typeName typeParams constructors = do let name = Syntax.mkName (Text.unpack typeName) 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 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 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 }