dhall-toml: Add support for Prelude.Map.Type (#2549)

Fixes #2509

This adds `dhall-to-toml` and `toml-to-dhall` support for
the `Prelude.Map.Type` type which is translated to and from
TOML tables.

Author: Gabriella439

dhall-toml/src/Dhall/DhallToToml.hs

@@ -1,6 +1,9 @@
-{-# LANGUAGE ApplicativeDo   #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo     #-}
+{-# LANGUAGE PatternSynonyms   #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 {-| This module exports the `dhallToToml` function for translating a
     Dhall syntax tree to a TOML syntax tree (`TOML`) for the @tomland@
@@ -81,6 +84,11 @@
 >   [r.nested]
 >     c = 3
 
+    … and @Prelude.Map.Type@ also translates to a TOML table:
+
+> $ dhall-to-toml <<< '[ { mapKey = "foo", mapValue = 1 } ]'
+> foo = 1
+
     Dhall unions translate to the wrapped value, or a string if the alternative is empty:
 
 > $ dhall-to-toml <<< '{ u = < A | B >.A }'
@@ -248,9 +256,21 @@ pattern UnionApp x <- Core.App (Core.Field (Core.Union _) _) x
 assertRecordLit
     :: Expr Void Void
     -> Either CompileError (Map Text (Core.RecordField Void Void))
-assertRecordLit (Core.RecordLit r) = Right r
-assertRecordLit (UnionApp x)       = assertRecordLit x
-assertRecordLit e                  = Left $ NotARecord e
+assertRecordLit (Core.RecordLit r) =
+    Right r
+assertRecordLit (UnionApp x) =
+    assertRecordLit x
+assertRecordLit (Core.ListLit _ expressions)
+    | Just keyValues <- traverse toKeyValue (toList expressions) =
+        Right (Map.fromList keyValues)
+  where
+    toKeyValue
+       (Core.RecordLit [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] key)), ("mapValue", value) ]) =
+       Just (key, value)
+    toKeyValue _ =
+       Nothing
+assertRecordLit e =
+    Left (NotARecord e)
 
 toTomlTable :: Map Text (Core.RecordField Void Void) -> Either CompileError TOML
 toTomlTable r = foldM (toTomlRecordFold []) (mempty :: TOML) (Map.toList r)
@@ -292,24 +312,6 @@ toToml toml pieces expr  = case expr of
     Core.App Core.None _ ->
         return toml
 
-    Core.ListLit _ a -> case toList a of
-        -- TODO: unions need to be handled here as well, it's a bit tricky
-        -- because they also have to be probed for being a "simple"
-        -- array of table
-        union@(UnionApp (Core.RecordLit _)) : unions -> do
-            insertTables (union :| unions)
-
-        record@(Core.RecordLit _) : records -> do
-            insertTables (record :| records)
-
-        -- inline array
-        expressions -> do
-            anyValues <- mapM toAnyValue expressions
-
-            case AnyValue.toMArray anyValues of
-                Left _ -> Left (HeterogeneousArray expr)
-                Right array -> insertPrim array
-
     Core.RecordLit r -> do
         let (inline, nested) =
                 Map.partition (isInline . Core.recordFieldValue) r
@@ -331,6 +333,28 @@ toToml toml pieces expr  = case expr of
         else do
             newPairs <- foldM (toTomlRecordFold []) mempty pairs
             return (TOML.insertTable key newPairs toml)
+
+    _ | Right keyValues <- assertRecordLit expr ->
+        toToml toml pieces (Core.RecordLit keyValues)
+
+    Core.ListLit _ a -> case toList a of
+        -- TODO: unions need to be handled here as well, it's a bit tricky
+        -- because they also have to be probed for being a "simple"
+        -- array of table
+        union@(UnionApp (Core.RecordLit _)) : unions -> do
+            insertTables (union :| unions)
+
+        record@(Core.RecordLit _) : records -> do
+            insertTables (record :| records)
+
+        -- inline array
+        expressions -> do
+            anyValues <- mapM toAnyValue expressions
+
+            case AnyValue.toMArray anyValues of
+                Left _ -> Left (HeterogeneousArray expr)
+                Right array -> insertPrim array
+
     _ ->
         Left (Unsupported expr)
   where

