Optionally allow missing lists in yaml/json-to-dhall (#1414)

[#1410]

dhall-json/src/Dhall/JSONToDhall.hs

@@ -255,6 +255,7 @@ parseConversion = Conversion <$> parseStrict
                              <*> parseKVArr
                              <*> parseKVMap
                              <*> parseUnion
+                             <*> parseOmissibleLists
   where
     parseStrict =
             O.flag' True
@@ -275,6 +276,10 @@ parseConversion = Conversion <$> parseStrict
                 (  O.long "no-keyval-maps"
                 <> 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
 parseUnion :: Parser UnionConv
@@ -303,21 +308,23 @@ parseUnion =
 
 -- | JSON-to-dhall translation options
 data Conversion = Conversion
-    { strictRecs  :: Bool
-    , noKeyValArr :: Bool
-    , noKeyValMap :: Bool
-    , unions      :: UnionConv
+    { strictRecs     :: Bool
+    , noKeyValArr    :: Bool
+    , noKeyValMap    :: Bool
+    , unions         :: UnionConv
+    , omissibleLists :: Bool
     } 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
+defaultConversion = Conversion
+    { strictRecs     = False
+    , noKeyValArr    = False
+    , noKeyValMap    = False
+    , unions         = UFirst
+    , omissibleLists = False
     }
 
 -- | The 'Expr' type concretization used throughout this module
@@ -416,6 +423,9 @@ dhallFromJSON (Conversion {..}) expressionType =
                     = loop t value
                     | App D.Optional t' <- t
                     = Right (App D.None t')
+                    | App D.List _ <- t
+                    , omissibleLists
+                    = Right (D.ListLit (Just t) [])
                     | otherwise
                     = Left (MissingKey k t v)
            in D.RecordLit <$> Map.traverseWithKey f r
@@ -470,6 +480,12 @@ dhallFromJSON (Conversion {..}) expressionType =
                        (Seq.fromList es)
            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
     loop D.Integer (A.Number x)
         | Right n <- floatingOrInteger x :: Either Double Integer

dhall-json/tasty/Main.hs

@@ -44,6 +44,7 @@ testTree =
         , testJSONToDhall "./tasty/data/emptyList"
         , testJSONToDhall "./tasty/data/emptyObjectStrongType"
         , testJSONToDhall "./tasty/data/emptyListStrongType"
+        , testCustomConversionJSONToDhall omissibleLists "./tasty/data/missingList"
         , Test.Tasty.testGroup "Nesting"
             [ testDhallToJSON "./tasty/data/nesting0"
             , testDhallToJSON "./tasty/data/nesting1"
@@ -57,6 +58,7 @@ testTree =
             , testDhallToJSON "./tasty/data/unionKeys"
             ]
         ]
+    where omissibleLists = JSONToDhall.defaultConversion{JSONToDhall.omissibleLists = True}
 
 testDhallToJSON :: String -> TestTree
 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
 
-testJSONToDhall :: String -> TestTree
-testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do
+testCustomConversionJSONToDhall :: JSONToDhall.Conversion -> String -> TestTree
+testCustomConversionJSONToDhall conv prefix =
+  Test.Tasty.HUnit.testCase prefix $ do
     let inputFile = prefix <> ".json"
     let schemaFile = prefix <> "Schema.dhall"
     let outputFile = prefix <> ".dhall"
@@ -114,7 +117,7 @@ testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do
     _ <- Core.throws (Dhall.TypeCheck.typeOf schema)
 
     actualExpression <- do
-        Core.throws (JSONToDhall.dhallFromJSON JSONToDhall.defaultConversion schema value)
+        Core.throws (JSONToDhall.dhallFromJSON conv schema value)
 
     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
 
+testJSONToDhall :: String -> TestTree
+testJSONToDhall = testCustomConversionJSONToDhall JSONToDhall.defaultConversion
+
 testDhallToYaml :: Dhall.Yaml.Options -> String -> TestTree
 testDhallToYaml options prefix = Test.Tasty.HUnit.testCase prefix $ do
     let inputFile = prefix <> ".dhall"

dhall-json/tasty/data/missingList.dhall

@@ -0,0 +1 @@
+{present = ["some-stuff"], null = [] : List Text, missing = [] : List Text}

dhall-json/tasty/data/missingList.json

@@ -0,0 +1 @@
+{"present": ["some-stuff"], "null": null}

dhall-json/tasty/data/missingListSchema.dhall

@@ -0,0 +1 @@
+{present : List Text, null  : List Text, missing : List Text}