dhall-json 1.2.8 → 1.3.0

raw patch · 11 files changed

+949/−535 lines, 11 filesdep +lensdep +libyamldep ~aesondep ~aeson-prettydep ~basenew-component:exe:yaml-to-dhallPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, libyaml

Dependency ranges changed: aeson, aeson-pretty, base, dhall, optparse-applicative, text, unordered-containers, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• dhall-json.cabal +50/−15
• dhall-to-json/Main.hs +20/−7
• dhall-to-yaml/Main.hs +12/−10
• json-to-dhall/Main.hs +4/−490
• src/Dhall/JSON.hs +85/−13
• src/Dhall/JSONToDhall.hs +529/−0
• src/Dhall/Yaml.hs +56/−0
• tasty/Main.hs +59/−0
• tasty/data/yaml.dhall +5/−0
• yaml-to-dhall/Main.hs +114/−0

@@ -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

@@ -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:

@@ -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 

@@ -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 

@@ -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

@@ -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+

@@ -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"

@@ -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'+

@@ -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

@@ -0,0 +1,5 @@+{ string_value = "2000-01-01"+, text = ./tasty/data/yaml.txt as Text+, int_value = 1+, bool_value = True+}

@@ -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