diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +1.3.0 + +* BREAKING CHANGE: Change YAML/JSON encoding for `NaN`/`Infinity`/`-Infinity` + * They are now encoded as the standard `"nan"`/`"inf"`/`"-inf"` + representations instead of `null`/`MIN_DOUBLE/`/`MAX_DOUBLE` + * See: https://github.com/dhall-lang/dhall-haskell/pull/946 +* BREAKING CHANGE: Isolate YAML code to one modulee + * This is a breaking change because it moves `Dhall.JSON.jsonToYaml` to + `Dhall.YAML.jsonToYaml` + * See: https://github.com/dhall-lang/dhall-haskell/pull/989/files +* New `yaml-to-dhall` command-line utility + * See: https://github.com/dhall-lang/dhall-haskell/pull/977 +* Add `--quoted` flag to force quoting of YAML string literals + * See: https://github.com/dhall-lang/dhall-haskell/pull/941 + 1.2.8 * New `json-to-dhall` command-line utility 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.8 +Version: 1.3.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 @@ -9,10 +9,10 @@ Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com Bug-Reports: https://github.com/dhall-lang/dhall-haskell/issues -Synopsis: Compile Dhall to JSON or YAML +Synopsis: Convert between Dhall and JSON or YAML Description: - Use this package if you want to compile Dhall expressions to JSON or YAML. - You can use this package as a library or an executable: + Use this package if you want to convert between Dhall expressions and JSON + or YAML. You can use this package as a library or an executable: . * See the "Dhall.JSON" module if you want to use this package as a library . @@ -26,21 +26,43 @@ CHANGELOG.md tasty/data/*.dhall tasty/data/*.json + Source-Repository head Type: git Location: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-json +Flag yaml-pre-0_11 + Default: False + Manual: False + Library Hs-Source-Dirs: src Build-Depends: base >= 4.8.0.0 && < 5 , aeson >= 1.0.0.0 && < 1.5 , - dhall >= 1.22.0 && < 1.23, + aeson-pretty < 0.9 , + bytestring < 0.11, + containers , + dhall >= 1.22.0 && < 1.25, + exceptions >= 0.8.3 && < 0.11, + lens >= 2.5 && < 4.18, optparse-applicative >= 0.14.0.0 && < 0.15, + scientific >= 0.3.0.0 && < 0.4 , text >= 0.11.1.0 && < 1.3 , - unordered-containers < 0.3 - Exposed-Modules: Dhall.JSON + unordered-containers < 0.3 , + vector + Exposed-Modules: + Dhall.JSON + Dhall.JSONToDhall + Dhall.Yaml GHC-Options: -Wall + if flag(yaml-pre-0_11) + Build-Depends: + yaml >= 0.5.0 && < 0.11 + else + Build-Depends: + libyaml >= 0.1.1.0 && < 0.2 , + yaml >= 0.11.0 && < 0.12 Executable dhall-to-json Hs-Source-Dirs: dhall-to-json @@ -48,7 +70,7 @@ Build-Depends: base , aeson , - aeson-pretty < 0.9 , + aeson-pretty >= 0.8.5 && < 0.9 , bytestring < 0.11, dhall , dhall-json , @@ -68,8 +90,6 @@ dhall , dhall-json , optparse-applicative , - yaml >= 0.5.0 && < 0.12, - vector , text GHC-Options: -Wall @@ -79,15 +99,30 @@ Build-Depends: base , aeson , - aeson-pretty < 0.9 , bytestring < 0.11 , dhall , + dhall-json , + exceptions >= 0.8.3 && < 0.11 , optparse-applicative , - text < 1.3 , - scientific >= 0.3.0.0 && < 0.4 , + text < 1.3 + if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4) + Build-Depends: semigroups == 0.18.* + Other-Modules: + Paths_dhall_json + GHC-Options: -Wall + +Executable yaml-to-dhall + Hs-Source-Dirs: yaml-to-dhall + Main-Is: Main.hs + Build-Depends: + base , + aeson , + bytestring < 0.11 , + dhall , + dhall-json , exceptions >= 0.8.3 && < 0.11 , - containers , - unordered-containers >= 0.1.3.0 && < 0.3 + optparse-applicative , + text < 1.3 if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4) Build-Depends: semigroups == 0.18.* Other-Modules: 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 @@ -9,7 +9,7 @@ import Data.Aeson (Value) import Data.Monoid ((<>)) import Data.Version (showVersion) -import Dhall.JSON (Conversion) +import Dhall.JSON (Conversion, SpecialDoubleMode(..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception @@ -27,11 +27,12 @@ import qualified System.IO data Options = Options - { explain :: Bool - , pretty :: Bool - , omission :: Value -> Value - , version :: Bool - , conversion :: Conversion + { explain :: Bool + , pretty :: Bool + , omission :: Value -> Value + , version :: Bool + , conversion :: Conversion + , approximateSpecialDoubles :: Bool } parseOptions :: Parser Options @@ -42,6 +43,7 @@ <*> Dhall.JSON.parseOmission <*> parseVersion <*> Dhall.JSON.parseConversion + <*> parseApproximateSpecialDoubles where parseExplain = Options.Applicative.switch @@ -75,6 +77,12 @@ <> Options.Applicative.help "Display version" ) + parseApproximateSpecialDoubles = + Options.Applicative.switch + ( Options.Applicative.long "approximate-special-doubles" + <> Options.Applicative.help "Use approximate representation for NaN/±Infinity" + ) + parserInfo :: ParserInfo Options parserInfo = Options.Applicative.info @@ -106,9 +114,14 @@ let explaining = if explain then Dhall.detailed else id + let specialDoubleMode = + if approximateSpecialDoubles + then ApproximateWithinJSON + else ForbidWithinJSON + stdin <- Data.Text.IO.getContents - json <- omission <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin) + json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode "(stdin)" stdin) Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs --- a/dhall-to-yaml/Main.hs +++ b/dhall-to-yaml/Main.hs @@ -6,16 +6,15 @@ import Control.Exception (SomeException) import Data.Aeson (Value) import Data.Monoid ((<>)) -import Dhall.JSON (Conversion) +import Dhall.JSON (Conversion, SpecialDoubleMode(..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception import qualified Data.ByteString import qualified Data.Text.IO -import qualified Data.Vector -import qualified Data.Yaml import qualified Dhall import qualified Dhall.JSON +import qualified Dhall.Yaml import qualified GHC.IO.Encoding import qualified Options.Applicative import qualified System.Exit @@ -25,6 +24,7 @@ { explain :: Bool , omission :: Value -> Value , documents :: Bool + , quoted :: Bool , conversion :: Conversion } @@ -34,6 +34,7 @@ <$> parseExplain <*> Dhall.JSON.parseOmission <*> parseDocuments + <*> parseQuoted <*> Dhall.JSON.parseConversion where parseExplain = @@ -48,6 +49,12 @@ <> Options.Applicative.help "If given a Dhall list, output a document for every element" ) + parseQuoted = + Options.Applicative.switch + ( Options.Applicative.long "quoted" + <> Options.Applicative.help "Prevent from generating not quoted scalars" + ) + parserInfo :: ParserInfo Options parserInfo = Options.Applicative.info @@ -67,14 +74,9 @@ stdin <- Data.Text.IO.getContents - json <- omission <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin) + json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding "(stdin)" stdin) - let yaml = case (documents, json) of - (True, Data.Yaml.Array elems) - -> Data.ByteString.intercalate "\n---\n" - $ fmap Data.Yaml.encode - $ Data.Vector.toList elems - _ -> Data.Yaml.encode json + let yaml = Dhall.Yaml.jsonToYaml json documents quoted Data.ByteString.putStr yaml diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs --- a/json-to-dhall/Main.hs +++ b/json-to-dhall/Main.hs @@ -6,159 +6,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-| The tool for converting JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous. - - Reasonable requirements to the conversion tool are: - - 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression - 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@ - - Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data: - - * @Bool@s - * @Natural@s - * @Integer@s - * @Double@s - * @Text@s - * @List@s - * @Optional@ values - * unions - * records - -== Primitive types - - JSON @Bool@s translate to Dhall bools: - -> $ json-to-dhall Bool <<< 'true' -> True -> $ json-to-dhall Bool <<< 'false' -> False - - JSON numbers translate to Dhall numbers: - -> $ json-to-dhall Integer <<< 2 -> +2 -> $ json-to-dhall Natural <<< 2 -> 2 -> $ json-to-dhall Double <<< -2.345 -> -2.345 - - Dhall @Text@ corresponds to JSON text: - -> $ json-to-dhall Text <<< '"foo bar"' -> "foo bar" - - -== Lists and records - - Dhall @List@s correspond to JSON lists: - -> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]' -> [ +1, +2, +3 ] - - - Dhall __records__ correspond to JSON records: - -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}' -> { foo = [ +1, +2, +3 ] } - - - Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored: - -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' -> { foo = [ +1, +2, +3 ] } - - - If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used: - -> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' -> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict: - - - By default, JSON key-value arrays will be converted to Dhall records: - -> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' -> { a = +1, b = "asdf" } - - - Attempting to do the same with @--no-keyval-arrays@ on will result in error: - -> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' -> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag: - - Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default: - -> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' -> [ { mapKey = "foo", mapValue = "bar" } ] - - Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it): - -> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' -> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag - - -== Optional values and unions - - Dhall @Optional@ Dhall type allows null or missing JSON values: - -> $ json-to-dhall "Optional Integer" <<< '1' -> Some +1 - -> $ json-to-dhall "Optional Integer" <<< null -> None Integer - -> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }' -{ a = +1, b = None Text } - - - - For Dhall __union types__ the correct value will be based on matching the type of JSON expression: - -> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]' -> [ < Left : Text | Right : Integer >.Right +1 - , < Left : Text | Right : Integer >.Left "bar" - ] - -> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }' -> { foo = < Left : Text | Right : Integer >.Left "bar" } - - In presence of multiple potential matches, the first will be selected by default: - -> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' -> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" } - - This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list) - -> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' -> Error: More than one union component type matches JSON value -> ... -> Possible matches: -< Left : Text | Middle : Text | Right : Integer >.Left "bar" -> -------- -< Left : Text | Middle : Text | Right : Integer >.Middle "bar" --} - module Main where -import Control.Applicative ((<|>)) import qualified Control.Exception -import Control.Exception (SomeException, Exception, throwIO) -import Control.Monad.Catch (throwM, MonadCatch) +import Control.Exception (SomeException, throwIO) import Control.Monad (when) import qualified Data.Aeson as A -import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BSL8 -import Data.Either (rights) -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HM -import Data.List ((\\)) import Data.Monoid ((<>)) -import Data.Scientific (floatingOrInteger, toRealFloat) -import qualified Data.Sequence as Seq -import qualified Data.String -import qualified Data.Text as Text -import qualified Data.Text.IO as Text import Data.Text (Text) +import qualified Data.Text.IO as Text import Data.Version (showVersion) import qualified GHC.IO.Encoding import qualified Options.Applicative as O @@ -166,15 +23,8 @@ import qualified System.Exit import qualified System.IO -import qualified Dhall import qualified Dhall.Core as D -import Dhall.Core (Expr(App), Chunks(..)) -import qualified Dhall.Import -import qualified Dhall.Map as Map -import qualified Dhall.Parser -import Dhall.Parser (Src) -import qualified Dhall.TypeCheck as D -import Dhall.TypeCheck (X) +import Dhall.JSONToDhall import qualified Paths_dhall_json as Meta @@ -213,66 +63,6 @@ <> O.help "Display version" ) --- | JSON-to-dhall translation options -data Conversion = Conversion - { strictRecs :: Bool - , noKeyValArr :: Bool - , noKeyValMap :: Bool - , unions :: UnionConv - } deriving Show - -data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq) - -defaultConversion :: Conversion -defaultConversion = Conversion - { strictRecs = False - , noKeyValArr = False - , noKeyValMap = False - , unions = UFirst - } - --- | Parser for command options related to the conversion method -parseConversion :: Parser Conversion -parseConversion = Conversion <$> parseStrict - <*> parseKVArr - <*> parseKVMap - <*> parseUnion - where - parseStrict = O.switch - ( O.long "records-strict" - <> O.help "Parse all fields in records" - ) - parseKVArr = O.switch - ( O.long "no-keyval-arrays" - <> O.help "Disable conversion of key-value arrays to records" - ) - parseKVMap = O.switch - ( O.long "no-keyval-maps" - <> O.help "Disable conversion of homogeneous map objects to association lists" - ) - --- | Parser for command options related to treating union types -parseUnion :: Parser UnionConv -parseUnion = - uFirst - <|> uNone - <|> uStrict - <|> pure UFirst -- defaulting to UFirst - where - uFirst = O.flag' UFirst - ( O.long "unions-first" - <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)" - ) - uNone = O.flag' UNone - ( O.long "unions-none" - <> O.help "Unions not allowed" - ) - uStrict = O.flag' UStrict - ( O.long "unions-strict" - <> O.help "Error if more than one union values match the type (and parse successfully)" - ) - - -- ---------- -- Main -- ---------- @@ -293,7 +83,7 @@ Left err -> throwIO (userError err) Right v -> pure v - expr <- typeCheckSchemaExpr =<< resolveSchemaExpr schema + expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema case dhallFromJSON conversion expr value of Left err -> throwIO err @@ -307,279 +97,3 @@ System.IO.hPutStrLn System.IO.stderr "" System.IO.hPrint System.IO.stderr e System.Exit.exitFailure - - --- ---------- --- Conversion --- ---------- - --- | The 'Expr' type concretization used throughout this module -type ExprX = Expr Src X - --- | Parse schema code to a valid Dhall expression and check that its type is actually Type -resolveSchemaExpr :: Text -- ^ type code (schema) - -> IO ExprX -resolveSchemaExpr code = do - parsedExpression <- - case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of - Left err -> Control.Exception.throwIO err - Right parsedExpression -> return parsedExpression - D.normalize <$> Dhall.Import.load parsedExpression -- IO - -{-| Check that the Dhall type expression actually has type 'Type' ->>> :set -XOverloadedStrings ->>> import Dhall.Core - ->>> typeCheckSchemaExpr =<< resolveSchemaExpr "List Natural" -App List Natural - ->>> typeCheckSchemaExpr =<< resolveSchemaExpr "+1" -*** Exception: -Error: Schema expression is succesfully parsed but has Dhall type: -Integer -Expected Dhall type: Type -Parsed expression: +1 --} -typeCheckSchemaExpr :: MonadCatch m - => ExprX -> m ExprX -typeCheckSchemaExpr expr = - case D.typeOf expr of -- check if the expression has type - Left err -> throwM $ TypeError err - Right t -> case t of -- check if the expression has type Type - D.Const D.Type -> return expr - _ -> throwM $ BadDhallType t expr - -keyValMay :: A.Value -> Maybe (Text, A.Value) -keyValMay (A.Object o) = do - A.String k <- HM.lookup "key" o - v <- HM.lookup "value" o - return (k, v) -keyValMay _ = Nothing - - -{-| The main conversion function. Traversing/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options: - ->>> :set -XOverloadedStrings ->>> import qualified Dhall.Core as D ->>> import qualified Dhall.Map as Map ->>> import qualified Data.Aeson as A ->>> import qualified Data.HashMap.Strict as HM - ->>> s = D.Record (Map.fromList [("foo", D.Integer)]) ->>> v = A.Object (HM.fromList [("foo", A.Number 1)]) ->>> dhallFromJSON defaultConversion s v -Right (RecordLit (fromList [("foo",IntegerLit 1)])) - --} -dhallFromJSON - :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX -dhallFromJSON (Conversion {..}) = loop - where - -- any ~> Union - loop t@(D.Union tmMay) v = case unions of - UNone -> Left $ ContainsUnion t - _ -> case Map.traverseWithKey (const id) tmMay of - Nothing -> undefined - Just tm -> - -- OLD-STYLE UNION: - -- let f k a = D.UnionLit k <$> loop a v - -- <*> pure (Map.delete k tmMay) - let f k a = D.App (D.Field t k) <$> loop a v - in case rights . toList $ Map.mapWithKey f tm of - [ ] -> Left $ Mismatch t v - [x] -> Right x - xs@(x:_:_) -> case unions of - UStrict -> Left $ UndecidableUnion t v xs - UFirst -> Right x - UNone -> undefined -- can't happen - - -- object ~> Record - loop (D.Record r) v@(A.Object o) - | extraKeys <- HM.keys o \\ Map.keys r - , strictRecs && not (null extraKeys) - = Left (UnhandledKeys extraKeys (D.Record r) v) - | otherwise - = let f :: Text -> ExprX -> Either CompileError ExprX - f k t | Just value <- HM.lookup k o - = loop t value - | App D.Optional t' <- t - = Right (App D.None t') - | otherwise - = Left (MissingKey k t v) - in D.RecordLit <$> Map.traverseWithKey f r - - -- key-value list ~> Record - loop t@(D.Record _) v@(A.Array a) - | not noKeyValArr - , os :: [A.Value] <- toList a - , Just kvs <- traverse keyValMay os - = loop t (A.Object $ HM.fromList kvs) - | noKeyValArr - = Left (NoKeyValArray t v) - | otherwise - = Left (Mismatch t v) - - -- object ~> List (key, value) - loop t@(App D.List (D.Record r)) v@(A.Object o) - | not noKeyValMap - , ["mapKey", "mapValue"] == Map.keys r - , Just D.Text == Map.lookup "mapKey" r - , Just mapValue <- Map.lookup "mapValue" r - , keyExprMap :: Either CompileError (HM.HashMap Text ExprX) - <- traverse (loop mapValue) o - = let f :: (Text, ExprX) -> ExprX - f (key, val) = D.RecordLit ( Map.fromList - [ ("mapKey" , D.TextLit (Chunks [] key)) - , ("mapValue", val) - ] ) - recs :: Either CompileError (Dhall.Seq ExprX) - recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap - typeAnn = if HM.null o then Just mapValue else Nothing - in D.ListLit typeAnn <$> recs - | noKeyValMap - = Left (NoKeyValMap t v) - | otherwise - = Left (Mismatch t v) - - -- array ~> List - loop (App D.List t) (A.Array a) - = let f :: [ExprX] -> ExprX - f es = D.ListLit - (if null es then Just t else Nothing) - (Seq.fromList es) - in f <$> traverse (loop t) (toList a) - - -- number ~> Integer - loop D.Integer (A.Number x) - | Right n <- floatingOrInteger x :: Either Double Integer - = Right (D.IntegerLit n) - | otherwise - = Left (Mismatch D.Integer (A.Number x)) - - -- number ~> Natural - loop D.Natural (A.Number x) - | Right n <- floatingOrInteger x :: Either Double Dhall.Natural - , n >= 0 - = Right (D.NaturalLit n) - | otherwise - = Left (Mismatch D.Natural (A.Number x)) - - -- number ~> Double - loop D.Double (A.Number x) - = Right (D.DoubleLit $ toRealFloat x) - - -- string ~> Text - loop D.Text (A.String t) - = Right (D.TextLit (Chunks [] t)) - - -- bool ~> Bool - loop D.Bool (A.Bool t) - = Right (D.BoolLit t) - - -- null ~> Optional - loop (App D.Optional expr) A.Null - = Right $ App D.None expr - - -- value ~> Optional - loop (App D.Optional expr) value - = D.Some <$> loop expr value - - -- fail - loop expr value - = Left (Mismatch expr value) - - --- ---------- --- EXCEPTIONS --- ---------- - -red, purple, green - :: (Monoid a, Data.String.IsString a) => a -> a -red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold -purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold -green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain - -showExpr :: ExprX -> String -showExpr dhall = Text.unpack (D.pretty dhall) - -showJSON :: A.Value -> String -showJSON value = BSL8.unpack (encodePretty value) - -data CompileError - -- Dhall shema - = TypeError (D.TypeError Src X) - | BadDhallType - ExprX -- Expression type - ExprX -- Whole expression - -- generic mismatch (fallback) - | Mismatch - ExprX -- Dhall expression - A.Value -- Aeson value - -- record specific - | MissingKey Text ExprX A.Value - | UnhandledKeys [Text] ExprX A.Value - | NoKeyValArray ExprX A.Value - | NoKeyValMap ExprX A.Value - -- union specific - | ContainsUnion ExprX - | UndecidableUnion ExprX A.Value [ExprX] - -instance Show CompileError where - show = let prefix = red "\nError: " - in \case - TypeError e -> show e - - BadDhallType t e -> prefix - <> "Schema expression is succesfully parsed but has Dhall type:\n" - <> showExpr t <> "\nExpected Dhall type: Type" - <> "\nParsed expression: " - <> showExpr e <> "\n" - - ContainsUnion e -> prefix - <> "Dhall type expression contains union type:\n" - <> showExpr e <> "\nwhile it is forbidden by option " - <> green "--unions-none\n" - - UndecidableUnion e v xs -> prefix - <> "More than one union component type matches JSON value" - <> "\n\nDhall:\n" <> showExpr e - <> "\n\nJSON:\n" <> showJSON v - <> "\n\nPossible matches:\n\n" -- Showing all the allowed matches - <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs) - where sep = red "\n--------\n" :: Text - - Mismatch e v -> prefix - <> "Dhall type expression and json value do not match:" - <> "\n\nDhall:\n" <> showExpr e - <> "\n\nJSON:\n" <> showJSON v - <> "\n" - - MissingKey k e v -> prefix - <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n" - <> showExpr e - <> "\nis not present in JSON object:\n" - <> showJSON v <> "\n" - - UnhandledKeys ks e v -> prefix - <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks)) - <> " present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of " - <> green "--records-strict" <> " flag:" - <> "\n\nDhall:\n" <> showExpr e - <> "\n\nJSON:\n" <> showJSON v - <> "\n" - - NoKeyValArray e v -> prefix - <> "JSON (key-value) arrays cannot be converted to Dhall records under " - <> green "--no-keyval-arrays" <> " flag" - <> "\n\nDhall:\n" <> showExpr e - <> "\n\nJSON:\n" <> showJSON v - <> "\n" - - NoKeyValMap e v -> prefix - <> "Homogeneous JSON map objects cannot be converted to Dhall association lists under " - <> green "--no-keyval-arrays" <> " flag" - <> "\n\nDhall:\n" <> showExpr e - <> "\n\nJSON:\n" <> showJSON v - <> "\n" - -instance Exception CompileError diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- a/src/Dhall/JSON.hs +++ b/src/Dhall/JSON.hs @@ -165,6 +165,8 @@ , Conversion(..) , convertToHomogeneousMaps , parseConversion + , SpecialDoubleMode(..) + , handleSpecialDoubles , codeToValue -- * Exceptions @@ -182,6 +184,7 @@ import Dhall.Map (Map) import Options.Applicative (Parser) +import qualified Control.Lens import qualified Data.Foldable import qualified Data.HashMap.Strict import qualified Data.List @@ -202,6 +205,7 @@ -} data CompileError = Unsupported (Expr X X) + | SpecialDouble Double | BareNone instance Show CompileError where @@ -228,6 +232,26 @@ \ \n\ \ \n\ \The conversion to JSON/YAML only translates the fully applied form to ❰null❱. " + + show (SpecialDouble n) = + Data.Text.unpack $ + _ERROR <> ": " <> special <> " disallowed in JSON \n\ + \ \n\ + \Explanation: The JSON standard does not define a canonical way to encode \n\ + \❰NaN❱/❰Infinity❱/❰-Infinity❱. You can fix this error by either: \n\ + \ \n\ + \● Using ❰dhall-to-yaml❱ instead of ❰dhall-to-json❱, since YAML does support \n\ + \ ❰NaN❱/❰Infinity❱/❰-Infinity❱ \n\ + \ \n\ + \● Enabling the ❰--approximate-special-doubles❱ flag which will encode ❰NaN❱ as \n\ + \ ❰null❱, ❰Infinity❱ as the maximum ❰Double❱, and ❰-Infinity❱ as the minimum \n\ + \❰Double❱ \n\ + \ \n\ + \● See if there is a way to remove ❰NaN❱/❰Infinity❱/❰-Infinity❱ from the \n\ + \ expression that you are converting to JSON " + where + special = Data.Text.pack (show n) + show (Unsupported e) = Data.Text.unpack $ _ERROR <> ": Cannot translate to JSON \n\ @@ -256,17 +280,16 @@ >>> fmap Data.Aeson.encode it Right "{\"foo\":1,\"bar\":\"ABC\"}" -} -dhallToJSON :: Expr s X -> Either CompileError Value +dhallToJSON + :: Expr s X + -> Either CompileError Value dhallToJSON e0 = loop (Dhall.Core.normalize e0) where loop e = case e of Dhall.Core.BoolLit a -> return (toJSON a) Dhall.Core.NaturalLit a -> return (toJSON a) Dhall.Core.IntegerLit a -> return (toJSON a) - Dhall.Core.DoubleLit a - | isInfinite a && a > 0 -> return (toJSON ( 1.7976931348623157e308 :: Double)) - | isInfinite a && a < 0 -> return (toJSON (-1.7976931348623157e308 :: Double)) - | otherwise -> return (toJSON a) + Dhall.Core.DoubleLit a -> return (toJSON a) Dhall.Core.TextLit (Dhall.Core.Chunks [] a) -> do return (toJSON a) Dhall.Core.ListLit _ a -> do @@ -791,7 +814,56 @@ <> Options.Applicative.help "Disable conversion of association lists to homogeneous maps" ) +-- | This option specifies how to encode @NaN@\/@Infinity@\/@-Infinity@ +data SpecialDoubleMode + = UseYAMLEncoding + -- ^ YAML natively supports @NaN@\/@Infinity@\/@-Infinity@ + | ForbidWithinJSON + -- ^ Forbid @NaN@\/@Infinity@\/@-Infinity@ because JSON doesn't support them + | ApproximateWithinJSON + -- ^ Encode @NaN@\/@Infinity@\/@-Infinity@ as + -- @null@\/@1.7976931348623157e308@\/@-1.7976931348623157e308@, + -- respectively +{-| Pre-process an expression containing @NaN@\/@Infinity@\/@-Infinity@, + handling them as specified according to the `SpecialDoubleMode` +-} +handleSpecialDoubles + :: SpecialDoubleMode -> Expr s X -> Either CompileError (Expr s X) +handleSpecialDoubles specialDoubleMode = + Control.Lens.rewriteMOf Dhall.Core.subExpressions rewrite + where + rewrite = + case specialDoubleMode of + UseYAMLEncoding -> useYAMLEncoding + ForbidWithinJSON -> forbidWithinJSON + ApproximateWithinJSON -> approximateWithinJSON + + useYAMLEncoding (Dhall.Core.DoubleLit n) + | isInfinite n && 0 < n = + return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "inf"))) + | isInfinite n && n < 0 = + return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "-inf"))) + | isNaN n = + return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "nan"))) + useYAMLEncoding _ = + return Nothing + + forbidWithinJSON (Dhall.Core.DoubleLit n) + | isInfinite n || isNaN n = + Left (SpecialDouble n) + forbidWithinJSON _ = + return Nothing + + approximateWithinJSON (Dhall.Core.DoubleLit n) + | isInfinite n && n > 0 = + return (Just (Dhall.Core.DoubleLit ( 1.7976931348623157e308 :: Double))) + | isInfinite n && n < 0 = + return (Just (Dhall.Core.DoubleLit (-1.7976931348623157e308 :: Double))) + -- Do nothing for @NaN@, which already encodes to @null@ + approximateWithinJSON _ = + return Nothing + {-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value >>> :set -XOverloadedStrings @@ -801,23 +873,23 @@ -} codeToValue :: Conversion + -> SpecialDoubleMode -> 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) code of - Left err -> Control.Exception.throwIO err - Right parsedExpression -> return parsedExpression +codeToValue conversion specialDoubleMode name code = do + parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText (Data.Text.unpack name) code) resolvedExpression <- Dhall.Import.load parsedExpression - case Dhall.TypeCheck.typeOf resolvedExpression of - Left err -> Control.Exception.throwIO err - Right _ -> return () + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) let convertedExpression = convertToHomogeneousMaps conversion resolvedExpression - case dhallToJSON convertedExpression of + specialDoubleExpression <- Dhall.Core.throws (handleSpecialDoubles specialDoubleMode convertedExpression) + + case dhallToJSON specialDoubleExpression of Left err -> Control.Exception.throwIO err Right json -> return json + diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/JSONToDhall.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| Convert JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous. + + Reasonable requirements for conversion are: + + 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression + 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@ + + Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data: + + * @Bool@s + * @Natural@s + * @Integer@s + * @Double@s + * @Text@s + * @List@s + * @Optional@ values + * unions + * records + + This library can be used to implement an executable which takes any data + serialisation format which can be parsed as an Aeson @Value@ and converts + the result to a Dhall value. One such executable is @json-to-dhall@ which + is used in the examples below. + +== Primitive types + + JSON @Bool@s translate to Dhall bools: + +> $ json-to-dhall Bool <<< 'true' +> True +> $ json-to-dhall Bool <<< 'false' +> False + + JSON numbers translate to Dhall numbers: + +> $ json-to-dhall Integer <<< 2 +> +2 +> $ json-to-dhall Natural <<< 2 +> 2 +> $ json-to-dhall Double <<< -2.345 +> -2.345 + + Dhall @Text@ corresponds to JSON text: + +> $ json-to-dhall Text <<< '"foo bar"' +> "foo bar" + + +== Lists and records + + Dhall @List@s correspond to JSON lists: + +> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]' +> [ +1, +2, +3 ] + + + Dhall __records__ correspond to JSON records: + +> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}' +> { foo = [ +1, +2, +3 ] } + + + Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored: + +> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' +> { foo = [ +1, +2, +3 ] } + + + If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used: + +> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' +> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict: + + + By default, JSON key-value arrays will be converted to Dhall records: + +> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' +> { a = +1, b = "asdf" } + + + Attempting to do the same with @--no-keyval-arrays@ on will result in error: + +> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' +> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag: + + Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default: + +> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' +> [ { mapKey = "foo", mapValue = "bar" } ] + + Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it): + +> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' +> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag + + +== Optional values and unions + + Dhall @Optional@ Dhall type allows null or missing JSON values: + +> $ json-to-dhall "Optional Integer" <<< '1' +> Some +1 + +> $ json-to-dhall "Optional Integer" <<< null +> None Integer + +> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }' +{ a = +1, b = None Text } + + + + For Dhall __union types__ the correct value will be based on matching the type of JSON expression: + +> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]' +> [ < Left : Text | Right : Integer >.Right +1 + , < Left : Text | Right : Integer >.Left "bar" + ] + +> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }' +> { foo = < Left : Text | Right : Integer >.Left "bar" } + + In presence of multiple potential matches, the first will be selected by default: + +> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' +> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" } + + This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list) + +> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' +> Error: More than one union component type matches JSON value +> ... +> Possible matches: +< Left : Text | Middle : Text | Right : Integer >.Left "bar" +> -------- +< Left : Text | Middle : Text | Right : Integer >.Middle "bar" +-} + +module Dhall.JSONToDhall ( + -- * JSON to Dhall + parseConversion + , Conversion(..) + , defaultConversion + , resolveSchemaExpr + , typeCheckSchemaExpr + , dhallFromJSON + + -- * Exceptions + , CompileError(..) + , showCompileError + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (Exception, throwIO) +import Control.Monad.Catch (throwM, MonadCatch) +import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Either (rights) +import Data.Foldable (toList) +import qualified Data.HashMap.Strict as HM +import Data.List ((\\)) +import Data.Monoid ((<>)) +import Data.Scientific (floatingOrInteger, toRealFloat) +import qualified Data.Sequence as Seq +import qualified Data.String +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Options.Applicative as O +import Options.Applicative (Parser) + +import qualified Dhall +import qualified Dhall.Core as D +import Dhall.Core (Expr(App), Chunks(..)) +import qualified Dhall.Import +import qualified Dhall.Map as Map +import qualified Dhall.Parser +import Dhall.Parser (Src) +import qualified Dhall.TypeCheck as D +import Dhall.TypeCheck (X) + +-- --------------- +-- Command options +-- --------------- + +-- | Standard parser for options related to the conversion method +parseConversion :: Parser Conversion +parseConversion = Conversion <$> parseStrict + <*> parseKVArr + <*> parseKVMap + <*> parseUnion + where + parseStrict = O.switch + ( O.long "records-strict" + <> O.help "Parse all fields in records" + ) + parseKVArr = O.switch + ( O.long "no-keyval-arrays" + <> O.help "Disable conversion of key-value arrays to records" + ) + parseKVMap = O.switch + ( O.long "no-keyval-maps" + <> O.help "Disable conversion of homogeneous map objects to association lists" + ) + +-- | Parser for command options related to treating union types +parseUnion :: Parser UnionConv +parseUnion = + uFirst + <|> uNone + <|> uStrict + <|> pure UFirst -- defaulting to UFirst + where + uFirst = O.flag' UFirst + ( O.long "unions-first" + <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)" + ) + uNone = O.flag' UNone + ( O.long "unions-none" + <> O.help "Unions not allowed" + ) + uStrict = O.flag' UStrict + ( O.long "unions-strict" + <> O.help "Error if more than one union values match the type (and parse successfully)" + ) + +-- ---------- +-- Conversion +-- ---------- + +-- | JSON-to-dhall translation options +data Conversion = Conversion + { strictRecs :: Bool + , noKeyValArr :: Bool + , noKeyValMap :: Bool + , unions :: UnionConv + } deriving Show + +data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq) + +-- | Default conversion options +defaultConversion :: Conversion +defaultConversion = Conversion + { strictRecs = False + , noKeyValArr = False + , noKeyValMap = False + , unions = UFirst + } + +-- | The 'Expr' type concretization used throughout this module +type ExprX = Expr Src X + +-- | Parse schema code to a valid Dhall expression and check that its type is actually Type +resolveSchemaExpr :: Text -- ^ type code (schema) + -> IO ExprX +resolveSchemaExpr code = do + parsedExpression <- + case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of + Left err -> throwIO err + Right parsedExpression -> return parsedExpression + D.normalize <$> Dhall.Import.load parsedExpression -- IO + +{-| Check that the Dhall type expression actually has type 'Type' +>>> :set -XOverloadedStrings +>>> import Dhall.Core + +>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "List Natural" +App List Natural + +>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "+1" +*** Exception: +Error: Schema expression is succesfully parsed but has Dhall type: +Integer +Expected Dhall type: Type +Parsed expression: +1 +-} +typeCheckSchemaExpr :: (Exception e, MonadCatch m) + => (CompileError -> e) -> ExprX -> m ExprX +typeCheckSchemaExpr compileException expr = + case D.typeOf expr of -- check if the expression has type + Left err -> throwM . compileException $ TypeError err + Right t -> case t of -- check if the expression has type Type + D.Const D.Type -> return expr + _ -> throwM . compileException $ BadDhallType t expr + +keyValMay :: A.Value -> Maybe (Text, A.Value) +keyValMay (A.Object o) = do + A.String k <- HM.lookup "key" o + v <- HM.lookup "value" o + return (k, v) +keyValMay _ = Nothing + + +{-| The main conversion function. Traversing/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options: + +>>> :set -XOverloadedStrings +>>> import qualified Dhall.Core as D +>>> import qualified Dhall.Map as Map +>>> import qualified Data.Aeson as A +>>> import qualified Data.HashMap.Strict as HM + +>>> s = D.Record (Map.fromList [("foo", D.Integer)]) +>>> v = A.Object (HM.fromList [("foo", A.Number 1)]) +>>> dhallFromJSON defaultConversion s v +Right (RecordLit (fromList [("foo",IntegerLit 1)])) + +-} +dhallFromJSON + :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX +dhallFromJSON (Conversion {..}) = loop + where + -- any ~> Union + loop t@(D.Union tmMay) v = case unions of + UNone -> Left $ ContainsUnion t + _ -> case Map.traverseWithKey (const id) tmMay of + Nothing -> undefined + Just tm -> + -- OLD-STYLE UNION: + -- let f k a = D.UnionLit k <$> loop a v + -- <*> pure (Map.delete k tmMay) + let f k a = D.App (D.Field t k) <$> loop a v + in case rights . toList $ Map.mapWithKey f tm of + [ ] -> Left $ Mismatch t v + [x] -> Right x + xs@(x:_:_) -> case unions of + UStrict -> Left $ UndecidableUnion t v xs + UFirst -> Right x + UNone -> undefined -- can't happen + + -- object ~> Record + loop (D.Record r) v@(A.Object o) + | extraKeys <- HM.keys o \\ Map.keys r + , strictRecs && not (null extraKeys) + = Left (UnhandledKeys extraKeys (D.Record r) v) + | otherwise + = let f :: Text -> ExprX -> Either CompileError ExprX + f k t | Just value <- HM.lookup k o + = loop t value + | App D.Optional t' <- t + = Right (App D.None t') + | otherwise + = Left (MissingKey k t v) + in D.RecordLit <$> Map.traverseWithKey f r + + -- key-value list ~> Record + loop t@(D.Record _) v@(A.Array a) + | not noKeyValArr + , os :: [A.Value] <- toList a + , Just kvs <- traverse keyValMay os + = loop t (A.Object $ HM.fromList kvs) + | noKeyValArr + = Left (NoKeyValArray t v) + | otherwise + = Left (Mismatch t v) + + -- object ~> List (key, value) + loop t@(App D.List (D.Record r)) v@(A.Object o) + | not noKeyValMap + , ["mapKey", "mapValue"] == Map.keys r + , Just D.Text == Map.lookup "mapKey" r + , Just mapValue <- Map.lookup "mapValue" r + , keyExprMap :: Either CompileError (HM.HashMap Text ExprX) + <- traverse (loop mapValue) o + = let f :: (Text, ExprX) -> ExprX + f (key, val) = D.RecordLit ( Map.fromList + [ ("mapKey" , D.TextLit (Chunks [] key)) + , ("mapValue", val) + ] ) + recs :: Either CompileError (Dhall.Seq ExprX) + recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap + typeAnn = if HM.null o then Just mapValue else Nothing + in D.ListLit typeAnn <$> recs + | noKeyValMap + = Left (NoKeyValMap t v) + | otherwise + = Left (Mismatch t v) + + -- array ~> List + loop (App D.List t) (A.Array a) + = let f :: [ExprX] -> ExprX + f es = D.ListLit + (if null es then Just t else Nothing) + (Seq.fromList es) + in f <$> traverse (loop t) (toList a) + + -- number ~> Integer + loop D.Integer (A.Number x) + | Right n <- floatingOrInteger x :: Either Double Integer + = Right (D.IntegerLit n) + | otherwise + = Left (Mismatch D.Integer (A.Number x)) + + -- number ~> Natural + loop D.Natural (A.Number x) + | Right n <- floatingOrInteger x :: Either Double Dhall.Natural + , n >= 0 + = Right (D.NaturalLit n) + | otherwise + = Left (Mismatch D.Natural (A.Number x)) + + -- number ~> Double + loop D.Double (A.Number x) + = Right (D.DoubleLit $ toRealFloat x) + + -- string ~> Text + loop D.Text (A.String t) + = Right (D.TextLit (Chunks [] t)) + + -- bool ~> Bool + loop D.Bool (A.Bool t) + = Right (D.BoolLit t) + + -- null ~> Optional + loop (App D.Optional expr) A.Null + = Right $ App D.None expr + + -- value ~> Optional + loop (App D.Optional expr) value + = D.Some <$> loop expr value + + -- fail + loop expr value + = Left (Mismatch expr value) + + +-- ---------- +-- EXCEPTIONS +-- ---------- + +red, purple, green + :: (Monoid a, Data.String.IsString a) => a -> a +red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold +purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold +green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain + +showExpr :: ExprX -> String +showExpr dhall = Text.unpack (D.pretty dhall) + +showJSON :: A.Value -> String +showJSON value = BSL8.unpack (encodePretty value) + +data CompileError + -- Dhall shema + = TypeError (D.TypeError Src X) + | BadDhallType + ExprX -- Expression type + ExprX -- Whole expression + -- generic mismatch (fallback) + | Mismatch + ExprX -- Dhall expression + A.Value -- Aeson value + -- record specific + | MissingKey Text ExprX A.Value + | UnhandledKeys [Text] ExprX A.Value + | NoKeyValArray ExprX A.Value + | NoKeyValMap ExprX A.Value + -- union specific + | ContainsUnion ExprX + | UndecidableUnion ExprX A.Value [ExprX] + +instance Show CompileError where + show = showCompileError "JSON" showJSON + +instance Exception CompileError + +showCompileError :: String -> (A.Value -> String) -> CompileError -> String +showCompileError format showValue = let prefix = red "\nError: " + in \case + TypeError e -> show e + + BadDhallType t e -> prefix + <> "Schema expression is succesfully parsed but has Dhall type:\n" + <> showExpr t <> "\nExpected Dhall type: Type" + <> "\nParsed expression: " + <> showExpr e <> "\n" + + ContainsUnion e -> prefix + <> "Dhall type expression contains union type:\n" + <> showExpr e <> "\nwhile it is forbidden by option " + <> green "--unions-none\n" + + UndecidableUnion e v xs -> prefix + <> "More than one union component type matches " <> format <> " value" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\n" <> format <> ":\n" <> showValue v + <> "\n\nPossible matches:\n\n" -- Showing all the allowed matches + <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs) + where sep = red "\n--------\n" :: Text + + Mismatch e v -> prefix + <> "Dhall type expression and json value do not match:" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\n" <> format <> ":\n" <> showValue v + <> "\n" + + MissingKey k e v -> prefix + <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n" + <> showExpr e + <> "\nis not present in " <> format <> " object:\n" + <> showValue v <> "\n" + + UnhandledKeys ks e v -> prefix + <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks)) + <> " present in the " <> format <> " object but not in the corresponding Dhall record. This is not allowed in presence of " + <> green "--records-strict" <> " flag:" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\n" <> format <> ":\n" <> showValue v + <> "\n" + + NoKeyValArray e v -> prefix + <> "" <> format <> " (key-value) arrays cannot be converted to Dhall records under " + <> green "--no-keyval-arrays" <> " flag" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\n" <> format <> ":\n" <> showValue v + <> "\n" + + NoKeyValMap e v -> prefix + <> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under " + <> green "--no-keyval-arrays" <> " flag" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\n" <> format <> ":\n" <> showValue v + <> "\n" diff --git a/src/Dhall/Yaml.hs b/src/Dhall/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Yaml.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Dhall.Yaml ( jsonToYaml, yamlToJson ) where + +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) + +import qualified Data.Aeson +import qualified Data.ByteString +import qualified Data.Vector +import qualified Data.Yaml +#if MIN_VERSION_yaml(0,10,2) +import qualified Data.Text +import qualified Text.Libyaml +#endif + +-- | Transform json representation into yaml +jsonToYaml + :: Data.Aeson.Value + -> Bool + -> Bool + -> ByteString +jsonToYaml json documents quoted = case (documents, json) of + (True, Data.Yaml.Array elems) + -> Data.ByteString.intercalate "\n---\n" + $ fmap (encodeYaml encodeOptions) + $ Data.Vector.toList elems + _ -> encodeYaml encodeOptions json + where +#if !MIN_VERSION_yaml(0,10,2) + encodeYaml = Data.Yaml.encode +#else + encodeYaml = Data.Yaml.encodeWith + + customStyle = \s -> case () of + () + | "\n" `Data.Text.isInfixOf` s -> ( noTag, literal ) + | otherwise -> ( noTag, Text.Libyaml.SingleQuoted ) + where + noTag = Text.Libyaml.NoTag + literal = Text.Libyaml.Literal + + quotedOptions = Data.Yaml.setStringStyle + customStyle + Data.Yaml.defaultEncodeOptions + + encodeOptions = if quoted + then quotedOptions + else Data.Yaml.defaultEncodeOptions +#endif + +-- | Transform yaml representation into dhall +yamlToJson :: ByteString -> Either String Data.Aeson.Value +yamlToJson = + bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither' + diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -13,6 +13,7 @@ import qualified Dhall.Import import qualified Dhall.JSON import qualified Dhall.Parser +import qualified Dhall.Yaml import qualified Test.Tasty import qualified Test.Tasty.HUnit @@ -23,6 +24,8 @@ testTree = Test.Tasty.testGroup "dhall-json" [ issue48 + , yamlQuotedStrings + , yaml ] issue48 :: TestTree @@ -58,5 +61,61 @@ let message = "Conversion to homogeneous maps did not generate the expected JSON output" + + Test.Tasty.HUnit.assertEqual message expectedValue actualValue + +yamlQuotedStrings :: TestTree +yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assertion + where + assertion = do + let file = "./tasty/data/yaml.dhall" + + code <- Data.Text.IO.readFile file + + parsedExpression <- case Dhall.Parser.exprFromText file code of + Left exception -> Control.Exception.throwIO exception + Right parsedExpression -> return parsedExpression + + resolvedExpression <- Dhall.Import.load parsedExpression + + jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of + Left exception -> Control.Exception.throwIO exception + Right jsonValue -> return jsonValue + + let actualValue = Dhall.Yaml.jsonToYaml jsonValue False True + + bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml" + let expectedValue = Data.ByteString.Lazy.toStrict bytes + + let message = + "Conversion to quoted yaml did not generate the expected output" + + Test.Tasty.HUnit.assertEqual message expectedValue actualValue + +yaml :: TestTree +yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion + where + assertion = do + let file = "./tasty/data/yaml.dhall" + + code <- Data.Text.IO.readFile file + + parsedExpression <- case Dhall.Parser.exprFromText file code of + Left exception -> Control.Exception.throwIO exception + Right parsedExpression -> return parsedExpression + + resolvedExpression <- Dhall.Import.load parsedExpression + + jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of + Left exception -> Control.Exception.throwIO exception + Right jsonValue -> return jsonValue + + let actualValue = Dhall.Yaml.jsonToYaml jsonValue False False + + bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml" + let expectedValue = Data.ByteString.Lazy.toStrict bytes + + let message = + "Conversion to normal yaml did not generate the expected output" Test.Tasty.HUnit.assertEqual message expectedValue actualValue diff --git a/tasty/data/yaml.dhall b/tasty/data/yaml.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/yaml.dhall @@ -0,0 +1,5 @@ +{ string_value = "2000-01-01" +, text = ./tasty/data/yaml.txt as Text +, int_value = 1 +, bool_value = True +} diff --git a/yaml-to-dhall/Main.hs b/yaml-to-dhall/Main.hs new file mode 100644 --- /dev/null +++ b/yaml-to-dhall/Main.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import qualified Control.Exception +import Control.Exception (Exception, SomeException, throwIO) +import Control.Monad (when) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text.IO as Text +import Data.Version (showVersion) +import qualified GHC.IO.Encoding +import qualified Options.Applicative as O +import Options.Applicative (Parser, ParserInfo) +import qualified System.Exit +import qualified System.IO + +import qualified Dhall.Core as D +import Dhall.JSONToDhall +import Dhall.Yaml (yamlToJson, jsonToYaml) +import qualified Paths_dhall_json as Meta + +-- --------------- +-- Command options +-- --------------- + +-- | Command info and description +parserInfo :: ParserInfo Options +parserInfo = O.info + ( O.helper <*> parseOptions) + ( O.fullDesc + <> O.progDesc "Populate Dhall value given its Dhall type (schema) from a YAML expression" + ) + +-- | All the command arguments and options +data Options = Options + { version :: Bool + , schema :: Text + , conversion :: Conversion + } deriving Show + +-- | Parser for all the command arguments and options +parseOptions :: Parser Options +parseOptions = Options <$> parseVersion + <*> parseSchema + <*> parseConversion + where + parseSchema = O.strArgument + ( O.metavar "SCHEMA" + <> O.help "Dhall type expression (schema)" + ) + parseVersion = O.switch + ( O.long "version" + <> O.short 'V' + <> O.help "Display version" + ) + +-- ---------- +-- YAML +-- ---------- + +showYAML :: A.Value -> String +showYAML value = BS8.unpack (jsonToYaml value False False) + +data YAMLCompileError = YAMLCompileError CompileError + +instance Show YAMLCompileError where + show (YAMLCompileError e) = showCompileError "YAML" showYAML e + +instance Exception YAMLCompileError + +-- ---------- +-- Main +-- ---------- + +main :: IO () +main = do + GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 + + Options {..} <- O.execParser parserInfo + + when version $ do + putStrLn (showVersion Meta.version) + System.Exit.exitSuccess + + handle $ do + stdin <- BSL8.getContents + + value <- either (throwIO . userError) pure + (yamlToJson . BS8.concat $ BSL8.toChunks stdin) + + expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema + + case dhallFromJSON conversion expr value of + Left err -> throwIO $ YAMLCompileError err + Right res -> Text.putStr (D.pretty res) + +handle :: IO a -> IO a +handle = Control.Exception.handle handler + where + handler :: SomeException -> IO a + handler e = do + System.IO.hPutStrLn System.IO.stderr "" + System.IO.hPrint System.IO.stderr e + System.Exit.exitFailure