summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2018-05-19 17:50:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-05-19 17:50:00 (GMT)
commitd0d9803a1e0698752889902233f6956955d4c0ec (patch)
treec7467dbb52fa729a7bbbed15929ec9c9ca7dae04
parentfb2be9465e7579b709852e4bc28975510dcc0791 (diff)
version 1.2.01.2.0
-rw-r--r--dhall-json.cabal30
-rw-r--r--dhall-to-json/Main.hs81
-rw-r--r--dhall-to-yaml/Main.hs62
-rw-r--r--src/Dhall/JSON.hs396
4 files changed, 510 insertions, 59 deletions
diff --git a/dhall-json.cabal b/dhall-json.cabal
index f23375e..4b9bee1 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -1,5 +1,5 @@
Name: dhall-json
-Version: 1.1.0
+Version: 1.2.0
Cabal-Version: >=1.8.0.2
Build-Type: Simple
Tested-With: GHC == 7.10.2, GHC == 8.0.1
@@ -29,11 +29,13 @@ Source-Repository head
Library
Hs-Source-Dirs: src
Build-Depends:
- base >= 4.8.0.0 && < 5 ,
- aeson >= 1.0.0.0 && < 1.4 ,
- dhall >= 1.11.0 && < 1.14,
- text >= 0.11.1.0 && < 1.3 ,
- unordered-containers < 0.3
+ base >= 4.8.0.0 && < 5 ,
+ aeson >= 1.0.0.0 && < 1.4 ,
+ dhall >= 1.14.0 && < 1.15,
+ insert-ordered-containers < 1.14,
+ optparse-applicative >= 0.14.0.0 && < 0.15,
+ text >= 0.11.1.0 && < 1.3 ,
+ unordered-containers < 0.3
Exposed-Modules: Dhall.JSON
GHC-Options: -Wall
@@ -41,13 +43,13 @@ Executable dhall-to-json
Hs-Source-Dirs: dhall-to-json
Main-Is: Main.hs
Build-Depends:
- base ,
- aeson ,
- aeson-pretty < 0.9 ,
- bytestring < 0.11,
- dhall ,
- dhall-json ,
- optparse-generic >= 1.1.1 && < 1.4 ,
+ base ,
+ aeson ,
+ aeson-pretty < 0.9 ,
+ bytestring < 0.11,
+ dhall ,
+ dhall-json ,
+ optparse-applicative ,
text
GHC-Options: -Wall
@@ -59,7 +61,7 @@ Executable dhall-to-yaml
bytestring < 0.11,
dhall ,
dhall-json ,
- optparse-generic >= 1.1.1 && < 1.4 ,
+ optparse-applicative ,
yaml >= 0.5.0 && < 0.9 ,
text
GHC-Options: -Wall
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index db0c9a4..e7191ed 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Exception (SomeException)
-import Options.Generic (Generic, ParseRecord, type (<?>))
+import Data.Monoid ((<>))
+import Dhall.JSON (Conversion)
+import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.Aeson
@@ -19,32 +18,72 @@ import qualified Data.Text.IO
import qualified Dhall
import qualified Dhall.JSON
import qualified GHC.IO.Encoding
-import qualified Options.Generic
+import qualified Options.Applicative
import qualified System.Exit
import qualified System.IO
data Options = Options
- { explain :: Bool <?> "Explain error messages in detail"
- , pretty :: Bool <?> "Pretty print generated JSON"
- , omitNull :: Bool <?> "Omit record fields that are null"
- } deriving (Generic, ParseRecord)
+ { explain :: Bool
+ , pretty :: Bool
+ , omitNull :: Bool
+ , conversion :: Conversion
+ }
+
+parseOptions :: Parser Options
+parseOptions = Options.Applicative.helper <*> do
+ explain <- parseExplain
+ pretty <- parsePretty
+ omitNull <- parseOmitNull
+ conversion <- Dhall.JSON.parseConversion
+ return (Options {..})
+ where
+ parseExplain =
+ Options.Applicative.switch
+ ( Options.Applicative.long "explain"
+ <> Options.Applicative.help "Explain error messages in detail"
+ )
+
+ parsePretty =
+ Options.Applicative.switch
+ ( Options.Applicative.long "pretty"
+ <> Options.Applicative.help "Pretty print generated JSON"
+ )
+
+ parseOmitNull =
+ Options.Applicative.switch
+ ( Options.Applicative.long "omitNull"
+ <> Options.Applicative.help "Omit record fields that are null"
+ )
+
+parserInfo :: ParserInfo Options
+parserInfo =
+ Options.Applicative.info
+ parseOptions
+ ( Options.Applicative.fullDesc
+ <> Options.Applicative.progDesc "Compile Dhall to JSON"
+ )
main :: IO ()
-main = handle $ do
+main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- Options {..} <- Options.Generic.getRecord "Compile Dhall to JSON"
- let encode = if Options.Generic.unHelpful pretty
- then Data.Aeson.Encode.Pretty.encodePretty
- else Data.Aeson.encode
- explaining = if Options.Generic.unHelpful explain then Dhall.detailed else id
- omittingNull = if Options.Generic.unHelpful omitNull then Dhall.JSON.omitNull else id
+ Options {..} <- Options.Applicative.execParser parserInfo
+
+ handle $ do
+ let encode =
+ if pretty
+ then Data.Aeson.Encode.Pretty.encodePretty
+ else Data.Aeson.encode
+
+ let explaining = if explain then Dhall.detailed else id
+
+ let omittingNull = if omitNull then Dhall.JSON.omitNull else id
- stdin <- Data.Text.IO.getContents
+ stdin <- Data.Text.IO.getContents
- json <- omittingNull <$> explaining (Dhall.JSON.codeToValue "(stdin)" stdin)
+ json <- omittingNull <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
- Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
+ Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
handle :: IO a -> IO a
handle = Control.Exception.handle handler
diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs
index 15369fb..56b7485 100644
--- a/dhall-to-yaml/Main.hs
+++ b/dhall-to-yaml/Main.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Exception (SomeException)
-import Options.Generic (Generic, ParseRecord, type (<?>))
+import Data.Monoid ((<>))
+import Dhall.JSON (Conversion)
+import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.ByteString
@@ -17,28 +16,59 @@ import qualified Data.Yaml
import qualified Dhall
import qualified Dhall.JSON
import qualified GHC.IO.Encoding
-import qualified Options.Generic
+import qualified Options.Applicative
import qualified System.Exit
import qualified System.IO
data Options = Options
- { explain :: Bool <?> "Explain error messages in detail"
- , omitNull :: Bool <?> "Omit record fields that are null"
- } deriving (Generic, ParseRecord)
+ { explain :: Bool
+ , omitNull :: Bool
+ , conversion :: Conversion
+ }
+
+parseOptions :: Parser Options
+parseOptions = Options.Applicative.helper <*> do
+ explain <- parseExplain
+ omitNull <- parseOmitNull
+ conversion <- Dhall.JSON.parseConversion
+ return (Options {..})
+ where
+ parseExplain =
+ Options.Applicative.switch
+ ( Options.Applicative.long "explain"
+ <> Options.Applicative.help "Explain error messages in detail"
+ )
+
+ parseOmitNull =
+ Options.Applicative.switch
+ ( Options.Applicative.long "omitNull"
+ <> Options.Applicative.help "Omit record fields that are null"
+ )
+
+parserInfo :: ParserInfo Options
+parserInfo =
+ Options.Applicative.info
+ parseOptions
+ ( Options.Applicative.fullDesc
+ <> Options.Applicative.progDesc "Compile Dhall to YAML"
+ )
main :: IO ()
-main = handle $ do
+main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- Options{..} <- Options.Generic.getRecord "Compile Dhall to JSON"
- let explaining = if Options.Generic.unHelpful explain then Dhall.detailed else id
- omittingNull = if Options.Generic.unHelpful omitNull then Dhall.JSON.omitNull else id
+ Options {..} <- Options.Applicative.execParser parserInfo
+
+ handle $ do
+ let explaining = if explain then Dhall.detailed else id
+
+ let omittingNull = if omitNull then Dhall.JSON.omitNull else id
- stdin <- Data.Text.IO.getContents
+ stdin <- Data.Text.IO.getContents
- json <- omittingNull <$> explaining (Dhall.JSON.codeToValue "(stdin)" stdin)
+ json <- omittingNull <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
- Data.ByteString.putStr $ Data.Yaml.encode json
+ Data.ByteString.putStr $ Data.Yaml.encode json
handle :: IO a -> IO a
handle = Control.Exception.handle handler
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index 196dfd7..a66736e 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-| 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@
@@ -100,21 +102,30 @@ module Dhall.JSON (
-- * Dhall to JSON
dhallToJSON
, omitNull
+ , Conversion(..)
+ , convertToHomogeneousMaps
+ , parseConversion
, codeToValue
-- * Exceptions
, CompileError(..)
) where
+import Control.Applicative (empty, (<|>))
+import Control.Monad (guard)
import Control.Exception (Exception, throwIO)
import Data.Aeson (Value(..))
import Data.Monoid ((<>))
+import Data.Text.Lazy (Text)
import Data.Typeable (Typeable)
import Dhall.Core (Expr)
import Dhall.TypeCheck (X)
+import Options.Applicative (Parser)
import qualified Data.Aeson
+import qualified Data.Foldable
import qualified Data.HashMap.Strict
+import qualified Data.HashMap.Strict.InsOrd
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
@@ -122,6 +133,7 @@ import qualified Dhall.Core
import qualified Dhall.Import
import qualified Dhall.Parser
import qualified Dhall.TypeCheck
+import qualified Options.Applicative
{-| This is the exception type for errors that might arise when translating
Dhall to JSON
@@ -197,6 +209,369 @@ omitNull (Bool bool) =
omitNull Null =
Null
+{-| Specify whether or not to convert association lists of type
+ @List { mapKey: Text, mapValue : v }@ to records
+-}
+data Conversion
+ = NoConversion
+ | Conversion { mapKey :: Text, mapValue :: Text }
+
+{-| Convert association lists to homogeneous maps
+
+ This converts an association list of the form:
+
+ > [ { mapKey = k0, mapValue = v0 }, { mapKey = k1, mapValue = v1 } ]
+
+ ... to a record of the form:
+
+ > { k0 = v0, k1 = v1 }
+-}
+convertToHomogeneousMaps :: Conversion -> Expr s X -> Expr s X
+convertToHomogeneousMaps NoConversion e0 = e0
+convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
+ where
+ loop e = case e of
+ Dhall.Core.Const a ->
+ Dhall.Core.Const a
+
+ Dhall.Core.Var v ->
+ Dhall.Core.Var v
+
+ Dhall.Core.Lam a b c ->
+ Dhall.Core.Lam a b' c'
+ where
+ b' = loop b
+ c' = loop c
+
+ Dhall.Core.Pi a b c ->
+ Dhall.Core.Pi a b' c'
+ where
+ b' = loop b
+ c' = loop c
+
+ Dhall.Core.App a b ->
+ Dhall.Core.App a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.Let a b c d ->
+ Dhall.Core.Let a b' c' d'
+ where
+ b' = fmap loop b
+ c' = loop c
+ d' = loop d
+
+ Dhall.Core.Annot a b ->
+ Dhall.Core.Annot a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.Bool ->
+ Dhall.Core.Bool
+
+ Dhall.Core.BoolLit a ->
+ Dhall.Core.BoolLit a
+
+ Dhall.Core.BoolAnd a b ->
+ Dhall.Core.BoolAnd a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.BoolOr a b ->
+ Dhall.Core.BoolOr a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.BoolEQ a b ->
+ Dhall.Core.BoolEQ a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.BoolNE a b ->
+ Dhall.Core.BoolNE a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.BoolIf a b c ->
+ Dhall.Core.BoolIf a' b' c'
+ where
+ a' = loop a
+ b' = loop b
+ c' = loop c
+
+ Dhall.Core.Natural ->
+ Dhall.Core.Natural
+
+ Dhall.Core.NaturalLit a ->
+ Dhall.Core.NaturalLit a
+
+ Dhall.Core.NaturalFold ->
+ Dhall.Core.NaturalFold
+
+ Dhall.Core.NaturalBuild ->
+ Dhall.Core.NaturalBuild
+
+ Dhall.Core.NaturalIsZero ->
+ Dhall.Core.NaturalIsZero
+
+ Dhall.Core.NaturalEven ->
+ Dhall.Core.NaturalEven
+
+ Dhall.Core.NaturalOdd ->
+ Dhall.Core.NaturalOdd
+
+ Dhall.Core.NaturalToInteger ->
+ Dhall.Core.NaturalToInteger
+
+ Dhall.Core.NaturalShow ->
+ Dhall.Core.NaturalShow
+
+ Dhall.Core.NaturalPlus a b ->
+ Dhall.Core.NaturalPlus a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.NaturalTimes a b ->
+ Dhall.Core.NaturalTimes a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.Integer ->
+ Dhall.Core.Integer
+
+ Dhall.Core.IntegerLit a ->
+ Dhall.Core.IntegerLit a
+
+ Dhall.Core.IntegerShow ->
+ Dhall.Core.IntegerShow
+
+ Dhall.Core.Double ->
+ Dhall.Core.Double
+
+ Dhall.Core.DoubleLit a ->
+ Dhall.Core.DoubleLit a
+
+ Dhall.Core.DoubleShow ->
+ Dhall.Core.DoubleShow
+
+ Dhall.Core.Text ->
+ Dhall.Core.Text
+
+ Dhall.Core.TextLit (Dhall.Core.Chunks a b) ->
+ Dhall.Core.TextLit (Dhall.Core.Chunks a' b)
+ where
+ a' = fmap (fmap loop) a
+
+ Dhall.Core.TextAppend a b ->
+ Dhall.Core.TextAppend a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.List ->
+ Dhall.Core.List
+
+ Dhall.Core.ListLit a b ->
+ case transform of
+ Just c -> c
+ Nothing -> Dhall.Core.ListLit a' b'
+ where
+ elements = Data.Foldable.toList b
+
+ toKeyValue :: Expr s X -> Maybe (Text, Expr s X)
+ toKeyValue (Dhall.Core.RecordLit m) = do
+ guard (Data.HashMap.Strict.InsOrd.size m == 2)
+
+ key <- Data.HashMap.Strict.InsOrd.lookup mapKey m
+ value <- Data.HashMap.Strict.InsOrd.lookup mapValue m
+
+ keyText <- case key of
+ Dhall.Core.TextLit (Dhall.Core.Chunks [] keyText) ->
+ return keyText
+
+ _ ->
+ empty
+
+ return (Data.Text.Lazy.Builder.toLazyText keyText, value)
+ toKeyValue _ = do
+ empty
+
+ transform =
+ case elements of
+ [] ->
+ case a of
+ Just (Dhall.Core.Record m) -> do
+ guard (Data.HashMap.Strict.InsOrd.size m == 2)
+ guard (Data.HashMap.Strict.InsOrd.member mapKey m)
+ guard (Data.HashMap.Strict.InsOrd.member mapValue m)
+ return (Dhall.Core.RecordLit Data.HashMap.Strict.InsOrd.empty)
+ _ -> do
+ empty
+
+ _ -> do
+ keyValues <- traverse toKeyValue elements
+
+ let recordLiteral =
+ Data.HashMap.Strict.InsOrd.fromList keyValues
+
+ return (Dhall.Core.RecordLit recordLiteral)
+
+ a' = fmap loop a
+ b' = fmap loop b
+
+ Dhall.Core.ListAppend a b ->
+ Dhall.Core.ListAppend a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.ListBuild ->
+ Dhall.Core.ListBuild
+
+ Dhall.Core.ListFold ->
+ Dhall.Core.ListFold
+
+ Dhall.Core.ListLength ->
+ Dhall.Core.ListLength
+
+ Dhall.Core.ListHead ->
+ Dhall.Core.ListHead
+
+ Dhall.Core.ListLast ->
+ Dhall.Core.ListLast
+
+ Dhall.Core.ListIndexed ->
+ Dhall.Core.ListIndexed
+
+ Dhall.Core.ListReverse ->
+ Dhall.Core.ListReverse
+
+ Dhall.Core.Optional ->
+ Dhall.Core.Optional
+
+ Dhall.Core.OptionalLit a b ->
+ Dhall.Core.OptionalLit a' b'
+ where
+ a' = loop a
+ b' = fmap loop b
+
+ Dhall.Core.OptionalFold ->
+ Dhall.Core.OptionalFold
+
+ Dhall.Core.OptionalBuild ->
+ Dhall.Core.OptionalBuild
+
+ Dhall.Core.Record a ->
+ Dhall.Core.Record a'
+ where
+ a' = fmap loop a
+
+ Dhall.Core.RecordLit a ->
+ Dhall.Core.RecordLit a'
+ where
+ a' = fmap loop a
+
+ Dhall.Core.Union a ->
+ Dhall.Core.Union a'
+ where
+ a' = fmap loop a
+
+ Dhall.Core.UnionLit a b c ->
+ Dhall.Core.UnionLit a b' c'
+ where
+ b' = loop b
+ c' = fmap loop c
+
+ Dhall.Core.Combine a b ->
+ Dhall.Core.Combine a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.CombineTypes a b ->
+ Dhall.Core.CombineTypes a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.Prefer a b ->
+ Dhall.Core.Prefer a' b'
+ where
+ a' = loop a
+ b' = loop b
+
+ Dhall.Core.Merge a b c ->
+ Dhall.Core.Merge a' b' c'
+ where
+ a' = loop a
+ b' = loop b
+ c' = fmap loop c
+
+ Dhall.Core.Constructors a ->
+ Dhall.Core.Constructors a'
+ where
+ a' = loop a
+
+ Dhall.Core.Field a b ->
+ Dhall.Core.Field a' b
+ where
+ a' = loop a
+
+ Dhall.Core.Project a b ->
+ Dhall.Core.Project a' b
+ where
+ a' = loop a
+
+ Dhall.Core.Note a b ->
+ Dhall.Core.Note a b'
+ where
+ b' = loop b
+
+ Dhall.Core.Embed a ->
+ Dhall.Core.Embed a
+
+parseConversion :: Parser Conversion
+parseConversion =
+ conversion
+ <|> noConversion
+ where
+ conversion = do
+ mapKey <- parseKeyField
+ mapValue <- parseValueField
+ return (Conversion {..})
+ where
+ parseKeyField =
+ Options.Applicative.strOption
+ ( 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
+ )
+
+ parseValueField =
+ Options.Applicative.strOption
+ ( 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
+ )
+
+ noConversion =
+ Options.Applicative.flag'
+ NoConversion
+ ( Options.Applicative.long "noMaps"
+ <> Options.Applicative.help "Disable conversion of association lists to homogeneous maps"
+ )
+
+
{-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value
>>> :set -XOverloadedStrings
@@ -205,19 +580,24 @@ omitNull Null =
>>> Object (fromList [("a",Number 1.0)])
-}
codeToValue
- :: Data.Text.Text -- ^ Describe the input for the sake of error location.
+ :: Conversion
+ -> Data.Text.Text -- ^ Describe the input for the sake of error location.
-> Data.Text.Text -- ^ Input text.
-> IO Value
-codeToValue name code = do
- expr <- case Dhall.Parser.exprFromText (Data.Text.unpack name) (Data.Text.Lazy.fromStrict code) of
- Left err -> Control.Exception.throwIO err
- Right expr -> return expr
+codeToValue conversion name code = do
+ parsedExpression <- case Dhall.Parser.exprFromText (Data.Text.unpack name) (Data.Text.Lazy.fromStrict code) of
+ Left err -> Control.Exception.throwIO err
+ Right parsedExpression -> return parsedExpression
+
+ resolvedExpression <- Dhall.Import.load parsedExpression
- expr' <- Dhall.Import.load expr
- case Dhall.TypeCheck.typeOf expr' of
+ case Dhall.TypeCheck.typeOf resolvedExpression of
Left err -> Control.Exception.throwIO err
Right _ -> return ()
- case dhallToJSON expr' of
+ let convertedExpression =
+ convertToHomogeneousMaps conversion resolvedExpression
+
+ case dhallToJSON convertedExpression of
Left err -> Control.Exception.throwIO err
Right json -> return json