summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2018-06-29 04:43:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-06-29 04:43:00 (GMT)
commit988a142ff2ae6d7ff50cbfbd8ffa4b3fdb64b29a (patch)
tree7f8c555c8110b58d5ba242a1971c794c7ea31172
parentd0d9803a1e0698752889902233f6956955d4c0ec (diff)
version 1.2.11.2.1
-rw-r--r--dhall-json.cabal6
-rw-r--r--dhall-to-json/Main.hs7
-rw-r--r--src/Dhall/JSON.hs165
3 files changed, 160 insertions, 18 deletions
diff --git a/dhall-json.cabal b/dhall-json.cabal
index 4b9bee1..f16d238 100644
--- 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 @@ Library
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
index e7191ed..f1fda41 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -70,9 +70,14 @@ main = do
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
index a66736e..12b4f48 100644
--- 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.Applicative (empty, (<|>))
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.Aeson
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 @@ instance Show CompileError where
\ \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 @@ dhallToJSON e0 = loop (Dhall.Core.normalize e0)
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 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
Dhall.Core.IntegerShow ->
Dhall.Core.IntegerShow
+ Dhall.Core.IntegerToDouble ->
+ Dhall.Core.IntegerToDouble
+
Dhall.Core.Double ->
Dhall.Core.Double
@@ -400,7 +531,7 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
_ ->
empty
- return (Data.Text.Lazy.Builder.toLazyText keyText, value)
+ return (keyText, value)
toKeyValue _ = do
empty
@@ -530,6 +661,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
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 @@ parseConversion =
( 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 @@ parseConversion =
( 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 @@ parseConversion =
-}
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