dhall-json 1.7.0 → 1.7.1
raw patch · 9 files changed
+176/−155 lines, 9 filesdep +lens-family-coredep −semigroupsdep ~aeson-yamldep ~ansi-terminaldep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: lens-family-core
Dependencies removed: semigroups
Dependency ranges changed: aeson-yaml, ansi-terminal, base, dhall, optparse-applicative, prettyprinter
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- dhall-json.cabal +17/−18
- dhall-to-json/Main.hs +8/−9
- json-to-dhall/Main.hs +10/−13
- src/Dhall/DhallToYaml/Main.hs +0/−1
- src/Dhall/JSON.hs +56/−50
- src/Dhall/JSON/Yaml.hs +1/−2
- src/Dhall/JSONToDhall.hs +73/−55
- tasty/Main.hs +5/−7
CHANGELOG.md view
@@ -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)
dhall-json.cabal view
@@ -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 @@ 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 @@ 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
dhall-to-json/Main.hs view
@@ -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 @@ 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
json-to-dhall/Main.hs view
@@ -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.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 @@ Text.IO.hPutStrLn h "" case options of- Version -> do+ Version -> putStrLn (showVersion Meta.version) Default{..} -> do
src/Dhall/DhallToYaml/Main.hs view
@@ -8,7 +8,6 @@ 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)
src/Dhall/JSON.hs view
@@ -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.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.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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ empty return (keyText, value)- toKeyValue _ = do+ toKeyValue _ = empty transform =@@ -911,13 +919,12 @@ 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 @@ 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 @@ case dhallToJSON specialDoubleExpression of Left err -> Control.Exception.throwIO err Right json -> return json-
src/Dhall/JSON/Yaml.hs view
@@ -17,7 +17,6 @@ ) 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 = 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
src/Dhall/JSONToDhall.hs view
@@ -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.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 @@ 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 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 @@ 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 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 @@ 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 @@ = 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 @@ 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 @@ _ -> 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 @@ (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 @@ 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 @@ 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 @@ 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 @@ (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 @@ 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 @@ 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 @@ 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)
tasty/Main.hs view
@@ -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 @@ 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 @@ 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 @@ _ <- 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