From 47ecbd2b8c6d889c20e48bea606e453cb5c151f6 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Tue, 21 Nov 2023 17:54:14 -0800 Subject: [PATCH] dhall-toml: Add support for Prelude.Map.Type Fixes https://github.com/dhall-lang/dhall-haskell/issues/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. --- dhall-toml/src/Dhall/DhallToToml.hs | 72 ++++++++++++------- dhall-toml/src/Dhall/TomlToDhall.hs | 42 ++++++++--- dhall-toml/tasty/Main.hs | 5 ++ .../tasty/data/map-complex-schema.dhall | 1 + dhall-toml/tasty/data/map-complex.dhall | 1 + dhall-toml/tasty/data/map-complex.toml | 2 + dhall-toml/tasty/data/map-empty-schema.dhall | 1 + dhall-toml/tasty/data/map-empty.dhall | 1 + dhall-toml/tasty/data/map-empty.toml | 0 dhall-toml/tasty/data/map-simple-schema.dhall | 1 + dhall-toml/tasty/data/map-simple.dhall | 1 + dhall-toml/tasty/data/map-simple.toml | 1 + 12 files changed, 93 insertions(+), 35 deletions(-) create mode 100644 dhall-toml/tasty/data/map-complex-schema.dhall create mode 100644 dhall-toml/tasty/data/map-complex.dhall create mode 100644 dhall-toml/tasty/data/map-complex.toml create mode 100644 dhall-toml/tasty/data/map-empty-schema.dhall create mode 100644 dhall-toml/tasty/data/map-empty.dhall create mode 100644 dhall-toml/tasty/data/map-empty.toml create mode 100644 dhall-toml/tasty/data/map-simple-schema.dhall create mode 100644 dhall-toml/tasty/data/map-simple.dhall create mode 100644 dhall-toml/tasty/data/map-simple.toml diff --git a/dhall-toml/src/Dhall/DhallToToml.hs b/dhall-toml/src/Dhall/DhallToToml.hs index 12ae146a6..c790ff8cd 100644 --- a/dhall-toml/src/Dhall/DhallToToml.hs +++ b/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 diff --git a/dhall-toml/src/Dhall/TomlToDhall.hs b/dhall-toml/src/Dhall/TomlToDhall.hs index c545b3446..aadcd506d 100644 --- a/dhall-toml/src/Dhall/TomlToDhall.hs +++ b/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 diff --git a/dhall-toml/tasty/Main.hs b/dhall-toml/tasty/Main.hs index 46d39bedf..6b0d87570 100644 --- a/dhall-toml/tasty/Main.hs +++ b/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 diff --git a/dhall-toml/tasty/data/map-complex-schema.dhall b/dhall-toml/tasty/data/map-complex-schema.dhall new file mode 100644 index 000000000..2b0a4d8fc --- /dev/null +++ b/dhall-toml/tasty/data/map-complex-schema.dhall @@ -0,0 +1 @@ +{ foo : List { mapKey : Text, mapValue : { baz : Natural } } } diff --git a/dhall-toml/tasty/data/map-complex.dhall b/dhall-toml/tasty/data/map-complex.dhall new file mode 100644 index 000000000..8696a2516 --- /dev/null +++ b/dhall-toml/tasty/data/map-complex.dhall @@ -0,0 +1 @@ +{ foo = [ { mapValue = { baz = 1 }, mapKey = "bar" } ] } diff --git a/dhall-toml/tasty/data/map-complex.toml b/dhall-toml/tasty/data/map-complex.toml new file mode 100644 index 000000000..405a92428 --- /dev/null +++ b/dhall-toml/tasty/data/map-complex.toml @@ -0,0 +1,2 @@ +[foo.bar] + baz = 1 diff --git a/dhall-toml/tasty/data/map-empty-schema.dhall b/dhall-toml/tasty/data/map-empty-schema.dhall new file mode 100644 index 000000000..4a9542d74 --- /dev/null +++ b/dhall-toml/tasty/data/map-empty-schema.dhall @@ -0,0 +1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-empty.dhall b/dhall-toml/tasty/data/map-empty.dhall new file mode 100644 index 000000000..05d70a8a8 --- /dev/null +++ b/dhall-toml/tasty/data/map-empty.dhall @@ -0,0 +1 @@ +[] : List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-empty.toml b/dhall-toml/tasty/data/map-empty.toml new file mode 100644 index 000000000..e69de29bb diff --git a/dhall-toml/tasty/data/map-simple-schema.dhall b/dhall-toml/tasty/data/map-simple-schema.dhall new file mode 100644 index 000000000..4a9542d74 --- /dev/null +++ b/dhall-toml/tasty/data/map-simple-schema.dhall @@ -0,0 +1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/dhall-toml/tasty/data/map-simple.dhall b/dhall-toml/tasty/data/map-simple.dhall new file mode 100644 index 000000000..22748d28e --- /dev/null +++ b/dhall-toml/tasty/data/map-simple.dhall @@ -0,0 +1 @@ +[ { mapKey = "foo", mapValue = 1 } ] diff --git a/dhall-toml/tasty/data/map-simple.toml b/dhall-toml/tasty/data/map-simple.toml new file mode 100644 index 000000000..c4e5bcc80 --- /dev/null +++ b/dhall-toml/tasty/data/map-simple.toml @@ -0,0 +1 @@ +foo = 1