json-to-dhall initial implementation (#884)
* Initial draft of the json-to-dhall tool * Homogenous JSON maps -> Dhall association lists. Bower example. * Default conversion options. Ghci examples in function annotations. * Added type signature to text color highlighting functions (error reporing) * Removed TypeApplications extension * Explicit semigroups * Disable ghc < 8.0 build * Type specifications for 'None's (e.g. None Integer instead of just None) * New style for unions, e.g.: < Left : Text | Right : Integer >.Right +1
This commit is contained in:
parent
d0fb71b0ba
commit
c52ae96a0b
|
@ -73,6 +73,29 @@ Executable dhall-to-yaml
|
||||||
text
|
text
|
||||||
GHC-Options: -Wall
|
GHC-Options: -Wall
|
||||||
|
|
||||||
|
Executable json-to-dhall
|
||||||
|
Hs-Source-Dirs: json-to-dhall
|
||||||
|
Main-Is: Main.hs
|
||||||
|
Build-Depends:
|
||||||
|
base ,
|
||||||
|
aeson ,
|
||||||
|
aeson-pretty < 0.9 ,
|
||||||
|
bytestring < 0.11 ,
|
||||||
|
dhall ,
|
||||||
|
optparse-applicative ,
|
||||||
|
text < 1.3 ,
|
||||||
|
scientific >= 0.3.0.0 && < 0.4 ,
|
||||||
|
exceptions >= 0.8.3 && < 0.11 ,
|
||||||
|
containers ,
|
||||||
|
unordered-containers >= 0.1.3.0 && < 0.3
|
||||||
|
if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4)
|
||||||
|
Build-Depends: semigroups == 0.18.*
|
||||||
|
Other-Modules:
|
||||||
|
Paths_dhall_json
|
||||||
|
GHC-Options: -Wall
|
||||||
|
if impl(ghc < 8.0)
|
||||||
|
Buildable: False
|
||||||
|
|
||||||
Test-Suite tasty
|
Test-Suite tasty
|
||||||
Type: exitcode-stdio-1.0
|
Type: exitcode-stdio-1.0
|
||||||
Hs-Source-Dirs: tasty
|
Hs-Source-Dirs: tasty
|
||||||
|
|
13
dhall-json/examples/bower.dhall
Normal file
13
dhall-json/examples/bower.dhall
Normal file
|
@ -0,0 +1,13 @@
|
||||||
|
-- Using this file:
|
||||||
|
-- json-to-dhall ./bower.dhall < ./bower.json | dhall
|
||||||
|
-- Round-trip test:
|
||||||
|
-- json-to-dhall ./bower.dhall < ./bower.json | dhall | dhall-to-json
|
||||||
|
|
||||||
|
{ name : Text
|
||||||
|
, description : Text
|
||||||
|
, license : Text
|
||||||
|
, keywords : List Text
|
||||||
|
, repository : { type : Text, url : Text}
|
||||||
|
, dependencies : List { mapKey: Text, mapValue: Text }
|
||||||
|
, devDependencies : List { mapKey: Text, mapValue: Text }
|
||||||
|
}
|
20
dhall-json/examples/bower.json
Normal file
20
dhall-json/examples/bower.json
Normal file
|
@ -0,0 +1,20 @@
|
||||||
|
{
|
||||||
|
"name": "purescript-package",
|
||||||
|
"description": "A simple PS package",
|
||||||
|
"keywords": [
|
||||||
|
"purescript"
|
||||||
|
],
|
||||||
|
"license": "MIT",
|
||||||
|
"repository": {
|
||||||
|
"type": "git",
|
||||||
|
"url": "git://github.com/purescript/purescript-package.git"
|
||||||
|
},
|
||||||
|
"dependencies": {
|
||||||
|
"purescript-prelude": "^4.0.0",
|
||||||
|
"purescript-effect": "^2.0.0"
|
||||||
|
},
|
||||||
|
"devDependencies": {
|
||||||
|
"purescript-math": "^2.1.1",
|
||||||
|
"purescript-integers": "^4.0.0"
|
||||||
|
}
|
||||||
|
}
|
586
dhall-json/json-to-dhall/Main.hs
Normal file
586
dhall-json/json-to-dhall/Main.hs
Normal file
|
@ -0,0 +1,586 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE PatternGuards #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# 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.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 Data.Semigroup (Semigroup)
|
||||||
|
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 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
|
||||||
|
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 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 JSON 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"
|
||||||
|
)
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
-- ----------
|
||||||
|
|
||||||
|
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 :: A.Value <- case A.eitherDecode stdin of
|
||||||
|
Left err -> throwIO (userError err)
|
||||||
|
Right v -> pure v
|
||||||
|
|
||||||
|
expr <- typeCheckSchemaExpr =<< resolveSchemaExpr schema
|
||||||
|
|
||||||
|
case dhallFromJSON conversion expr value of
|
||||||
|
Left err -> throwIO 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
|
||||||
|
|
||||||
|
|
||||||
|
-- ----------
|
||||||
|
-- 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
|
||||||
|
:: (Semigroup 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
|
Loading…
Reference in New Issue
Block a user