summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2020-08-03 05:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-03 05:28:00 (GMT)
commit8f7c25dc27ab092b2580752f4d0c351f4b304095 (patch)
tree6ab187832d33ac5087bdf1569e0f759f6cca4581
parenteda202020ddb32a37aee868fdfb6ab655728b050 (diff)
version 1.7.11.7.1
-rw-r--r--CHANGELOG.md6
-rw-r--r--dhall-json.cabal35
-rw-r--r--dhall-to-json/Main.hs17
-rw-r--r--json-to-dhall/Main.hs23
-rw-r--r--src/Dhall/DhallToYaml/Main.hs1
-rw-r--r--src/Dhall/JSON.hs106
-rw-r--r--src/Dhall/JSON/Yaml.hs3
-rw-r--r--src/Dhall/JSONToDhall.hs128
-rw-r--r--tasty/Main.hs12
9 files changed, 176 insertions, 155 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index a3f960f..6914ebb 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,9 @@
+1.7.1
+
+* [Format documents with leading `---`](https://github.com/dhall-lang/dhall-haskell/pull/1865)
+ * Now if you use the `--documents` flag the first document will also
+ include a leading `---`
+
1.7.0
* BREAKING CHANGE: [Add `--generated-comment` flag for `dhall-to-yaml{-ng}`](https://github.com/dhall-lang/dhall-haskell/pull/1840)
diff --git a/dhall-json.cabal b/dhall-json.cabal
index 1abcf42..5036b09 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -1,8 +1,8 @@
Name: dhall-json
-Version: 1.7.0
+Version: 1.7.1
Cabal-Version: >=1.10
Build-Type: Simple
-Tested-With: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1
+Tested-With: GHC == 8.4.3, GHC == 8.6.1
License: BSD3
License-File: LICENSE
Copyright: 2017 Gabriel Gonzalez
@@ -38,20 +38,21 @@ Source-Repository head
Library
Hs-Source-Dirs: src
Build-Depends:
- base >= 4.8.0.0 && < 5 ,
- aeson >= 1.0.0.0 && < 1.6 ,
- aeson-pretty < 0.9 ,
- aeson-yaml >= 1.0.6 && < 1.1 ,
- bytestring < 0.11,
- containers >= 0.5.9 && < 0.7 ,
- dhall >= 1.33.0 && < 1.34,
- exceptions >= 0.8.3 && < 0.11,
- filepath < 1.5 ,
- optparse-applicative >= 0.14.0.0 && < 0.16,
- prettyprinter >= 1.5.1 && < 1.7 ,
- scientific >= 0.3.0.0 && < 0.4 ,
- text >= 0.11.1.0 && < 1.3 ,
- unordered-containers < 0.3 ,
+ base >= 4.11.0.0 && < 5 ,
+ aeson >= 1.0.0.0 && < 1.6 ,
+ aeson-pretty < 0.9 ,
+ aeson-yaml >= 1.1.0 && < 1.2 ,
+ bytestring < 0.11,
+ containers >= 0.5.9 && < 0.7 ,
+ dhall >= 1.33.0 && < 1.35,
+ exceptions >= 0.8.3 && < 0.11,
+ filepath < 1.5 ,
+ lens-family-core >= 1.0.0 && < 2.2 ,
+ optparse-applicative >= 0.14.0.0 && < 0.16,
+ prettyprinter >= 1.5.1 && < 1.8 ,
+ scientific >= 0.3.0.0 && < 0.4 ,
+ text >= 0.11.1.0 && < 1.3 ,
+ unordered-containers < 0.3 ,
vector
Exposed-Modules:
Dhall.JSON
@@ -106,8 +107,6 @@ Executable json-to-dhall
prettyprinter ,
prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 ,
text < 1.3
- if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4)
- Build-Depends: semigroups == 0.18.*
Other-Modules:
Paths_dhall_json
GHC-Options: -Wall
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index 3c15caf..60fb188 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
module Main where
-import Control.Applicative ((<|>), optional)
-import Control.Exception (SomeException)
-import Data.Aeson (Value)
-import Data.Monoid ((<>))
-import Data.Version (showVersion)
-import Dhall.JSON (Conversion, SpecialDoubleMode(..))
+import Control.Applicative (optional, (<|>))
+import Control.Exception (SomeException)
+import Data.Aeson (Value)
+import Data.Version (showVersion)
+import Dhall.JSON (Conversion, SpecialDoubleMode (..))
import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
@@ -117,10 +116,10 @@ main = do
options <- Options.execParser parserInfo
case options of
- Version -> do
+ Version ->
putStrLn (showVersion Meta.version)
- Options {..} -> do
+ Options {..} ->
handle $ do
let config = Data.Aeson.Encode.Pretty.Config
{ Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2
diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs
index 550ae78..b8ba0db 100644
--- a/json-to-dhall/Main.hs
+++ b/json-to-dhall/Main.hs
@@ -1,20 +1,17 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Applicative (optional, (<|>))
-import Control.Exception (SomeException, throwIO)
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import Data.Version (showVersion)
+import Control.Exception (SomeException, throwIO)
+import Data.Text (Text)
+import Data.Version (showVersion)
import Dhall.JSONToDhall
-import Dhall.Pretty (CharacterSet(..))
+import Dhall.Pretty (CharacterSet (..))
import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
@@ -24,14 +21,14 @@ import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text
+import qualified Dhall.Core
+import qualified Dhall.Pretty
import qualified GHC.IO.Encoding
import qualified Options.Applicative as Options
+import qualified Paths_dhall_json as Meta
import qualified System.Console.ANSI as ANSI
import qualified System.Exit
import qualified System.IO as IO
-import qualified Dhall.Core
-import qualified Dhall.Pretty
-import qualified Paths_dhall_json as Meta
-- ---------------
-- Command options
@@ -188,7 +185,7 @@ main = do
Text.IO.hPutStrLn h ""
case options of
- Version -> do
+ Version ->
putStrLn (showVersion Meta.version)
Default{..} -> do
diff --git a/src/Dhall/DhallToYaml/Main.hs b/src/Dhall/DhallToYaml/Main.hs
index ca19578..2cc2a44 100644
--- a/src/Dhall/DhallToYaml/Main.hs
+++ b/src/Dhall/DhallToYaml/Main.hs
@@ -8,7 +8,6 @@ module Dhall.DhallToYaml.Main (main) where
import Control.Applicative (optional, (<|>))
import Control.Exception (SomeException)
import Data.ByteString (ByteString)
-import Data.Monoid ((<>))
import Data.Text (Text)
import Dhall.JSON (parseConversion, parsePreservationAndOmission)
import Dhall.JSON.Yaml (Options (..), parseDocuments, parseQuoted)
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index 8025954..a27de5c 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
{-| This library only exports a single `dhallToJSON` function for translating a
Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@
@@ -26,7 +27,7 @@
* @Natural@s
* @Integer@s
* @Double@s
- * @Text@
+ * @Text@ values
* @List@s
* @Optional@ values
* unions
@@ -217,7 +218,6 @@ import Control.Exception (Exception, throwIO)
import Control.Monad (guard)
import Data.Aeson (ToJSON (..), Value (..))
import Data.Maybe (fromMaybe)
-import Data.Monoid (mempty, (<>))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty)
import Data.Void (Void)
@@ -245,6 +245,7 @@ import qualified Dhall.Parser
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck
import qualified Dhall.Util
+import qualified Lens.Family as Lens
import qualified Options.Applicative
import qualified System.FilePath
@@ -417,32 +418,29 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
Core.NaturalLit a -> return (toJSON a)
Core.IntegerLit a -> return (toJSON a)
Core.DoubleLit (DhallDouble a) -> return (toJSON a)
- Core.TextLit (Core.Chunks [] a) -> do
- return (toJSON a)
+ Core.TextLit (Core.Chunks [] a) -> return (toJSON a)
Core.ListLit _ a -> do
a' <- traverse loop a
return (toJSON a')
Core.Some a -> do
a' <- loop a
return (toJSON a')
- Core.App Core.None _ -> do
- return Aeson.Null
+ Core.App Core.None _ -> return Aeson.Null
-- Provide a nicer error message for a common user mistake.
--
-- See: https://github.com/dhall-lang/dhall-lang/issues/492
- Core.None -> do
- Left BareNone
+ Core.None -> Left BareNone
Core.RecordLit a ->
case toOrderedList a of
[ ( "contents"
- , contents
+ , Core.recordFieldValue -> contents
)
, ( "field"
- , Core.TextLit
+ , Core.recordFieldValue -> Core.TextLit
(Core.Chunks [] field)
)
, ( "nesting"
- , Core.App
+ , Core.recordFieldValue -> Core.App
(Core.Field
(Core.Union
[ ("Inline", mInlineType)
@@ -474,14 +472,14 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
return (Aeson.toJSON taggedValue)
[ ( "contents"
- , contents
+ , Core.recordFieldValue -> contents
)
, ( "field"
- , Core.TextLit
+ , Core.recordFieldValue -> Core.TextLit
(Core.Chunks [] field)
)
, ( "nesting"
- , nesting
+ , Core.recordFieldValue -> nesting
)
] | isInlineNesting nesting
, Just (alternativeName, mExpr) <- getContents contents -> do
@@ -491,40 +489,44 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
Left (InvalidInlineContents e alternativeContents)
Nothing -> return mempty
- let name = Core.TextLit (Core.Chunks [] alternativeName)
+ let name = Core.makeRecordField $ Core.TextLit (Core.Chunks [] alternativeName)
let kvs1 = Dhall.Map.insert field name kvs0
loop (Core.RecordLit kvs1)
_ -> do
- a' <- traverse loop a
+ a' <- traverse (loop . Core.recordFieldValue) a
return (Aeson.toJSON (Dhall.Map.toMap a'))
Core.App (Core.Field (Core.Union _) _) b -> loop b
Core.Field (Core.Union _) k -> return (Aeson.toJSON k)
Core.Lam _ (Core.Const Core.Type)
(Core.Lam _
(Core.Record
- [ ("array" , Core.Pi _ (Core.App Core.List (V 0)) (V 1))
- , ("bool" , Core.Pi _ Core.Bool (V 1))
- , ("null" , V 0)
- , ("number", Core.Pi _ Core.Double (V 1))
- , ("object", Core.Pi _ (Core.App Core.List (Core.Record [ ("mapKey", Core.Text), ("mapValue", V 0)])) (V 1))
- , ("string", Core.Pi _ Core.Text (V 1))
+ [ ("array" , Core.recordFieldValue -> Core.Pi _ (Core.App Core.List (V 0)) (V 1))
+ , ("bool" , Core.recordFieldValue -> Core.Pi _ Core.Bool (V 1))
+ , ("null" , Core.recordFieldValue -> V 0)
+ , ("number", Core.recordFieldValue -> Core.Pi _ Core.Double (V 1))
+ , ("object", Core.recordFieldValue ->
+ Core.Pi _ (Core.App Core.List (Core.Record
+ [ ("mapKey", Core.recordFieldValue -> Core.Text)
+ , ("mapValue", Core.recordFieldValue -> V 0)])) (V 1))
+ , ("string", Core.recordFieldValue -> Core.Pi _ Core.Text (V 1))
]
)
value
) -> do
- let outer (Core.Field (V 0) "null") = do
- return Aeson.Null
- outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = do
+ let outer (Core.Field (V 0) "null") = return Aeson.Null
+ outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) =
return (Aeson.Bool b)
outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do
ys <- traverse outer (Foldable.toList xs)
return (Aeson.Array (Vector.fromList ys))
outer (Core.App (Core.Field (V 0) "object") (Core.ListLit _ xs)) = do
- let inner (Core.RecordLit [("mapKey", Core.TextLit (Core.Chunks [] mapKey)), ("mapValue", mapExpression)]) = do
+ let inner (Core.RecordLit
+ [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))
+ , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do
mapValue <- outer mapExpression
return (mapKey, mapValue)
@@ -533,9 +535,9 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
ys <- traverse inner (Foldable.toList xs)
return (Aeson.Object (HashMap.fromList ys))
- outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) = do
+ outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) =
return (Aeson.toJSON n)
- outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do
+ outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) =
return (toJSON text)
outer _ = Left (Unsupported e)
@@ -543,27 +545,33 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
Core.Lam _ (Core.Const Core.Type)
(Core.Lam _
(Core.Record
- [ ("array" , Core.Pi _ (Core.App Core.List (V 0)) (V 1))
- , ("bool" , Core.Pi _ Core.Bool (V 1))
- , ("double", Core.Pi _ Core.Double (V 1))
- , ("integer", Core.Pi _ Core.Integer (V 1))
- , ("null" , V 0)
- , ("object", Core.Pi _ (Core.App Core.List (Core.Record [ ("mapKey", Core.Text), ("mapValue", V 0)])) (V 1))
- , ("string", Core.Pi _ Core.Text (V 1))
+ [ ("array" , Core.recordFieldValue -> Core.Pi _ (Core.App Core.List (V 0)) (V 1))
+ , ("bool" , Core.recordFieldValue -> Core.Pi _ Core.Bool (V 1))
+ , ("double", Core.recordFieldValue -> Core.Pi _ Core.Double (V 1))
+ , ("integer", Core.recordFieldValue -> Core.Pi _ Core.Integer (V 1))
+ , ("null" , Core.recordFieldValue -> V 0)
+ , ("object", Core.recordFieldValue ->
+ Core.Pi _ (Core.App Core.List (Core.Record
+ [ ("mapKey", Core.recordFieldValue -> Core.Text)
+ , ("mapValue", Core.recordFieldValue -> V 0)
+ ])) (V 1))
+ , ("string", Core.recordFieldValue -> Core.Pi _ Core.Text (V 1))
]
)
value
) -> do
- let outer (Core.Field (V 0) "null") = do
+ let outer (Core.Field (V 0) "null") =
return Aeson.Null
- outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = do
+ outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) =
return (Aeson.Bool b)
outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do
ys <- traverse outer (Foldable.toList xs)
return (Aeson.Array (Vector.fromList ys))
outer (Core.App (Core.Field (V 0) "object") (Core.ListLit _ xs)) = do
- let inner (Core.RecordLit [("mapKey", Core.TextLit (Core.Chunks [] mapKey)), ("mapValue", mapExpression)]) = do
+ let inner (Core.RecordLit
+ [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))
+ , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do
mapValue <- outer mapExpression
return (mapKey, mapValue)
@@ -572,11 +580,11 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
ys <- traverse inner (Foldable.toList xs)
return (Aeson.Object (HashMap.fromList ys))
- outer (Core.App (Core.Field (V 0) "double") (Core.DoubleLit (DhallDouble n))) = do
+ outer (Core.App (Core.Field (V 0) "double") (Core.DoubleLit (DhallDouble n))) =
return (Aeson.toJSON n)
- outer (Core.App (Core.Field (V 0) "integer") (Core.IntegerLit n)) = do
+ outer (Core.App (Core.Field (V 0) "integer") (Core.IntegerLit n)) =
return (Aeson.toJSON n)
- outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do
+ outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) =
return (toJSON text)
outer _ = Left (Unsupported e)
@@ -885,8 +893,8 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
toKeyValue (Core.RecordLit m) = do
guard (Foldable.length m == 2)
- key <- Dhall.Map.lookup mapKey m
- value <- Dhall.Map.lookup mapValue m
+ key <- Core.recordFieldValue <$> Dhall.Map.lookup mapKey m
+ value <- Core.recordFieldValue <$> Dhall.Map.lookup mapValue m
keyText <- case key of
Core.TextLit (Core.Chunks [] keyText) ->
@@ -899,7 +907,7 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
empty
return (keyText, value)
- toKeyValue _ = do
+ toKeyValue _ =
empty
transform =
@@ -911,13 +919,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
guard (Dhall.Map.member mapKey m)
guard (Dhall.Map.member mapValue m)
return (Core.RecordLit mempty)
- _ -> do
- empty
+ _ -> empty
_ -> do
keyValues <- traverse toKeyValue elements
- let recordLiteral =
+ let recordLiteral = Core.makeRecordField <$>
Dhall.Map.fromList keyValues
return (Core.RecordLit recordLiteral)
@@ -966,12 +973,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
Core.Record a ->
Core.Record a'
where
- a' = fmap loop a
+ a' = Lens.over Core.recordFieldExprs loop <$> a
Core.RecordLit a ->
Core.RecordLit a'
where
- a' = fmap loop a
+ a' = Lens.over Core.recordFieldExprs loop <$> a
Core.Union a ->
Core.Union a'
@@ -1170,4 +1177,3 @@ codeToValue conversion specialDoubleMode mFilePath code = do
case dhallToJSON specialDoubleExpression of
Left err -> Control.Exception.throwIO err
Right json -> return json
-
diff --git a/src/Dhall/JSON/Yaml.hs b/src/Dhall/JSON/Yaml.hs
index a8983c4..ebb729e 100644
--- a/src/Dhall/JSON/Yaml.hs
+++ b/src/Dhall/JSON/Yaml.hs
@@ -17,7 +17,6 @@ module Dhall.JSON.Yaml
) where
import Data.ByteString (ByteString)
-import Data.Monoid ((<>))
import Data.Text (Text)
import Dhall.JSON (Conversion (..), SpecialDoubleMode (..))
import Options.Applicative (Parser)
@@ -57,7 +56,7 @@ parseDocuments :: Parser Bool
parseDocuments =
Options.Applicative.switch
( Options.Applicative.long "documents"
- <> Options.Applicative.help "If given a Dhall list, output a document for every element"
+ <> Options.Applicative.help "If given a Dhall list, output a document for every element. Each document, including the first one, will be preceded by \"---\", even if there is only one document"
)
parseQuoted :: Parser Bool
diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs
index 7373199..d8acd95 100644
--- a/src/Dhall/JSONToDhall.hs
+++ b/src/Dhall/JSONToDhall.hs
@@ -1,12 +1,13 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
{-| Convert JSON data to Dhall in one of two ways:
@@ -369,7 +370,6 @@ import Data.Foldable (toList)
import Data.List ((\\))
import Data.Monoid (Any (..))
import Data.Scientific (floatingOrInteger, toRealFloat)
-import Data.Semigroup (Semigroup (..))
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App))
@@ -571,7 +571,7 @@ instance Semigroup RecordSchema where
recordSchemaToDhallType :: RecordSchema -> Expr s a
recordSchemaToDhallType (RecordSchema m) =
- D.Record (Map.fromList (Data.Map.toList (fmap schemaToDhallType m)))
+ D.Record (Map.fromList (Data.Map.toList (fmap (D.makeRecordField . schemaToDhallType) m)))
{-| `inferSchema` will never infer a union type with more than one numeric
alternative
@@ -597,8 +597,6 @@ instance Semigroup UnionNumber where
instance Monoid UnionNumber where
mempty = minBound
- mappend = (<>)
-
unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]
unionNumberToAlternatives UnionAbsent = []
unionNumberToAlternatives UnionNatural = [ ("Natural", Just D.Natural) ]
@@ -658,8 +656,6 @@ instance Monoid UnionSchema where
text = mempty
- mappend = (<>)
-
{-| A `Schema` is a subset of the `Expr` type representing all possible
Dhall types that `inferSchema` could potentially return
-}
@@ -760,8 +756,6 @@ instance Semigroup Schema where
instance Monoid Schema where
mempty = Union mempty
- mappend = (<>)
-
-- | Convert a `Schema` to the corresponding Dhall type
schemaToDhallType :: Schema -> Expr s a
schemaToDhallType Bool = D.Bool
@@ -777,13 +771,17 @@ schemaToDhallType ArbitraryJSON =
D.Pi "_" (D.Const D.Type)
(D.Pi "_"
(D.Record
- [ ("array" , D.Pi "_" (D.App D.List (V 0)) (V 1))
- , ("bool" , D.Pi "_" D.Bool (V 1))
- , ("double", D.Pi "_" D.Double (V 1))
- , ("integer", D.Pi "_" D.Integer (V 1))
- , ("null" , V 0)
- , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))
- , ("string", D.Pi "_" D.Text (V 1))
+ [ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List (V 0)) (V 1))
+ , ("bool" , D.makeRecordField $ D.Pi "_" D.Bool (V 1))
+ , ("double", D.makeRecordField $ D.Pi "_" D.Double (V 1))
+ , ("integer", D.makeRecordField $ D.Pi "_" D.Integer (V 1))
+ , ("null" , D.makeRecordField $ V 0)
+ , ("object", D.makeRecordField $
+ D.Pi "_" (D.App D.List (D.Record
+ [ ("mapKey", D.makeRecordField D.Text)
+ , ("mapValue", D.makeRecordField $ V 0)
+ ])) (V 1))
+ , ("string", D.makeRecordField $ D.Pi "_" D.Text (V 1))
]
)
(V 1)
@@ -848,7 +846,7 @@ dhallFromJSON (Conversion {..}) expressionType =
= Right (D.ListLit (Just t) [])
| otherwise
= Left (MissingKey k t v jsonPath)
- in D.RecordLit <$> Map.traverseWithKey f r
+ in D.RecordLit . fmap D.makeRecordField <$> Map.traverseWithKey f (D.recordFieldValue <$> r)
-- key-value list ~> Record
loop jsonPath t@(D.Record _) v@(Aeson.Array a)
@@ -865,8 +863,8 @@ dhallFromJSON (Conversion {..}) expressionType =
loop jsonPath t@(App D.List (D.Record r)) v@(Aeson.Object o)
| not noKeyValMap
, ["mapKey", "mapValue"] == Map.keys r
- , Just mapKey <- Map.lookup "mapKey" r
- , Just mapValue <- Map.lookup "mapValue" r
+ , Just mapKey <- D.recordFieldValue <$> Map.lookup "mapKey" r
+ , Just mapValue <- D.recordFieldValue <$> Map.lookup "mapValue" r
= do
keyExprMap <- HM.traverseWithKey (\k child -> loop (Aeson.Types.Key k : jsonPath) mapValue child) o
@@ -877,10 +875,10 @@ dhallFromJSON (Conversion {..}) expressionType =
_ -> Left (Mismatch t v jsonPath)
let f :: (Text, ExprX) -> ExprX
- f (key, val) = D.RecordLit ( Map.fromList
+ f (key, val) = D.RecordLit $ D.makeRecordField <$> Map.fromList
[ ("mapKey" , toKey key)
, ("mapValue", val)
- ] )
+ ]
let records = (fmap f . Seq.fromList . HM.toList) keyExprMap
@@ -947,12 +945,16 @@ dhallFromJSON (Conversion {..}) expressionType =
(D.Pi _ (D.Const D.Type)
(D.Pi _
(D.Record
- [ ("array" , D.Pi _ (D.App D.List (V 0)) (V 1))
- , ("bool" , D.Pi _ D.Bool (V 1))
- , ("null" , V 0)
- , ("number", D.Pi _ D.Double (V 1))
- , ("object", D.Pi _ (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))
- , ("string", D.Pi _ D.Text (V 1))
+ [ ("array" , D.recordFieldValue -> D.Pi _ (D.App D.List (V 0)) (V 1))
+ , ("bool" , D.recordFieldValue -> D.Pi _ D.Bool (V 1))
+ , ("null" , D.recordFieldValue -> V 0)
+ , ("number", D.recordFieldValue -> D.Pi _ D.Double (V 1))
+ , ("object", D.recordFieldValue ->
+ D.Pi _ (D.App D.List (D.Record
+ [ ("mapKey", D.recordFieldValue -> D.Text)
+ , ("mapValue", D.recordFieldValue -> V 0)
+ ])) (V 1))
+ , ("string", D.recordFieldValue -> D.Pi _ D.Text (V 1))
]
)
(V 1)
@@ -962,8 +964,8 @@ dhallFromJSON (Conversion {..}) expressionType =
let outer (Aeson.Object o) =
let inner (key, val) =
D.RecordLit
- [ ("mapKey" , D.TextLit (D.Chunks [] key))
- , ("mapValue", outer val )
+ [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))
+ , ("mapValue", D.makeRecordField $ outer val )
]
elements =
@@ -977,7 +979,10 @@ dhallFromJSON (Conversion {..}) expressionType =
elementType
| null elements =
- Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ]))
+ Just (D.App D.List (D.Record
+ [ ("mapKey", D.makeRecordField D.Text)
+ , ("mapValue", D.makeRecordField "JSON")
+ ]))
| otherwise =
Nothing
@@ -1005,12 +1010,16 @@ dhallFromJSON (Conversion {..}) expressionType =
D.Lam "JSON" (D.Const D.Type)
(D.Lam "json"
(D.Record
- [ ("array" , D.Pi "_" (D.App D.List "JSON") "JSON")
- , ("bool" , D.Pi "_" D.Bool "JSON")
- , ("null" , "JSON")
- , ("number", D.Pi "_" D.Double "JSON")
- , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON")])) "JSON")
- , ("string", D.Pi "_" D.Text "JSON")
+ [ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON")
+ , ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON")
+ , ("null" , D.makeRecordField "JSON")
+ , ("number", D.makeRecordField $ D.Pi "_" D.Double "JSON")
+ , ("object", D.makeRecordField $
+ D.Pi "_" (D.App D.List (D.Record
+ [ ("mapKey", D.makeRecordField D.Text)
+ , ("mapValue", D.makeRecordField "JSON")
+ ])) "JSON")
+ , ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON")
]
)
(outer value)
@@ -1024,13 +1033,17 @@ dhallFromJSON (Conversion {..}) expressionType =
(D.Pi _ (D.Const D.Type)
(D.Pi _
(D.Record
- [ ("array" , D.Pi _ (D.App D.List (V 0)) (V 1))
- , ("bool" , D.Pi _ D.Bool (V 1))
- , ("double", D.Pi _ D.Double (V 1))
- , ("integer", D.Pi _ D.Integer (V 1))
- , ("null" , V 0)
- , ("object", D.Pi _ (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))
- , ("string", D.Pi _ D.Text (V 1))
+ [ ("array" , D.recordFieldValue -> D.Pi _ (D.App D.List (V 0)) (V 1))
+ , ("bool" , D.recordFieldValue -> D.Pi _ D.Bool (V 1))
+ , ("double", D.recordFieldValue -> D.Pi _ D.Double (V 1))
+ , ("integer", D.recordFieldValue -> D.Pi _ D.Integer (V 1))
+ , ("null" , D.recordFieldValue -> V 0)
+ , ("object", D.recordFieldValue ->
+ D.Pi _ (D.App D.List (D.Record
+ [ ("mapKey", D.recordFieldValue -> D.Text)
+ , ("mapValue", D.recordFieldValue -> V 0)
+ ])) (V 1))
+ , ("string", D.recordFieldValue -> D.Pi _ D.Text (V 1))
]
)
(V 1)
@@ -1040,8 +1053,8 @@ dhallFromJSON (Conversion {..}) expressionType =
let outer (Aeson.Object o) =
let inner (key, val) =
D.RecordLit
- [ ("mapKey" , D.TextLit (D.Chunks [] key))
- , ("mapValue", outer val )
+ [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))
+ , ("mapValue", D.makeRecordField $ outer val )
]
elements =
@@ -1055,7 +1068,9 @@ dhallFromJSON (Conversion {..}) expressionType =
elementType
| null elements =
- Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ]))
+ Just (D.App D.List (D.Record
+ [ ("mapKey", D.makeRecordField D.Text)
+ , ("mapValue", D.makeRecordField "JSON") ]))
| otherwise =
Nothing
@@ -1085,13 +1100,16 @@ dhallFromJSON (Conversion {..}) expressionType =
D.Lam "JSON" (D.Const D.Type)
(D.Lam "json"
(D.Record
- [ ("array" , D.Pi "_" (D.App D.List "JSON") "JSON")
- , ("bool" , D.Pi "_" D.Bool "JSON")
- , ("double", D.Pi "_" D.Double "JSON")
- , ("integer", D.Pi "_" D.Integer "JSON")
- , ("null" , "JSON")
- , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON")])) "JSON")
- , ("string", D.Pi "_" D.Text "JSON")
+ [ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON")
+ , ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON")
+ , ("double", D.makeRecordField $ D.Pi "_" D.Double "JSON")
+ , ("integer", D.makeRecordField $ D.Pi "_" D.Integer "JSON")
+ , ("null" , D.makeRecordField "JSON")
+ , ("object", D.makeRecordField $ D.Pi "_"
+ (D.App D.List (D.Record
+ [ ("mapKey", D.makeRecordField D.Text)
+ , ("mapValue", D.makeRecordField "JSON")])) "JSON")
+ , ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON")
]
)
(outer value)
diff --git a/tasty/Main.hs b/tasty/Main.hs
index c494445..c732fe2 100644
--- a/tasty/Main.hs
+++ b/tasty/Main.hs
@@ -1,10 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Data.Monoid ((<>))
import Data.Void (Void)
import Test.Tasty (TestTree)
@@ -77,7 +75,7 @@ testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do
text <- Data.Text.IO.readFile inputFile
- parsedExpression <- do
+ parsedExpression <-
Core.throws (Dhall.Parser.exprFromText inputFile text)
resolvedExpression <- Dhall.Import.load parsedExpression
@@ -87,7 +85,7 @@ testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do
let convertedExpression =
Dhall.JSON.convertToHomogeneousMaps Dhall.JSON.defaultConversion resolvedExpression
- actualValue <- do
+ actualValue <-
Core.throws (Dhall.JSON.dhallToJSON convertedExpression)
bytes <- Data.ByteString.Lazy.readFile outputFile
@@ -121,12 +119,12 @@ testCustomConversionJSONToDhall infer conv prefix =
_ <- Core.throws (Dhall.TypeCheck.typeOf schema)
- actualExpression <- do
+ actualExpression <-
Core.throws (JSONToDhall.dhallFromJSON conv schema value)
outputText <- Data.Text.IO.readFile outputFile
- parsedExpression <- do
+ parsedExpression <-
Core.throws (Dhall.Parser.exprFromText outputFile outputText)
resolvedExpression <- Dhall.Import.load parsedExpression