dhall-to-toml: basic conversion (#2229)

* convert primitive types
* convert records
* dhall-to-toml command that works through stdin and stdout
* added a partition function to Dhall.Map, it was needed in the TOML
  table implementation
* enable and pass tests for dhallToToml

Still needed are unions and lists

dhall-toml/src/Dhall/Toml.hs

@@ -7,33 +7,101 @@ module Dhall.Toml
     , dhallToToml
     ) where
 
-
-import Control.Exception (Exception)
+import Control.Monad     (foldM)
+import Control.Exception (Exception, throwIO)
 import Data.Void         (Void)
-import Dhall.Core        (Expr)
+import Dhall.Core        (Expr, DhallDouble(..))
 import Dhall.Parser      (Src)
 import Toml.Type.TOML    (TOML)
+import Toml.Type.Key     (Piece(Piece), Key(Key))
+import Toml.Type.Printer (pretty)
+
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Text.IO       as Text.IO
+import qualified Dhall.Map          as Map
+import qualified Dhall.Core         as Core
+import qualified Dhall.Import
+import qualified Dhall.Parser
+import qualified Dhall.TypeCheck
+import qualified Toml.Type.TOML     as Toml.TOML
+import qualified Toml.Type.Value    as Toml.Value
 
 
--- TODO: populate with actual errors
 data CompileError
-    = CompileError String
+    = Unimplemented String
+    | Unsupported (Expr Void Void)
+    | NotARecord (Expr Void Void)
 
 instance Show CompileError where
-    show (CompileError s) = "compile error: " ++ s
+    show (Unimplemented s) = "unimplemented: " ++ s
+    show (Unsupported e) = "unsupported: " ++ show e
+    show (NotARecord e) = "The root object converted to TOML must be a record, got " ++ show e
 
 instance Exception CompileError
 
 dhallToToml :: Expr s Void -> Either CompileError TOML
-dhallToToml _ = Left $ CompileError  "not implemented"
+dhallToToml e0 = do
+    let norm = Core.normalize e0
+    _ <- assertRecordLit norm
+    toToml (mempty :: TOML) [] norm
+    where
+        assertRecordLit (Core.RecordLit r) = Right r
+        assertRecordLit e                  = Left $ NotARecord e
+
+-- | A helper function for dhallToToml. It recursively adds the values in
+--   the Expr to the TOML. It has an invariant that key can be null iff
+--   Expr is a RecordLit. This aligns with how a TOML document must be a table,
+--   and bare values cannot be represented
+toToml :: TOML -> [Piece] -> Expr Void Void -> Either CompileError TOML
+toToml toml key expr  = case expr of
+    Core.BoolLit a -> return $ insertPrim (Toml.Value.Bool a)
+    Core.NaturalLit a -> return $ insertPrim (Toml.Value.Integer $ toInteger a)
+    Core.DoubleLit (DhallDouble a) -> return $ insertPrim (Toml.Value.Double a)
+    Core.TextLit (Core.Chunks [] a) -> return $ insertPrim (Toml.Value.Text a)
+    -- TODO: probe the element type, if record then table list else inline list
+    -- Core.ListLit _ a -> Left $ Unimplemented
+    Core.RecordLit r ->
+        let
+            f toml' (key', val) = toToml toml' [Piece key'] (Core.recordFieldValue val)
+        in
+            if null key -- at the top level, we can't have a table
+            then foldM f toml (Map.toList r)
+            else do
+                let (flat, nested) = Map.partition (isFlat . Core.recordFieldValue) r
+                -- the order here is important, at least for testing, because
+                -- the PrefixMap inside TOML is dependent on insert order
+                flatTable   <- foldM f mempty    (Map.toList flat)
+                nestedTable <- foldM f flatTable (Map.toList nested)
+                return $ Toml.TOML.insertTable (Key $ NonEmpty.fromList key) nestedTable toml
+    _ -> Left $ Unsupported expr
+    where
+        -- insert a value at the current key to the TOML, note that
+        -- the current key cannot be empty. This is true assuming
+        -- the root call to toToml is always called with a RecordLit
+        insertPrim :: Toml.Value.Value a -> TOML
+        insertPrim val = Toml.TOML.insertKeyVal (Key $ NonEmpty.fromList key) val toml
+        isFlat v = case v of
+            Core.BoolLit _ -> True
+            Core.NaturalLit _ -> True
+            Core.DoubleLit _ -> True
+            Core.TextLit _ -> True
+            _ -> False
 
 type ExprX = Expr Src Void
 
 tomlToDhall :: ExprX -> TOML -> Either CompileError ExprX
-tomlToDhall _ _ = Left $ CompileError "not implemented"
+tomlToDhall _ _ = Left $ Unimplemented "toml -> dhall"
 
 dhallToTomlMain :: IO ()
-dhallToTomlMain = putStrLn "not implemented"
+dhallToTomlMain = do
+    text <- Text.IO.getContents
+    parsedExpression <- Core.throws (Dhall.Parser.exprFromText "(input)" text)
+    resolvedExpression <- Dhall.Import.load parsedExpression
+    _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
+    toml <- case dhallToToml resolvedExpression of
+        Left err -> throwIO err
+        Right toml -> return toml
+    Text.IO.putStrLn $ pretty toml
 
 tomlToDhallMain :: IO ()
 tomlToDhallMain = putStrLn "not implemented"

dhall-toml/tasty/Main.hs

@@ -1,6 +1,11 @@
 module Main where
 
