diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- 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 @@ 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 diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs --- 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 @@ 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 --- 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.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 diff --git a/src/Dhall/DhallToYaml/Main.hs b/src/Dhall/DhallToYaml/Main.hs --- a/src/Dhall/DhallToYaml/Main.hs +++ b/src/Dhall/DhallToYaml/Main.hs @@ -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) diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- 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.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 - diff --git a/src/Dhall/JSON/Yaml.hs b/src/Dhall/JSON/Yaml.hs --- a/src/Dhall/JSON/Yaml.hs +++ b/src/Dhall/JSON/Yaml.hs @@ -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 diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs --- 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.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) diff --git a/tasty/Main.hs b/tasty/Main.hs --- 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 @@ 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