diff options
author | GabrielGonzalez <> | 2018-05-19 17:50:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2018-05-19 17:50:00 (GMT) |
commit | d0d9803a1e0698752889902233f6956955d4c0ec (patch) | |
tree | c7467dbb52fa729a7bbbed15929ec9c9ca7dae04 | |
parent | fb2be9465e7579b709852e4bc28975510dcc0791 (diff) |
version 1.2.01.2.0
-rw-r--r-- | dhall-json.cabal | 30 | ||||
-rw-r--r-- | dhall-to-json/Main.hs | 81 | ||||
-rw-r--r-- | dhall-to-yaml/Main.hs | 62 | ||||
-rw-r--r-- | src/Dhall/JSON.hs | 396 |
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 |