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.2.0 +Version: 1.2.1 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.2, GHC == 8.0.1 @@ -30,8 +30,8 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.8.0.0 && < 5 , - aeson >= 1.0.0.0 && < 1.4 , - dhall >= 1.14.0 && < 1.15, + aeson >= 1.0.0.0 && < 1.5 , + dhall >= 1.15.0 && < 1.16, insert-ordered-containers < 1.14, optparse-applicative >= 0.14.0.0 && < 0.15, text >= 0.11.1.0 && < 1.3 , 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 @@ -70,9 +70,14 @@ Options {..} <- Options.Applicative.execParser parserInfo handle $ do + let config = Data.Aeson.Encode.Pretty.Config + { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2 + , Data.Aeson.Encode.Pretty.confCompare = compare + , Data.Aeson.Encode.Pretty.confNumFormat = Data.Aeson.Encode.Pretty.Generic + , Data.Aeson.Encode.Pretty.confTrailingNewline = False } let encode = if pretty - then Data.Aeson.Encode.Pretty.encodePretty + then Data.Aeson.Encode.Pretty.encodePretty' config else Data.Aeson.encode let explaining = if explain then Dhall.detailed else id diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- a/src/Dhall/JSON.hs +++ b/src/Dhall/JSON.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -91,6 +92,65 @@ > $ dhall-to-json <<< "./config" > [{"age":47,"name":"John"},{"location":"North Pole"},{"location":"Sahara Desert"},{"age":35,"name":"Alice"}] + You can preserve the name of the alternative if you wrap the value in a + record with three fields: + + * @contents@: The union literal that you want to preserve the tag of + + * @field@: the name of the field that will store the name of the + alternative + + * @nesting@: A value of type @\< Inline : {} | Nested : Text \>@. + + If @nesting@ is set to @Inline@ and the union literal stored in @contents@ + contains a record then the name of the alternative is stored inline within + the same record. For example, this code: + +> let Example = < Left : { foo : Natural } | Right : { bar : Bool } > +> +> in let example = constructors Example +> +> in let Nesting = < Inline : {} | Nested : Text > +> +> in let nesting = constructors Nesting +> +> in { field = "name" +> , nesting = nesting.Inline {=} +> , contents = example.Left { foo = 2 } +> } + + ... produces this JSON: + +> { +> "foo": 2, +> "name": "Left" +> } + + If @nesting@ is set to @Nested nestedField@ then the union is store + underneath a field named @nestedField@. For example, this code: + +> let Example = < Left : { foo : Natural } | Right : { bar : Bool } > +> +> in let example = constructors Example +> +> in let Nesting = < Inline : {} | Nested : Text > +> +> in let nesting = constructors Nesting +> +> in { field = "name" +> , nesting = nesting.Nested "value" +> , contents = example.Left { foo = 2 } +> } + + ... produces this JSON: + +> { +> "name": "Left", +> "value": { +> "foo": 2 +> } +> } + Also, all Dhall expressions are normalized before translation to JSON: > $ dhall-to-json <<< "True == False" @@ -115,8 +175,9 @@ import Control.Monad (guard) import Control.Exception (Exception, throwIO) import Data.Aeson (Value(..)) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.Monoid ((<>)) -import Data.Text.Lazy (Text) +import Data.Text (Text) import Data.Typeable (Typeable) import Dhall.Core (Expr) import Dhall.TypeCheck (X) @@ -126,9 +187,9 @@ import qualified Data.Foldable import qualified Data.HashMap.Strict import qualified Data.HashMap.Strict.InsOrd +import qualified Data.List +import qualified Data.Ord import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Parser @@ -155,7 +216,7 @@ \ \n\ \↳ " <> txt <> " " where - txt = Data.Text.Lazy.toStrict (Dhall.Core.pretty e) + txt = Dhall.Core.pretty e _ERROR :: Data.Text.Text _ERROR = "\ESC[1;31mError\ESC[0m" @@ -181,19 +242,86 @@ Dhall.Core.IntegerLit a -> return (Data.Aeson.toJSON a) Dhall.Core.DoubleLit a -> return (Data.Aeson.toJSON a) Dhall.Core.TextLit (Dhall.Core.Chunks [] a) -> do - return (Data.Aeson.toJSON (Data.Text.Lazy.Builder.toLazyText a)) + return (Data.Aeson.toJSON a) Dhall.Core.ListLit _ a -> do a' <- traverse loop a return (Data.Aeson.toJSON a') Dhall.Core.OptionalLit _ a -> do a' <- traverse loop a return (Data.Aeson.toJSON a') - Dhall.Core.RecordLit a -> do - a' <- traverse loop a - return (Data.Aeson.toJSON a') + Dhall.Core.RecordLit a -> + case toOrderedList a of + [ ( "contents" + , Dhall.Core.UnionLit alternativeName contents _ + ) + , ( "field" + , Dhall.Core.TextLit + (Dhall.Core.Chunks [] field) + ) + , ( "nesting" + , Dhall.Core.UnionLit + "Nested" + (Dhall.Core.TextLit + (Dhall.Core.Chunks [] nestedField) + ) + [ ("Inline", Dhall.Core.Record []) ] + ) + ] -> do + contents' <- loop contents + + let taggedValue = + Data.HashMap.Strict.InsOrd.fromList + [ ( field + , Data.Aeson.toJSON alternativeName + ) + , ( nestedField + , contents' + ) + ] + + return (Data.Aeson.toJSON taggedValue) + + [ ( "contents" + , Dhall.Core.UnionLit + alternativeName + (Dhall.Core.RecordLit contents) + _ + ) + , ( "field" + , Dhall.Core.TextLit + (Dhall.Core.Chunks [] field) + ) + , ( "nesting" + , Dhall.Core.UnionLit + "Inline" + (Dhall.Core.RecordLit []) + [ ("Nested", Dhall.Core.Text) ] + ) + ] -> do + let contents' = + Data.HashMap.Strict.InsOrd.insert + field + (Dhall.Core.TextLit + (Dhall.Core.Chunks + [] + alternativeName + ) + ) + contents + + loop (Dhall.Core.RecordLit contents') + _ -> do + a' <- traverse loop a + return (Data.Aeson.toJSON a') Dhall.Core.UnionLit _ b _ -> loop b _ -> Left (Unsupported e) +toOrderedList :: Ord k => InsOrdHashMap k v -> [(k, v)] +toOrderedList = + Data.List.sortBy (Data.Ord.comparing fst) + . Data.HashMap.Strict.toList + . Data.HashMap.Strict.InsOrd.toHashMap + -- | Omit record fields that are @null@ omitNull :: Value -> Value omitNull (Object object) = @@ -353,6 +481,9 @@ Dhall.Core.IntegerShow -> Dhall.Core.IntegerShow + Dhall.Core.IntegerToDouble -> + Dhall.Core.IntegerToDouble + Dhall.Core.Double -> Dhall.Core.Double @@ -400,7 +531,7 @@ _ -> empty - return (Data.Text.Lazy.Builder.toLazyText keyText, value) + return (keyText, value) toKeyValue _ = do empty @@ -530,6 +661,12 @@ where a' = loop a + Dhall.Core.ImportAlt a b -> + Dhall.Core.ImportAlt a' b' + where + a' = loop a + b' = loop b + Dhall.Core.Note a b -> Dhall.Core.Note a b' where @@ -553,7 +690,7 @@ ( Options.Applicative.long "key" <> Options.Applicative.help "Reserved key field name for association lists" <> Options.Applicative.value "mapKey" - <> Options.Applicative.showDefaultWith Data.Text.Lazy.unpack + <> Options.Applicative.showDefaultWith Data.Text.unpack ) parseValueField = @@ -561,7 +698,7 @@ ( Options.Applicative.long "value" <> Options.Applicative.help "Reserved value field name for association lists" <> Options.Applicative.value "mapValue" - <> Options.Applicative.showDefaultWith Data.Text.Lazy.unpack + <> Options.Applicative.showDefaultWith Data.Text.unpack ) noConversion = @@ -581,11 +718,11 @@ -} codeToValue :: Conversion - -> Data.Text.Text -- ^ Describe the input for the sake of error location. - -> Data.Text.Text -- ^ Input text. + -> Text -- ^ Describe the input for the sake of error location. + -> Text -- ^ Input text. -> IO Value codeToValue conversion name code = do - parsedExpression <- case Dhall.Parser.exprFromText (Data.Text.unpack name) (Data.Text.Lazy.fromStrict code) of + parsedExpression <- case Dhall.Parser.exprFromText (Data.Text.unpack name) code of Left err -> Control.Exception.throwIO err Right parsedExpression -> return parsedExpression