-import Test.Tasty (TestTree)
+import Control.Monad       (unless)
+import Data.Text           (unpack)
+import Test.Tasty          (TestTree)
+import Test.Tasty.HUnit    (HasCallStack, Assertion, assertFailure)
+import Toml.Type.TOML      (TOML, tomlDiff)
+import Toml.Type.Printer   (pretty)
 
 import qualified Toml.Parser
 import qualified Data.Text.IO
@@ -22,11 +27,15 @@ main = do
 
 testTree :: TestTree
 testTree =
-    Test.Tasty.testGroup "dhall-toml" [] -- dhallToTomlTests
+    Test.Tasty.testGroup "dhall-toml" dhallToTomlTests
     where
         dhallToTomlTests = map testDhallToToml
             [ "./tasty/data/empty"
             , "./tasty/data/natural"
+            , "./tasty/data/float"
+            , "./tasty/data/multiple-fields"
+            , "./tasty/data/nested-tables"
+            , "./tasty/data/adjacent-tables"
             ]
 
 testDhallToToml :: String -> TestTree
@@ -45,5 +54,15 @@ testDhallToToml prefix = Test.Tasty.HUnit.testCase prefix $ do
         Left tomlErr -> fail $ show tomlErr
         Right expectedValue -> return expectedValue
     let message = "Conversion to TOML did not generate the expected output"
-    Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+    assertTomlEq message expectedValue actualValue
+
+assertTomlEq :: HasCallStack => String -> TOML -> TOML -> Assertion
+assertTomlEq prefix expected actual  = unless (expected == actual) (assertFailure msg)
+    where
+        pretty' = unpack . pretty
+        msg = prefix ++ "\nExpected:\n" ++ pretty' expected ++ "\nActual:\n" ++ pretty' actual ++
+            "Diff:\nMissing:\n" ++ pretty' (tomlDiff expected actual) ++
+            "\nExtra:\n" ++ pretty' (tomlDiff actual expected) ++
+            "AST:\nExpected:\n" ++ show expected ++ "\nActual:\n" ++ show actual
+
 

dhall-toml/tasty/data/adjacent-tables.dhall

@@ -0,0 +1,12 @@
+{
+  a = {
+    a1 = 1,
+    a2 = True,
+    a3 = "hello"
+  },
+  b = {
+    b1 = 2,
+    b2 = False,
+    b3 = "world"
+  }
+}

dhall-toml/tasty/data/adjacent-tables.toml

@@ -0,0 +1,9 @@
+[a]
+    a1 = 1
+    a2 = true
+    a3 = "hello"
+
+[b]
+    b1 = 2
+    b2 = false
+    b3 = "world"

dhall-toml/tasty/data/float.dhall

@@ -0,0 +1,3 @@
+{
+  pi = 3.141592653589793
+}

dhall-toml/tasty/data/float.toml

@@ -0,0 +1 @@
+pi = 3.141592653589793

dhall-toml/tasty/data/multiple-fields.dhall

@@ -0,0 +1,5 @@
+{
+    a = "hello",
+    b = 42,
+    c = True
+}

dhall-toml/tasty/data/multiple-fields.toml

@@ -0,0 +1,3 @@
+a = "hello"
+b = 42
+c = true

dhall-toml/tasty/data/nested-tables.dhall

@@ -0,0 +1,11 @@
+{
+  a1 = {
+    b1 = "hello",
+    b2 = "world",
+    b3 = {
+      c1 = "!",
+      c2 = 42,
+    },
+  },
+  a2 = True
+}

dhall-toml/tasty/data/nested-tables.toml

@@ -0,0 +1,9 @@
+a2 = true
+
+[a1]
+    b1 = "hello"
+    b2 = "world"
+
+    [a1.b3]
+        c1 = "!"
+        c2 = 42

dhall/src/Dhall/Map.hs

@@ -33,6 +33,7 @@ module Dhall.Map
       -- * Deletion/Update
     , delete
     , filter
+    , partition
     , restrictKeys
     , withoutKeys
     , mapMaybe
@@ -356,6 +357,21 @@ filter predicate (Map m ks) = Map m' ks'
     ks' = filterKeys (\k -> Data.Map.member k m') ks
 {-# INLINABLE filter #-}
 
+{-| Split the map into values that do and don't satisfy the predicate
+
+>>> partition even (fromList [("C",3),("B",2),("A",1)])
+(fromList [("B",2)],fromList [("C",3),("A",1)])
+>>> partition odd (fromList [("C",3),("B",2),("A",1)])
+(fromList [("C",3),("A",1)],fromList [("B",2)])
+-}
+partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a, Map k a)
+partition predicate (Map m ks) = (Map mpass kpass, Map mfail kfail)
+  where
+    (mpass, mfail) = Data.Map.partition predicate m
+
+    (kpass, kfail) = partitionKeys (\k -> Data.Map.member k mpass) ks
+{-# INLINABLE partition #-}
+
 {-| Restrict a 'Map' to only those keys found in a @"Data.Set".'Data.Set.Set'@.
 
 >>> restrictKeys (fromList [("A",1),("B",2)]) (Data.Set.fromList ["A"])
@@ -693,6 +709,13 @@ filterKeys _ Sorted        = Sorted
 filterKeys f (Original ks) = Original (Prelude.filter f ks)
 {-# INLINABLE filterKeys #-}
 
+partitionKeys :: (a -> Bool) -> Keys a -> (Keys a, Keys a)
+partitionKeys _ Sorted        = (Sorted, Sorted)
+partitionKeys f (Original ks) =
+    let (kpass, kfail) = Data.List.partition f ks
+    in (Original kpass, Original kfail)
+{-# INLINABLE partitionKeys #-}
+
 {- $setup
 >>> import Test.QuickCheck (Arbitrary(..), oneof)
 >>> :{