dhall-toml/src/Dhall/TomlToDhall.hs

@@ -1,7 +1,10 @@
-{-# LANGUAGE ApplicativeDo   #-}
-{-# LANGUAGE GADTs           #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo     #-}
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 {-| This module exports the `tomlToDhall` function for translating a
     TOML syntax tree from @tomland@ to a Dhall syntax tree. For now,
@@ -250,13 +253,6 @@ objectToDhall type_ object = case (type_, object) of
             []    -> Left (Incompatible type_ object)
             x : _ -> Right x
 
-    (Core.App Core.List t, Array []) ->
-        Right (Core.ListLit (Just t) [])
-
-    (Core.App Core.List t, Array elements) -> do
-        expressions <- mapM (objectToDhall t) elements
-        return (Core.ListLit Nothing (Seq.fromList expressions))
-
     (Core.Record record, Table table) -> do
         let process key fieldType
                 | Just nestedObject <- HashMap.lookup (Piece key) table =
@@ -272,6 +268,30 @@ objectToDhall type_ object = case (type_, object) of
 
         return (Core.RecordLit (fmap Core.makeRecordField expressions))
 
+    (Core.App Core.List (Core.Record [("mapKey", Core.recordFieldValue -> Core.Text), ("mapValue", Core.recordFieldValue -> valueType)]), Table table) -> do
+        hashMap <- traverse (objectToDhall valueType) table
+
+        let expressions = Seq.fromList do
+                (Piece key, value) <- HashMap.toList hashMap
+
+                let newKey =
+                        Core.makeRecordField (Core.TextLit (Core.Chunks [] key))
+
+                let newValue = Core.makeRecordField value
+
+                pure (Core.RecordLit [("mapKey", newKey), ("mapValue", newValue)])
+
+        let listType = if Seq.null expressions then Just type_ else Nothing
+
+        return (Core.ListLit listType expressions)
+
+    (Core.App Core.List t, Array []) ->
+        Right (Core.ListLit (Just t) [])
+
+    (Core.App Core.List t, Array elements) -> do
+        expressions <- mapM (objectToDhall t) elements
+        return (Core.ListLit Nothing (Seq.fromList expressions))
+
     (_, Prim (AnyValue value)) ->
         valueToDhall type_ value
 

dhall-toml/tasty/Main.hs

@@ -46,6 +46,9 @@ testTree =
             , "./tasty/data/union-typed"
             , "./tasty/data/union-nested"
             , "./tasty/data/optional"
+            , "./tasty/data/map-simple"
+            , "./tasty/data/map-complex"
+            , "./tasty/data/map-empty"
             ]
         tomlToDhallTests = map testTomlToDhall
             [ "./tasty/data/empty"
@@ -59,6 +62,8 @@ testTree =
             , "./tasty/data/union-empty"
             , "./tasty/data/union-typed"
             , "./tasty/data/optional"
+            , "./tasty/data/map-simple"
+            , "./tasty/data/map-empty"
             ]
 
 testDhallToToml :: String -> TestTree

dhall-toml/tasty/data/map-complex-schema.dhall

@@ -0,0 +1 @@
+{ foo : List { mapKey : Text, mapValue : { baz : Natural } } }

dhall-toml/tasty/data/map-complex.dhall

@@ -0,0 +1 @@
+{ foo = [ { mapValue = { baz = 1 }, mapKey = "bar" } ] }

dhall-toml/tasty/data/map-complex.toml

@@ -0,0 +1,2 @@
+[foo.bar]
+  baz = 1

dhall-toml/tasty/data/map-empty-schema.dhall

@@ -0,0 +1 @@
+List { mapKey : Text, mapValue : Natural }

dhall-toml/tasty/data/map-empty.dhall

@@ -0,0 +1 @@
+[] : List { mapKey : Text, mapValue : Natural }

dhall-toml/tasty/data/map-empty.toml

@@ -0,0 +1 @@
+List { mapKey : Text, mapValue : Natural }