parent
4b8b8cd730
commit
194654c10c
|
@ -255,6 +255,7 @@ parseConversion = Conversion <$> parseStrict
|
||||||
<*> parseKVArr
|
<*> parseKVArr
|
||||||
<*> parseKVMap
|
<*> parseKVMap
|
||||||
<*> parseUnion
|
<*> parseUnion
|
||||||
|
<*> parseOmissibleLists
|
||||||
where
|
where
|
||||||
parseStrict =
|
parseStrict =
|
||||||
O.flag' True
|
O.flag' True
|
||||||
|
@ -275,6 +276,10 @@ parseConversion = Conversion <$> parseStrict
|
||||||
( O.long "no-keyval-maps"
|
( O.long "no-keyval-maps"
|
||||||
<> O.help "Disable conversion of homogeneous map objects to association lists"
|
<> O.help "Disable conversion of homogeneous map objects to association lists"
|
||||||
)
|
)
|
||||||
|
parseOmissibleLists = O.switch
|
||||||
|
( O.long "omissible-lists"
|
||||||
|
<> O.help "Tolerate missing list values, they are assumed empty"
|
||||||
|
)
|
||||||
|
|
||||||
-- | Parser for command options related to treating union types
|
-- | Parser for command options related to treating union types
|
||||||
parseUnion :: Parser UnionConv
|
parseUnion :: Parser UnionConv
|
||||||
|
@ -303,21 +308,23 @@ parseUnion =
|
||||||
|
|
||||||
-- | JSON-to-dhall translation options
|
-- | JSON-to-dhall translation options
|
||||||
data Conversion = Conversion
|
data Conversion = Conversion
|
||||||
{ strictRecs :: Bool
|
{ strictRecs :: Bool
|
||||||
, noKeyValArr :: Bool
|
, noKeyValArr :: Bool
|
||||||
, noKeyValMap :: Bool
|
, noKeyValMap :: Bool
|
||||||
, unions :: UnionConv
|
, unions :: UnionConv
|
||||||
|
, omissibleLists :: Bool
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
|
data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
|
||||||
|
|
||||||
-- | Default conversion options
|
-- | Default conversion options
|
||||||
defaultConversion :: Conversion
|
defaultConversion :: Conversion
|
||||||
defaultConversion = Conversion
|
defaultConversion = Conversion
|
||||||
{ strictRecs = False
|
{ strictRecs = False
|
||||||
, noKeyValArr = False
|
, noKeyValArr = False
|
||||||
, noKeyValMap = False
|
, noKeyValMap = False
|
||||||
, unions = UFirst
|
, unions = UFirst
|
||||||
|
, omissibleLists = False
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | The 'Expr' type concretization used throughout this module
|
-- | The 'Expr' type concretization used throughout this module
|
||||||
|
@ -416,6 +423,9 @@ dhallFromJSON (Conversion {..}) expressionType =
|
||||||
= loop t value
|
= loop t value
|
||||||
| App D.Optional t' <- t
|
| App D.Optional t' <- t
|
||||||
= Right (App D.None t')
|
= Right (App D.None t')
|
||||||
|
| App D.List _ <- t
|
||||||
|
, omissibleLists
|
||||||
|
= Right (D.ListLit (Just t) [])
|
||||||
| otherwise
|
| otherwise
|
||||||
= Left (MissingKey k t v)
|
= Left (MissingKey k t v)
|
||||||
in D.RecordLit <$> Map.traverseWithKey f r
|
in D.RecordLit <$> Map.traverseWithKey f r
|
||||||
|
@ -470,6 +480,12 @@ dhallFromJSON (Conversion {..}) expressionType =
|
||||||
(Seq.fromList es)
|
(Seq.fromList es)
|
||||||
in f <$> traverse (loop t) (toList a)
|
in f <$> traverse (loop t) (toList a)
|
||||||
|
|
||||||
|
-- null ~> List
|
||||||
|
loop t@(App D.List _) (A.Null)
|
||||||
|
= if omissibleLists
|
||||||
|
then Right (D.ListLit (Just t) [])
|
||||||
|
else Left (Mismatch t A.Null)
|
||||||
|
|
||||||
-- number ~> Integer
|
-- number ~> Integer
|
||||||
loop D.Integer (A.Number x)
|
loop D.Integer (A.Number x)
|
||||||
| Right n <- floatingOrInteger x :: Either Double Integer
|
| Right n <- floatingOrInteger x :: Either Double Integer
|
||||||
|
|
|
@ -44,6 +44,7 @@ testTree =
|
||||||
, testJSONToDhall "./tasty/data/emptyList"
|
, testJSONToDhall "./tasty/data/emptyList"
|
||||||
, testJSONToDhall "./tasty/data/emptyObjectStrongType"
|
, testJSONToDhall "./tasty/data/emptyObjectStrongType"
|
||||||
, testJSONToDhall "./tasty/data/emptyListStrongType"
|
, testJSONToDhall "./tasty/data/emptyListStrongType"
|
||||||
|
, testCustomConversionJSONToDhall omissibleLists "./tasty/data/missingList"
|
||||||
, Test.Tasty.testGroup "Nesting"
|
, Test.Tasty.testGroup "Nesting"
|
||||||
[ testDhallToJSON "./tasty/data/nesting0"
|
[ testDhallToJSON "./tasty/data/nesting0"
|
||||||
, testDhallToJSON "./tasty/data/nesting1"
|
, testDhallToJSON "./tasty/data/nesting1"
|
||||||
|
@ -57,6 +58,7 @@ testTree =
|
||||||
, testDhallToJSON "./tasty/data/unionKeys"
|
, testDhallToJSON "./tasty/data/unionKeys"
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
where omissibleLists = JSONToDhall.defaultConversion{JSONToDhall.omissibleLists = True}
|
||||||
|
|
||||||
testDhallToJSON :: String -> TestTree
|
testDhallToJSON :: String -> TestTree
|
||||||
testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do
|
testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do
|
||||||
|
@ -92,8 +94,9 @@ testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do
|
||||||
|
|
||||||
Test.Tasty.HUnit.assertEqual message expectedValue actualValue
|
Test.Tasty.HUnit.assertEqual message expectedValue actualValue
|
||||||
|
|
||||||
testJSONToDhall :: String -> TestTree
|
testCustomConversionJSONToDhall :: JSONToDhall.Conversion -> String -> TestTree
|
||||||
testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do
|
testCustomConversionJSONToDhall conv prefix =
|
||||||
|
Test.Tasty.HUnit.testCase prefix $ do
|
||||||
let inputFile = prefix <> ".json"
|
let inputFile = prefix <> ".json"
|
||||||
let schemaFile = prefix <> "Schema.dhall"
|
let schemaFile = prefix <> "Schema.dhall"
|
||||||
let outputFile = prefix <> ".dhall"
|
let outputFile = prefix <> ".dhall"
|
||||||
|
@ -114,7 +117,7 @@ testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do
|
||||||
_ <- Core.throws (Dhall.TypeCheck.typeOf schema)
|
_ <- Core.throws (Dhall.TypeCheck.typeOf schema)
|
||||||
|
|
||||||
actualExpression <- do
|
actualExpression <- do
|
||||||
Core.throws (JSONToDhall.dhallFromJSON JSONToDhall.defaultConversion schema value)
|
Core.throws (JSONToDhall.dhallFromJSON conv schema value)
|
||||||
|
|
||||||
outputText <- Data.Text.IO.readFile outputFile
|
outputText <- Data.Text.IO.readFile outputFile
|
||||||
|
|
||||||
|
@ -132,6 +135,9 @@ testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do
|
||||||
|
|
||||||
Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression
|
Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression
|
||||||
|
|
||||||
|
testJSONToDhall :: String -> TestTree
|
||||||
|
testJSONToDhall = testCustomConversionJSONToDhall JSONToDhall.defaultConversion
|
||||||
|
|
||||||
testDhallToYaml :: Dhall.Yaml.Options -> String -> TestTree
|
testDhallToYaml :: Dhall.Yaml.Options -> String -> TestTree
|
||||||
testDhallToYaml options prefix = Test.Tasty.HUnit.testCase prefix $ do
|
testDhallToYaml options prefix = Test.Tasty.HUnit.testCase prefix $ do
|
||||||
let inputFile = prefix <> ".dhall"
|
let inputFile = prefix <> ".dhall"
|
||||||
|
|
1
dhall-json/tasty/data/missingList.dhall
Normal file
1
dhall-json/tasty/data/missingList.dhall
Normal file
|
@ -0,0 +1 @@
|
||||||
|
{present = ["some-stuff"], null = [] : List Text, missing = [] : List Text}
|
1
dhall-json/tasty/data/missingList.json
Normal file
1
dhall-json/tasty/data/missingList.json
Normal file
|
@ -0,0 +1 @@
|
||||||
|
{"present": ["some-stuff"], "null": null}
|
1
dhall-json/tasty/data/missingListSchema.dhall
Normal file
1
dhall-json/tasty/data/missingListSchema.dhall
Normal file
|
@ -0,0 +1 @@
|
||||||
|
{present : List Text, null : List Text, missing : List Text}
|
Loading…
Reference in New Issue
Block a user