diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +1.7.2 + +* [The `--documents` flag now wraps non-`List`s in a document](https://github.com/dhall-lang/dhall-haskell/pull/1977) + 1.7.1 * [Format documents with leading `---`](https://github.com/dhall-lang/dhall-haskell/pull/1865) diff --git a/dhall-json.cabal b/dhall-json.cabal --- a/dhall-json.cabal +++ b/dhall-json.cabal @@ -1,5 +1,5 @@ Name: dhall-json -Version: 1.7.1 +Version: 1.7.2 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.4.3, GHC == 8.6.1 @@ -39,16 +39,16 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.11.0.0 && < 5 , - aeson >= 1.0.0.0 && < 1.6 , + aeson >= 1.4.6.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, + dhall >= 1.35.0 && < 1.36, 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, + optparse-applicative >= 0.14.0.0 && < 0.17, prettyprinter >= 1.5.1 && < 1.8 , scientific >= 0.3.0.0 && < 0.4 , text >= 0.11.1.0 && < 1.3 , @@ -98,7 +98,7 @@ Build-Depends: base , aeson , - ansi-terminal >= 0.6.3.1 && < 0.11, + ansi-terminal >= 0.6.3.1 && < 0.12, bytestring < 0.11, dhall , dhall-json , diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- a/src/Dhall/JSON.hs +++ b/src/Dhall/JSON.hs @@ -223,7 +223,7 @@ import Data.Void (Void) import Dhall.Core (Binding (..), DhallDouble (..), Expr) import Dhall.Import (SemanticCacheMode (..)) -import Dhall.JSON.Util (pattern V) +import Dhall.JSON.Util (pattern FA, pattern V) import Dhall.Map (Map) import Options.Applicative (Parser) import Prelude hiding (getContents) @@ -447,7 +447,7 @@ , ("Nested", Just Core.Text) ] ) - "Nested" + (FA "Nested") ) (Core.TextLit (Core.Chunks [] nestedField) @@ -499,9 +499,9 @@ 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.Field (Core.Union _) (FA k) -> return (Aeson.toJSON k) + Core.Lam (Core.functionBindingAnnotation -> Core.Const Core.Type) + (Core.Lam (Core.functionBindingAnnotation -> (Core.Record [ ("array" , Core.recordFieldValue -> Core.Pi _ (Core.App Core.List (V 0)) (V 1)) , ("bool" , Core.recordFieldValue -> Core.Pi _ Core.Bool (V 1)) @@ -513,17 +513,17 @@ , ("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") = return Aeson.Null - outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = + let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null + outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) = return (Aeson.Bool b) - outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do + outer (Core.App (Core.Field (V 0) (FA "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 + outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do let inner (Core.RecordLit [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey)) , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do @@ -535,15 +535,15 @@ ys <- traverse inner (Foldable.toList xs) return (Aeson.Object (HashMap.fromList ys)) - outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) = + outer (Core.App (Core.Field (V 0) (FA "number")) (Core.DoubleLit (DhallDouble n))) = return (Aeson.toJSON n) - outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = + outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) = return (toJSON text) outer _ = Left (Unsupported e) outer value - Core.Lam _ (Core.Const Core.Type) - (Core.Lam _ + Core.Lam (Core.functionBindingAnnotation -> Core.Const Core.Type) + (Core.Lam (Core.functionBindingAnnotation -> (Core.Record [ ("array" , Core.recordFieldValue -> Core.Pi _ (Core.App Core.List (V 0)) (V 1)) , ("bool" , Core.recordFieldValue -> Core.Pi _ Core.Bool (V 1)) @@ -557,18 +557,18 @@ ])) (V 1)) , ("string", Core.recordFieldValue -> Core.Pi _ Core.Text (V 1)) ] - ) + )) value ) -> do - let outer (Core.Field (V 0) "null") = + let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null - outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = + outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) = return (Aeson.Bool b) - outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do + outer (Core.App (Core.Field (V 0) (FA "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 + outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do let inner (Core.RecordLit [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey)) , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do @@ -580,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))) = + outer (Core.App (Core.Field (V 0) (FA "double")) (Core.DoubleLit (DhallDouble n))) = return (Aeson.toJSON n) - outer (Core.App (Core.Field (V 0) "integer") (Core.IntegerLit n)) = + outer (Core.App (Core.Field (V 0) (FA "integer")) (Core.IntegerLit n)) = return (Aeson.toJSON n) - outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = + outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) = return (toJSON text) outer _ = Left (Unsupported e) @@ -595,11 +595,11 @@ getContents (Core.App (Core.Field _ - alternativeName + (FA alternativeName) ) expression ) = Just (alternativeName, Just expression) -getContents (Core.Field _ alternativeName) = Just (alternativeName, Nothing) +getContents (Core.Field _ (FA alternativeName)) = Just (alternativeName, Nothing) getContents _ = Nothing isInlineNesting :: Expr s Void -> Bool @@ -610,7 +610,7 @@ , ("Nested", Just Core.Text) ] ) - "Inline" + (FA "Inline") ) (Core.RecordLit []) ) = True @@ -620,7 +620,7 @@ , ("Nested", Just Core.Text) ] ) - "Inline" + (FA "Inline") ) = True isInlineNesting _ = False @@ -728,8 +728,8 @@ case we do *not* want to perform this rewrite since it will interfere with decoding the value. -} - Core.Lam a b c -> - Core.Lam a b c + Core.Lam a b -> + Core.Lam a b Core.Pi a b c -> Core.Pi a b' c' @@ -900,7 +900,7 @@ Core.TextLit (Core.Chunks [] keyText) -> return keyText - Core.Field (Core.Union _) keyText -> + Core.Field (Core.Union _) (FA keyText) -> return keyText _ -> diff --git a/src/Dhall/JSON/Util.hs b/src/Dhall/JSON/Util.hs --- a/src/Dhall/JSON/Util.hs +++ b/src/Dhall/JSON/Util.hs @@ -3,11 +3,17 @@ module Dhall.JSON.Util ( pattern V + , pattern FA ) where -import Dhall.Core (Expr) +import Data.Text (Text) +import Dhall.Core (Expr, FieldSelection) import qualified Dhall.Core as Core pattern V :: Int -> Expr s a pattern V n = Core.Var (Core.V "_" n) + +pattern FA :: Text -> FieldSelection s +pattern FA t <- Core.FieldSelection _ t _ + where FA = Core.makeFieldSelection 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 @@ -56,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. Each document, including the first one, will be preceded by \"---\", even if there is only one document" + <> 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. If not given a list, output a single document (as if it were a list of one element)" ) parseQuoted :: Parser Bool @@ -106,6 +106,11 @@ then Data.Aeson.Yaml.encodeQuotedDocuments else Data.Aeson.Yaml.encodeDocuments ) (Data.Vector.toList elems) + (True, value) + -> (if quoted + then Data.Aeson.Yaml.encodeQuotedDocuments + else Data.Aeson.Yaml.encodeDocuments + ) [ value ] _ -> (if quoted then Data.Aeson.Yaml.encodeQuoted else Data.Aeson.Yaml.encode diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs --- a/src/Dhall/JSONToDhall.hs +++ b/src/Dhall/JSONToDhall.hs @@ -373,7 +373,7 @@ import Data.Text (Text) import Data.Void (Void) import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App)) -import Dhall.JSON.Util (pattern V) +import Dhall.JSON.Util (pattern FA, pattern V) import Dhall.Parser (Src) import Options.Applicative (Parser) @@ -814,12 +814,12 @@ Just _type -> do expression <- loop jsonPath _type v - return (D.App (D.Field t key) expression) + return (D.App (D.Field t $ FA key) expression) Nothing -> case v of Aeson.String text | key == text -> - return (D.Field t key) + return (D.Field t $ FA key) _ -> Left (Mismatch t v jsonPath) @@ -871,7 +871,7 @@ toKey <- case mapKey of D.Text -> return $ D.TextLit . Chunks [] - D.Union _ -> return $ D.Field mapKey + D.Union _ -> return $ D.Field mapKey . FA _ -> Left (Mismatch t v jsonPath) let f :: (Text, ExprX) -> ExprX @@ -988,7 +988,7 @@ keyValues = D.ListLit elementType elements - in D.App (D.Field "json" "object") keyValues + in D.App (D.Field "json" $ FA "object") keyValues outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) @@ -996,19 +996,19 @@ | null elements = Just (D.App D.List "JSON") | otherwise = Nothing - in D.App (D.Field "json" "array") (D.ListLit elementType elements) + in D.App (D.Field "json" $ FA "array") (D.ListLit elementType elements) outer (Aeson.String s) = - D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s)) + D.App (D.Field "json" $ FA "string") (D.TextLit (D.Chunks [] s)) outer (Aeson.Number n) = - D.App (D.Field "json" "number") (D.DoubleLit (DhallDouble (toRealFloat n))) + D.App (D.Field "json" $ FA "number") (D.DoubleLit (DhallDouble (toRealFloat n))) outer (Aeson.Bool b) = - D.App (D.Field "json" "bool") (D.BoolLit b) + D.App (D.Field "json" $ FA "bool") (D.BoolLit b) outer Aeson.Null = - D.Field "json" "null" + D.Field "json" $ FA "null" let result = - D.Lam "JSON" (D.Const D.Type) - (D.Lam "json" + D.Lam (D.makeFunctionBinding "JSON" (D.Const D.Type)) + (D.Lam (D.makeFunctionBinding "json" (D.Record [ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON") , ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON") @@ -1021,7 +1021,7 @@ ])) "JSON") , ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON") ] - ) + )) (outer value) ) @@ -1076,7 +1076,7 @@ keyValues = D.ListLit elementType elements - in D.App (D.Field "json" "object") keyValues + in D.App (D.Field "json" (FA "object")) keyValues outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) @@ -1084,21 +1084,21 @@ | null elements = Just (D.App D.List "JSON") | otherwise = Nothing - in D.App (D.Field "json" "array") (D.ListLit elementType elements) + in D.App (D.Field "json" (FA "array")) (D.ListLit elementType elements) outer (Aeson.String s) = - D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s)) + D.App (D.Field "json" (FA "string")) (D.TextLit (D.Chunks [] s)) outer (Aeson.Number n) = case floatingOrInteger n of - Left floating -> D.App (D.Field "json" "double") (D.DoubleLit (DhallDouble floating)) - Right integer -> D.App (D.Field "json" "integer") (D.IntegerLit integer) + Left floating -> D.App (D.Field "json" (FA "double")) (D.DoubleLit (DhallDouble floating)) + Right integer -> D.App (D.Field "json" (FA "integer")) (D.IntegerLit integer) outer (Aeson.Bool b) = - D.App (D.Field "json" "bool") (D.BoolLit b) + D.App (D.Field "json" (FA "bool")) (D.BoolLit b) outer Aeson.Null = - D.Field "json" "null" + D.Field "json" (FA "null") let result = - D.Lam "JSON" (D.Const D.Type) - (D.Lam "json" + D.Lam (D.makeFunctionBinding "JSON" (D.Const D.Type)) + (D.Lam (D.makeFunctionBinding "json" (D.Record [ ("array" , D.makeRecordField $ D.Pi "_" (D.App D.List "JSON") "JSON") , ("bool" , D.makeRecordField $ D.Pi "_" D.Bool "JSON") @@ -1111,7 +1111,7 @@ , ("mapValue", D.makeRecordField "JSON")])) "JSON") , ("string", D.makeRecordField $ D.Pi "_" D.Text "JSON") ] - ) + )) (outer value) )