dhall-toml 1.0.3 → 1.0.4
raw patch · 17 files changed
+479/−304 lines, 17 filesdep ~basedep ~containersdep ~filepathPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, filepath, optparse-applicative
API changes (from Hackage documentation)
+ Dhall.TomlToDhall: instance GHC.Base.Monoid Dhall.TomlToDhall.Object
Files
- CHANGELOG.md +5/−0
- README.md +2/−2
- dhall-toml.cabal +16/−15
- doctest/Main.hs +12/−2
- src/Dhall/DhallToToml.hs +208/−139
- src/Dhall/Toml/Utils.hs +10/−2
- src/Dhall/TomlToDhall.hs +212/−144
- tasty/Main.hs +5/−0
- tasty/data/map-complex-schema.dhall +1/−0
- tasty/data/map-complex.dhall +1/−0
- tasty/data/map-complex.toml +2/−0
- tasty/data/map-empty-schema.dhall +1/−0
- tasty/data/map-empty.dhall +1/−0
- tasty/data/map-empty.toml +0/−0
- tasty/data/map-simple-schema.dhall +1/−0
- tasty/data/map-simple.dhall +1/−0
- tasty/data/map-simple.toml +1/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+1.0.4++* [Add support for `Prelude.Map.Type`](https://github.com/dhall-lang/dhall-haskell/pull/2549)+* [Fix loading of relative paths](https://github.com/dhall-lang/dhall-haskell/pull/2607)+ 1.0.3 * [Support `Integer`s](https://github.com/dhall-lang/dhall-haskell/pull/2469)
README.md view
@@ -7,9 +7,9 @@ * [`dhall-haskell` - `README`](https://github.com/dhall-lang/dhall-haskell/blob/master/README.md) -Full documentation here:+Full documentation is available on Hackage: -* [`dhall-toml` instructions](https://hackage.haskell.org/package/dhall-toml/docs/Dhall-Toml.html)+* [`dhall-toml` on Hackage](https://hackage.haskell.org/package/dhall-toml) ## Introduction
dhall-toml.cabal view
@@ -1,5 +1,5 @@ Name: dhall-toml-Version: 1.0.3+Version: 1.0.4 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3@@ -36,12 +36,13 @@ Build-Depends: base >= 4.12 && < 5 , dhall >= 1.39.0 && < 1.43 ,+ filepath < 1.6 , tomland >= 1.3.2.0 && < 1.4 ,- text >= 0.11.1.0 && < 2.1 ,- containers >= 0.5.9 && < 0.7 ,+ text >= 0.11.1.0 && < 2.2 ,+ containers >= 0.5.9 && < 0.8 , unordered-containers >= 0.2 && < 0.3 , prettyprinter >= 1.7.0 && < 1.8 ,- optparse-applicative >= 0.14 && < 0.18+ optparse-applicative >= 0.14 && < 0.19 Exposed-Modules: Dhall.DhallToToml Dhall.TomlToDhall@@ -55,7 +56,7 @@ Hs-Source-Dirs: dhall-to-toml Main-Is: Main.hs Build-Depends:- base ,+ base >= 4.12 && < 5, dhall-toml GHC-Options: -Wall Default-Language: Haskell2010@@ -64,7 +65,7 @@ Hs-Source-Dirs: toml-to-dhall Main-Is: Main.hs Build-Depends:- base ,+ base >= 4.12 && < 5, dhall-toml GHC-Options: -Wall Default-Language: Haskell2010@@ -74,12 +75,12 @@ Hs-Source-Dirs: tasty Main-Is: Main.hs Build-Depends:- base ,- dhall ,- dhall-toml ,- tasty < 1.5 ,- tasty-hunit >= 0.2 ,- text ,+ base >= 4.12 && < 5 ,+ dhall ,+ dhall-toml ,+ tasty < 1.6,+ tasty-hunit >= 0.2 ,+ text , tomland GHC-Options: -Wall Default-Language: Haskell2010@@ -89,9 +90,9 @@ Hs-Source-Dirs: doctest Main-Is: Main.hs Build-Depends:- base ,- directory ,- filepath ,+ base >= 4.12 && < 5,+ directory ,+ filepath , doctest GHC-Options: -Wall Default-Language: Haskell2010
doctest/Main.hs view
@@ -1,14 +1,24 @@-module Main where+module Main (main) where import System.FilePath ((</>)) +import qualified GHC.IO.Encoding import qualified System.Directory+import qualified System.Environment+import qualified System.IO import qualified Test.DocTest main :: IO () main = do+ GHC.IO.Encoding.setLocaleEncoding System.IO.utf8+ args <- System.Environment.getArgs pwd <- System.Directory.getCurrentDirectory prefix <- System.Directory.makeAbsolute pwd let src = prefix </> "src"- Test.DocTest.doctest [ "--fast", "-i" <> src, src ] + Test.DocTest.doctest $+ [ "--fast"+ ] <> args <>+ [ "-i" <> src+ , src+ ]
src/Dhall/DhallToToml.hs view
@@ -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 }'@@ -103,7 +111,7 @@ , CompileError ) where -import Control.Exception (Exception, throwIO)+import Control.Exception (Exception) import Control.Monad (foldM) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty ((:|)))@@ -111,13 +119,14 @@ import Data.Version (showVersion) import Data.Void (Void) import Dhall.Core (DhallDouble (..), Expr)+import Dhall.Map (Map) import Dhall.Toml.Utils (fileToDhall, inputToDhall) import Prettyprinter (Pretty)-import Toml.Type.Key (Key (Key, unKey), Piece (Piece))-import Toml.Type.Printer (pretty)+import Toml.Type.Key (Key(..), Piece (Piece))+import Toml.Type.AnyValue (AnyValue(..)) import Toml.Type.TOML (TOML) -import qualified Data.Bifunctor as Bifunctor+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO@@ -125,12 +134,13 @@ import qualified Dhall.Map as Map import qualified Dhall.Pretty import qualified Dhall.Util-import qualified Options.Applicative as OA+import qualified Options.Applicative as Options import qualified Paths_dhall_toml as Meta import qualified Prettyprinter.Render.Text as Pretty-import qualified Toml.Type.AnyValue as Toml.AnyValue-import qualified Toml.Type.TOML as Toml.TOML-import qualified Toml.Type.Value as Toml.Value+import qualified Toml.Type.AnyValue as AnyValue+import qualified Toml.Type.Printer as Printer+import qualified Toml.Type.TOML as TOML+import qualified Toml.Type.Value as Value -- $setup --@@ -226,15 +236,15 @@ >>> import Toml.Type.Printer >>> f = makeRecordField >>> let toml = dhallToToml $ RecordLit [("foo", f $ NaturalLit 1), ("bar", f $ TextLit "ABC")]->>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Toml.Value.Integer 1)),("bar",AnyValue (Toml.Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []})+>>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Value.Integer 1)),("bar",AnyValue (Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []}) True >>> fmap Toml.Type.Printer.pretty toml Right "bar = \"ABC\"\nfoo = 1\n" -} dhallToToml :: Expr s Void -> Either CompileError TOML-dhallToToml e0 = do- r <- assertRecordLit (Core.normalize e0)- toTomlTable r+dhallToToml expression = do+ record <- assertRecordLit (Core.normalize expression)+ toTomlTable record -- empty union alternative like < A | B >.A pattern UnionEmpty :: Text -> Expr s a@@ -243,158 +253,217 @@ pattern UnionApp :: Expr s a -> Expr s a pattern UnionApp x <- Core.App (Core.Field (Core.Union _) _) x -assertRecordLit :: Expr Void Void -> Either CompileError (Map.Map Text (Core.RecordField Void Void))-assertRecordLit (Core.RecordLit r) = Right r-assertRecordLit (UnionApp x) = assertRecordLit x-assertRecordLit e = Left $ NotARecord e+assertRecordLit+ :: Expr Void Void+ -> Either CompileError (Map Text (Core.RecordField Void Void))+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.Map Text (Core.RecordField Void Void) -> Either CompileError TOML+toTomlTable :: Map Text (Core.RecordField Void Void) -> Either CompileError TOML toTomlTable r = foldM (toTomlRecordFold []) (mempty :: TOML) (Map.toList r) -toTomlRecordFold :: [Piece] -> TOML -> (Text, Core.RecordField Void Void) -> Either CompileError TOML-toTomlRecordFold curKey toml' (key', val) = toToml toml' newKey (Core.recordFieldValue val)- where- append :: [Piece] -> Piece -> NonEmpty Piece- append [] y = y :| []- append (x:xs) y = x :| xs ++ [y]- newKey = Key $ append curKey $ Piece key'+toTomlRecordFold+ :: [Piece]+ -> TOML+ -> (Text, Core.RecordField Void Void)+ -> Either CompileError TOML+toTomlRecordFold curKey toml (key, val) =+ toToml toml (Piece key :| curKey) (Core.recordFieldValue val) +toToml :: TOML -> NonEmpty Piece -> Expr Void Void -> Either CompileError TOML+toToml toml pieces expr = case expr of+ Core.BoolLit a ->+ insertPrim (Value.Bool a) + Core.NaturalLit a ->+ insertPrim (Value.Integer (toInteger a)) -toToml :: TOML -> Key -> 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.IntegerLit a -> return $ insertPrim (Toml.Value.Integer a)- Core.DoubleLit (DhallDouble a) -> return $ insertPrim (Toml.Value.Double a)- Core.TextLit (Core.Chunks [] a) -> return $ insertPrim (Toml.Value.Text a)- Core.App Core.None _ -> return toml- Core.Some a -> toToml toml key a- UnionEmpty a -> return $ insertPrim (Toml.Value.Text a)- UnionApp a -> toToml toml key a+ Core.IntegerLit a ->+ insertPrim (Value.Integer a)++ Core.DoubleLit (DhallDouble a) ->+ insertPrim (Value.Double a)++ Core.TextLit (Core.Chunks [] a) ->+ insertPrim (Value.Text a)++ UnionEmpty a ->+ insertPrim (Value.Text a)++ UnionApp a ->+ toToml toml pieces a++ Core.Some a ->+ toToml toml pieces a++ Core.App Core.None _ ->+ return toml++ Core.RecordLit r -> do+ let (inline, nested) =+ Map.partition (isInline . Core.recordFieldValue) r++ -- the order here is important, at least for testing, because the+ -- PrefixMap inside TOML is dependent on insert order+ let pairs = Map.toList inline <> Map.toList nested++ if null inline+ -- if the table doesn't have inline elements, don't register the table,+ -- only its non-inlined children. Ex:+ -- [a] # bad+ -- [b]+ -- c = 1+ -- [a.b] # good+ -- c = 1+ then do+ foldM (toTomlRecordFold (toList pieces)) toml pairs+ 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- -- empty array- [] -> return $ insertPrim (Toml.Value.Array []) -- 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- tables' <- case mapM assertRecordLit (union :| unions) of- Right x -> mapM toTomlTable x- Left (NotARecord e) -> Left (HeterogeneousArray e)- Left x -> Left x- return $ Toml.TOML.insertTableArrays key tables' toml+ insertTables (union :| unions) record@(Core.RecordLit _) : records -> do- tables' <- case mapM assertRecordLit (record :| records) of- Right x -> mapM toTomlTable x- Left (NotARecord e) -> Left (HeterogeneousArray e)- Left x -> Left x- return $ Toml.TOML.insertTableArrays key tables' toml+ insertTables (record :| records)+ -- inline array- a' -> do- anyList <- mapM toAny a'- let arrayEither = Toml.AnyValue.toMArray anyList- array <- Bifunctor.first (const $ HeterogeneousArray expr) arrayEither- return $ insertPrim array- Core.RecordLit r ->- let- (inline, nested) = Map.partition (isInline . Core.recordFieldValue) r- in- if null inline- -- if the table doesn't have inline elements, don't register- -- the table, only its non-inlined children. Ex:- -- [a] # bad- -- [b]- -- c = 1- -- [a.b] # good- -- c = 1- then foldM (toTomlRecordFold $ toList $ unKey key) toml (Map.toList nested)- else do- -- the order here is important, at least for testing, because- -- the PrefixMap inside TOML is dependent on insert order- inlinePairs <- foldM (toTomlRecordFold []) mempty (Map.toList inline)- nestedPairs <- foldM (toTomlRecordFold []) inlinePairs (Map.toList nested)- return $ Toml.TOML.insertTable key nestedPairs toml- _ -> Left $ Unsupported expr- where- insertPrim :: Toml.Value.Value a -> TOML- insertPrim val = Toml.TOML.insertKeyVal key val toml+ expressions -> do+ anyValues <- mapM toAnyValue expressions - -- checks if the value should be represented as an inline key/value- -- pair. Elements that are inlined are those that do not have a- -- [header] or [[header]]. One edge case is tables within multiple- -- arrays, though not currently supported by tomland, can only- -- be represented as inline tables.- isInline v = case v of- Core.BoolLit _ -> True- Core.IntegerLit _ -> True- Core.NaturalLit _ -> True- Core.DoubleLit _ -> True- Core.TextLit _ -> True- Core.ListLit _ s -> case Seq.lookup 0 s of- Nothing -> True- Just (Core.BoolLit _) -> True- Just (Core.NaturalLit _) -> True- Just (Core.DoubleLit _) -> True- Just (Core.TextLit _) -> True- Just (Core.ListLit _ _) -> True- _ -> False- _ -> False+ case AnyValue.toMArray anyValues of+ Left _ -> Left (HeterogeneousArray expr)+ Right array -> insertPrim array - rightAny = Right . Toml.AnyValue.AnyValue+ _ ->+ Left (Unsupported expr)+ where+ key :: Key+ key = Key (NonEmpty.reverse pieces) - -- toAny is a helper function for making lists so it returns a list- -- specific error, in particular tomland's inability to represent- -- tables in multi-dimensional arrays- toAny :: Expr Void Void -> Either CompileError Toml.AnyValue.AnyValue- toAny e = case e of- Core.BoolLit x -> rightAny $ Toml.Value.Bool x- Core.IntegerLit x -> rightAny $ Toml.Value.Integer x- Core.NaturalLit x -> rightAny $ Toml.Value.Integer $ toInteger x- Core.DoubleLit (DhallDouble x) -> rightAny $ Toml.Value.Double x- Core.TextLit (Core.Chunks [] x) -> rightAny $ Toml.Value.Text x- UnionEmpty x -> rightAny $ Toml.Value.Text x- UnionApp x -> toAny x- Core.ListLit _ x -> do- anyList <- mapM toAny $ toList x- case Toml.AnyValue.toMArray anyList of- Right x' -> rightAny x'- Left _ -> Left $ HeterogeneousArray expr- Core.RecordLit _ -> Left $ UnsupportedArray e- _ -> Left $ Unsupported e+ insertPrim :: Value.Value a -> Either CompileError TOML+ insertPrim val = return (TOML.insertKeyVal key val toml) + insertTables :: NonEmpty (Expr Void Void) -> Either CompileError TOML+ insertTables expressions = do+ tables <- case mapM assertRecordLit expressions of+ Right x -> mapM toTomlTable x+ Left (NotARecord e) -> Left (HeterogeneousArray e)+ Left x -> Left x+ return (TOML.insertTableArrays key tables toml)++ -- checks if the value should be represented as an inline key/value pair.+ -- Elements that are inlined are those that do not have a [header] or+ -- [[header]]. One edge case is tables within multiple arrays, though not+ -- currently supported by tomland, can only be represented as inline tables.+ isInline v = case v of+ Core.BoolLit _ -> True+ Core.IntegerLit _ -> True+ Core.NaturalLit _ -> True+ Core.DoubleLit _ -> True+ Core.TextLit _ -> True+ Core.ListLit _ s -> case Seq.lookup 0 s of+ Nothing -> True+ Just (Core.BoolLit _) -> True+ Just (Core.NaturalLit _) -> True+ Just (Core.DoubleLit _) -> True+ Just (Core.TextLit _) -> True+ Just (Core.ListLit _ _) -> True+ _ -> False+ _ -> False++ -- toAnyValue is a helper function for making lists so it returns a list+ -- specific error, in particular tomland's inability to represent tables in+ -- multi-dimensional arrays+ toAnyValue :: Expr Void Void -> Either CompileError AnyValue+ toAnyValue expression = case expression of+ Core.BoolLit x ->+ Right (AnyValue (Value.Bool x))+ Core.IntegerLit x ->+ Right (AnyValue (Value.Integer x))+ Core.NaturalLit x ->+ Right (AnyValue (Value.Integer (toInteger x)))+ Core.DoubleLit (DhallDouble x) ->+ Right (AnyValue (Value.Double x))+ Core.TextLit (Core.Chunks [] x) ->+ Right (AnyValue (Value.Text x))+ UnionEmpty x ->+ Right (AnyValue (Value.Text x))+ UnionApp x ->+ toAnyValue x+ Core.ListLit _ x -> do+ anyList <- mapM toAnyValue (toList x)+ case AnyValue.toMArray anyList of+ Right x' -> Right (AnyValue x')+ Left _ -> Left (HeterogeneousArray expr)+ Core.RecordLit _ ->+ Left (UnsupportedArray expression)+ _ ->+ Left (Unsupported expression)+ data Options = Options { input :: Maybe FilePath , output :: Maybe FilePath } -parserInfo :: OA.ParserInfo Options-parserInfo = OA.info- (OA.helper <*> versionOption <*> optionsParser)- (OA.fullDesc <> OA.progDesc "Convert Dhall to TOML")+parserInfo :: Options.ParserInfo Options+parserInfo = Options.info+ (Options.helper <*> versionOption <*> optionsParser)+ (Options.fullDesc <> Options.progDesc "Convert Dhall to TOML") where- versionOption = OA.infoOption (showVersion Meta.version) $- OA.long "version" <> OA.help "Display version"+ versionOption =+ Options.infoOption (showVersion Meta.version)+ (Options.long "version" <> Options.help "Display version")+ optionsParser = do- input <- OA.optional . OA.strOption $- OA.long "file"- <> OA.help "Read Dhall from file instead of standard input"- <> fileOpts- output <- OA.optional . OA.strOption $- OA.long "output"- <> OA.help "Write TOML to a file instead of standard output"- <> fileOpts- pure Options {..}- fileOpts = OA.metavar "FILE" <> OA.action "file"+ input <- (Options.optional . Options.strOption)+ ( Options.long "file"+ <> Options.help "Read Dhall from file instead of standard input"+ <> Options.metavar "FILE"+ <> Options.action "file"+ ) + output <- (Options.optional . Options.strOption)+ ( Options.long "output"+ <> Options.help "Write TOML to a file instead of standard output"+ <> Options.metavar "FILE"+ <> Options.action "file"+ )++ pure Options{..}+ {-| Runs the @dhall-to-toml@ command -} dhallToTomlMain :: IO () dhallToTomlMain = do- Options {..} <- OA.execParser parserInfo+ Options{..} <- Options.execParser parserInfo+ resolvedExpression <- maybe inputToDhall fileToDhall input- toml <- case dhallToToml resolvedExpression of- Left err -> throwIO err- Right toml -> return toml- maybe Text.IO.putStrLn Text.IO.writeFile output $ pretty toml++ toml <- Core.throws (dhallToToml resolvedExpression)++ let text = Printer.pretty toml++ case output of+ Just file -> Text.IO.writeFile file text+ Nothing -> Text.IO.putStrLn text
src/Dhall/Toml/Utils.hs view
@@ -10,6 +10,7 @@ import Data.Text (Text) import Data.Void (Void)+import Dhall.Import (SemanticCacheMode(..)) import Dhall.Parser (Src) import qualified Data.Text.IO as Text.IO@@ -17,6 +18,7 @@ import qualified Dhall.Import import qualified Dhall.Parser import qualified Dhall.TypeCheck+import qualified System.FilePath as FilePath -- | Read the file fileName and return the normalized Dhall AST fileToDhall :: String -> IO (Core.Expr Src Void)@@ -35,9 +37,15 @@ -- by the parser for generating error messages. textToDhall :: String -> Text -> IO (Core.Expr Src Void) textToDhall fileName text = do- parsedExpression <-+ parsedExpression <- do Core.throws (Dhall.Parser.exprFromText fileName text)- resolvedExpression <- Dhall.Import.load parsedExpression++ let directory = FilePath.takeDirectory fileName++ resolvedExpression <- do+ Dhall.Import.loadRelativeTo directory UseSemanticCache parsedExpression+ _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)+ return resolvedExpression
src/Dhall/TomlToDhall.hs view
@@ -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,@@ -118,35 +121,34 @@ , CompileError ) where -import Control.Exception (Exception, throwIO)+import Control.Exception (Exception(..))+import Data.Bifunctor (first) import Data.Either (rights)-import Data.Foldable (foldl', toList)+import Data.Foldable (fold, toList)+import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Text (Text) import Data.Version (showVersion) import Data.Void (Void) import Dhall.Core (DhallDouble (..), Expr) import Dhall.Parser (Src) import Dhall.Toml.Utils (fileToDhall) import Toml.Parser (TomlParseError)-import Toml.Type.AnyValue (AnyValue (AnyValue))-import Toml.Type.Key (Key (Key), Piece (Piece))-import Toml.Type.PrefixTree (PrefixTree)+import Toml.Type.AnyValue (AnyValue(..))+import Toml.Type.Key (Key(..), Piece(..))+import Toml.Type.PrefixTree (PrefixMap, PrefixTree(..)) import Toml.Type.TOML (TOML) import Toml.Type.Value (Value) import qualified Data.HashMap.Strict as HashMap import qualified Data.Sequence as Seq-import qualified Data.Text+import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Core as Core import qualified Dhall.Map as Map-import qualified Options.Applicative as OA+import qualified Options.Applicative as Options import qualified Paths_dhall_toml as Meta import qualified Toml.Parser-import qualified Toml.Type.AnyValue as Toml.AnyValue-import qualified Toml.Type.PrefixTree as Toml.PrefixTree-import qualified Toml.Type.TOML as Toml.TOML+import qualified Toml.Type.TOML as TOML import qualified Toml.Type.Value as Value data CompileError@@ -155,189 +157,255 @@ | InvalidToml TomlParseError | InternalError String | MissingKey String--instance Show CompileError where- show (Unimplemented s) = "unimplemented: " ++ s- show (Incompatible e toml) = "incompatible: " ++ (show e) ++ " with " ++ (show toml)- show (InvalidToml e) = "invalid TOML:\n" ++ (Data.Text.unpack $ Toml.Parser.unTomlParseError e)- show (InternalError e) = "internal error: " ++ show e- show (MissingKey e) = "missing key: " ++ show e+ deriving (Show) -instance Exception CompileError+instance Exception CompileError where+ displayException exception = case exception of+ Unimplemented s ->+ "unimplemented: " <> s+ Incompatible e toml ->+ "incompatible: " <> show e <> " with " <> show toml+ InvalidToml e ->+ "invalid TOML:\n" <> Text.unpack (Toml.Parser.unTomlParseError e)+ InternalError e ->+ "internal error: " <> show e+ MissingKey e ->+ "missing key: " <> show e tomlToDhall :: Expr Src Void -> TOML -> Either CompileError (Expr Src Void)-tomlToDhall schema toml = toDhall (Core.normalize schema) (tomlToObject toml)+tomlToDhall schema toml = objectToDhall (Core.normalize schema) (tomlToObject toml) -tomlValueToDhall :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void)-tomlValueToDhall exprType v = case (exprType, v) of- (Core.Bool , Value.Bool a ) -> Right $ Core.BoolLit a- (Core.Integer , Value.Integer a) -> Right $ Core.IntegerLit a- (Core.Natural , Value.Integer a) -> Right $ Core.NaturalLit $ fromInteger a- (Core.Double , Value.Double a ) -> Right $ Core.DoubleLit $ DhallDouble a- (Core.Text , Value.Text a ) -> Right $ Core.TextLit $ Core.Chunks [] a- (_ , Value.Zoned _ ) -> Left $ Unimplemented "toml time values"- (_ , Value.Local _ ) -> Left $ Unimplemented "toml time values"- (_ , Value.Day _ ) -> Left $ Unimplemented "toml time values"- (t@(Core.App Core.List _) , Value.Array [] ) -> Right $ Core.ListLit (Just t) []- (Core.App Core.Optional t , a ) -> do- o <- tomlValueToDhall t a- return $ Core.Some o- (Core.App Core.List t , Value.Array a ) -> do- l <- mapM (tomlValueToDhall t) a- return $ Core.ListLit Nothing (Seq.fromList l)+valueToDhall+ :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void)+valueToDhall type_ value = case (type_, value) of+ (Core.Bool, Value.Bool a) ->+ Right (Core.BoolLit a) + (Core.Integer, Value.Integer a) ->+ Right (Core.IntegerLit a)++ (Core.Natural, Value.Integer a) ->+ Right (Core.NaturalLit (fromInteger a))++ (Core.Double, Value.Double a) ->+ Right (Core.DoubleLit (DhallDouble a))++ (Core.Text, Value.Text a) ->+ Right (Core.TextLit (Core.Chunks [] a))++ (_, Value.Zoned _) ->+ Left (Unimplemented "toml time values")++ (_, Value.Local _) ->+ Left (Unimplemented "toml time values")++ (_, Value.Day _) ->+ Left (Unimplemented "toml time values")++ (Core.App Core.List _, Value.Array [] ) ->+ Right (Core.ListLit (Just type_) [])++ (Core.App Core.Optional t, a) -> do+ o <- valueToDhall t a+ return (Core.Some o)++ (Core.App Core.List elementType, Value.Array elements) -> do+ expressions <- mapM (valueToDhall elementType) elements+ return (Core.ListLit Nothing (Seq.fromList expressions))+ -- TODO: allow different types of matching (ex. first, strict, none) -- currently we just pick the first enum that matches- (Core.Union m , _) -> let- f key maybeType = case maybeType of- Just ty -> do- expr <- tomlValueToDhall ty v- return $ Core.App (Core.Field exprType $ Core.makeFieldSelection key) expr- Nothing -> case v of- Value.Text a | a == key ->- return $ Core.Field exprType (Core.makeFieldSelection a)- _ -> Left $ Incompatible exprType (Prim (AnyValue v))+ (Core.Union m, _) -> do+ let f key maybeAlternativeType = case maybeAlternativeType of+ Just alternativeType -> do+ expression <- valueToDhall alternativeType value+ return (Core.App (Core.Field type_ (Core.makeFieldSelection key)) expression)+ Nothing -> case value of+ Value.Text a | a == key ->+ return (Core.Field type_ (Core.makeFieldSelection a))+ _ -> Left (Incompatible type_ (Prim (AnyValue value))) - in case rights (toList (Map.mapWithKey f m)) of- [] -> Left $ Incompatible exprType (Prim (AnyValue v))- x:_ -> Right $ x+ case rights (toList (Map.mapWithKey f m)) of+ [] -> Left (Incompatible type_ (Prim (AnyValue value)))+ x : _ -> Right x - _ -> Left $ Incompatible exprType (Prim (AnyValue v))+ _ ->+ Left (Incompatible type_ (Prim (AnyValue value))) -- TODO: keep track of the path for more helpful error messages-toDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)-toDhall exprType value = case (exprType, value) of- (_, Invalid) -> Left $ InternalError "invalid object"+objectToDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)+objectToDhall type_ object = case (type_, object) of+ (_, Invalid) -> Left (InternalError "invalid object") -- TODO: allow different types of matching (ex. first, strict, none) -- currently we just pick the first enum that matches- (Core.Union m , _) -> let- f key maybeType = case maybeType of- Just ty -> do- expr <- toDhall ty value- return $ Core.App (Core.Field exprType $ Core.makeFieldSelection key) expr- Nothing -> case value of- Prim (AnyValue (Value.Text a)) | a == key ->- return $ Core.Field exprType (Core.makeFieldSelection a)- _ -> Left $ Incompatible exprType value+ (Core.Union m, _) -> do+ let f key maybeAlternativeType = case maybeAlternativeType of+ Just alternativeType -> do+ expression <- objectToDhall alternativeType object+ return (Core.App (Core.Field type_ (Core.makeFieldSelection key)) expression)+ Nothing -> case object of+ Prim (AnyValue (Value.Text a)) | a == key ->+ return (Core.Field type_ (Core.makeFieldSelection a))+ _ -> Left (Incompatible type_ object) - in case rights (toList (Map.mapWithKey f m)) of- [] -> Left $ Incompatible exprType value- x:_ -> Right $ x+ case rights (toList (Map.mapWithKey f m)) of+ [] -> Left (Incompatible type_ object)+ x : _ -> Right x - (Core.App Core.List t, Array []) -> Right $ Core.ListLit (Just t) []+ (Core.Record record, Table table) -> do+ let process key fieldType+ | Just nestedObject <- HashMap.lookup (Piece key) table =+ objectToDhall fieldType nestedObject+ | Core.App Core.Optional innerType <- fieldType =+ Right (Core.App Core.None innerType)+ | Core.App Core.List _ <- fieldType =+ Right (Core.ListLit (Just fieldType) [])+ | otherwise =+ Left (MissingKey (Text.unpack key)) - (Core.App Core.List t, Array a) -> do- l <- mapM (toDhall t) a- return $ Core.ListLit Nothing (Seq.fromList l)+ expressions <- Map.traverseWithKey process (fmap Core.recordFieldValue record) - (Core.Record r, Table t) -> let- f :: Text -> (Expr Src Void) -> Either CompileError (Expr Src Void)- f k ty | Just val <- HashMap.lookup (Piece k) t = toDhall ty val- | Core.App Core.Optional ty' <- ty = Right $ (Core.App Core.None ty')- | Core.App Core.List _ <- ty = Right $ Core.ListLit (Just ty) []- | otherwise = Left $ MissingKey $ Data.Text.unpack k- in do- values <- Map.traverseWithKey f (Core.recordFieldValue <$> r)- return $ Core.RecordLit (Core.makeRecordField <$> values)+ return (Core.RecordLit (fmap Core.makeRecordField expressions)) - (_, Prim (AnyValue v)) -> tomlValueToDhall exprType v+ (Core.App Core.List (Core.Record [("mapKey", Core.recordFieldValue -> Core.Text), ("mapValue", Core.recordFieldValue -> valueType)]), Table table) -> do+ hashMap <- traverse (objectToDhall valueType) table - (ty, obj) -> Left $ Incompatible ty obj+ 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++ (_, obj) ->+ Left (Incompatible type_ obj)+ -- | An intermediate object created from a 'TOML' before an 'Expr'. -- It does two things, firstly joining the tomlPairs, tomlTables, -- and tomlTableArrays parts of the TOML. Second, it turns the dense -- paths (ex. a.b.c = 1) into sparse paths (ex. a = { b = { c = 1 }}). data Object- = Prim Toml.AnyValue.AnyValue+ = Prim AnyValue | Array [Object]- | Table (HashMap.HashMap Piece Object)+ | Table (HashMap Piece Object) | Invalid deriving (Show) instance Semigroup Object where- (Table ls) <> (Table rs) = Table (ls <> rs)+ Table ls <> Table rs = Table (ls <> rs) -- this shouldn't happen because tomland has already verified correctness -- of the toml object _ <> _ = Invalid +instance Monoid Object where+ mempty = Table HashMap.empty+ -- | Creates an arbitrarily nested object sparseObject :: Key -> Object -> Object-sparseObject (Key (piece :| [])) value = Table $ HashMap.singleton piece value-sparseObject (Key (piece :| rest:rest')) value- = Table $ HashMap.singleton piece (sparseObject (Key $ rest :| rest') value)--pairsToObject :: HashMap.HashMap Key Toml.AnyValue.AnyValue -> Object-pairsToObject pairs- = foldl' (<>) (Table HashMap.empty)- $ HashMap.mapWithKey sparseObject- $ fmap Prim pairs+sparseObject (Key (piece :| [])) value =+ Table (HashMap.singleton piece value)+sparseObject (Key (piece :| piece' : pieces)) value =+ Table (HashMap.singleton piece (sparseObject (Key (piece' :| pieces)) value)) -tablesToObject :: Toml.PrefixTree.PrefixMap TOML -> Object-tablesToObject tables- = foldl' (<>) (Table HashMap.empty)- $ map prefixTreeToObject- $ HashMap.elems tables+tablesToObject :: PrefixMap TOML -> Object+tablesToObject = fold . map prefixTreeToObject . HashMap.elems prefixTreeToObject :: PrefixTree TOML -> Object-prefixTreeToObject (Toml.PrefixTree.Leaf key toml)- = sparseObject key (tomlToObject toml)-prefixTreeToObject (Toml.PrefixTree.Branch prefix _ toml)- = sparseObject prefix (tablesToObject toml)--tableArraysToObject :: HashMap.HashMap Key (NonEmpty TOML) -> Object-tableArraysToObject arrays- = foldl' (<>) (Table HashMap.empty)- $ HashMap.mapWithKey sparseObject- $ fmap (Array . fmap tomlToObject . toList) arrays+prefixTreeToObject (Leaf key toml) =+ sparseObject key (tomlToObject toml)+prefixTreeToObject (Branch prefix _ toml) =+ sparseObject prefix (tablesToObject toml) tomlToObject :: TOML -> Object-tomlToObject toml = pairs <> tables <> tableArrays- where- pairs = pairsToObject $ Toml.TOML.tomlPairs toml- tables = tablesToObject $ Toml.TOML.tomlTables toml- tableArrays = tableArraysToObject $ Toml.TOML.tomlTableArrays toml+tomlToObject = pairs <> tables <> tableArrays+ where+ pairs =+ fold+ . HashMap.mapWithKey sparseObject+ . fmap Prim+ . TOML.tomlPairs + tables =+ fold+ . map prefixTreeToObject+ . HashMap.elems+ . TOML.tomlTables++ tableArrays =+ fold+ . HashMap.mapWithKey sparseObject+ . fmap (Array . fmap tomlToObject . toList)+ . TOML.tomlTableArrays+ data Options = Options { input :: Maybe FilePath , output :: Maybe FilePath , schemaFile :: FilePath } -parserInfo :: OA.ParserInfo Options-parserInfo = OA.info- (OA.helper <*> versionOption <*> optionsParser)- (OA.fullDesc <> OA.progDesc "Convert TOML to Dhall")+parserInfo :: Options.ParserInfo Options+parserInfo = Options.info+ (Options.helper <*> versionOption <*> optionsParser)+ (Options.fullDesc <> Options.progDesc "Convert TOML to Dhall") where- versionOption = OA.infoOption (showVersion Meta.version) $- OA.long "version" <> OA.help "Display version"+ versionOption =+ Options.infoOption (showVersion Meta.version)+ (Options.long "version" <> Options.help "Display version")+ optionsParser = do- input <- OA.optional . OA.strOption $- OA.long "file"- <> OA.help "Read TOML from file instead of standard input"- <> fileOpts- output <- OA.optional . OA.strOption $- OA.long "output"- <> OA.help "Write Dhall to a file instead of standard output"- <> fileOpts- schemaFile <- OA.strArgument $- OA.help "Path to Dhall schema file"- <> OA.action "file"- <> OA.metavar "SCHEMA"+ input <- (Options.optional . Options.strOption)+ ( Options.long "file"+ <> Options.help "Read TOML from file instead of standard input"+ <> Options.metavar "FILE"+ <> Options.action "file"+ )+ output <- (Options.optional . Options.strOption)+ ( Options.long "output"+ <> Options.help "Write Dhall to a file instead of standard output"+ <> Options.metavar "FILE"+ <> Options.action "file"+ )+ schemaFile <- Options.strArgument+ ( Options.help "Path to Dhall schema file"+ <> Options.action "file"+ <> Options.metavar "SCHEMA"+ ) pure Options {..}- fileOpts = OA.metavar "FILE" <> OA.action "file" tomlToDhallMain :: IO () tomlToDhallMain = do- Options {..} <- OA.execParser parserInfo- text <- maybe Text.IO.getContents Text.IO.readFile input- toml <- case Toml.Parser.parse text of- Left tomlErr -> throwIO (InvalidToml tomlErr)- Right toml -> return toml+ Options{..} <- Options.execParser parserInfo++ inputText <- case input of+ Just file -> Text.IO.readFile file+ Nothing -> Text.IO.getContents++ toml <- Core.throws (first InvalidToml (Toml.Parser.parse inputText))+ schema <- fileToDhall schemaFile- dhall <- case tomlToDhall schema toml of- Left err -> throwIO err- Right dhall -> return dhall- maybe Text.IO.putStrLn Text.IO.writeFile output $ Core.pretty dhall++ dhall <- Core.throws (tomlToDhall schema toml)++ let outputText = Core.pretty dhall++ case output of+ Just file -> Text.IO.writeFile file outputText+ Nothing -> Text.IO.putStrLn outputText
tasty/Main.hs view
@@ -46,6 +46,9 @@ , "./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 @@ , "./tasty/data/union-empty" , "./tasty/data/union-typed" , "./tasty/data/optional"+ , "./tasty/data/map-simple"+ , "./tasty/data/map-empty" ] testDhallToToml :: String -> TestTree
+ tasty/data/map-complex-schema.dhall view
@@ -0,0 +1,1 @@+{ foo : List { mapKey : Text, mapValue : { baz : Natural } } }
+ tasty/data/map-complex.dhall view
@@ -0,0 +1,1 @@+{ foo = [ { mapValue = { baz = 1 }, mapKey = "bar" } ] }
+ tasty/data/map-complex.toml view
@@ -0,0 +1,2 @@+[foo.bar]+ baz = 1
+ tasty/data/map-empty-schema.dhall view
@@ -0,0 +1,1 @@+List { mapKey : Text, mapValue : Natural }
+ tasty/data/map-empty.dhall view
@@ -0,0 +1,1 @@+[] : List { mapKey : Text, mapValue : Natural }
+ tasty/data/map-empty.toml view
+ tasty/data/map-simple-schema.dhall view
@@ -0,0 +1,1 @@+List { mapKey : Text, mapValue : Natural }
+ tasty/data/map-simple.dhall view
@@ -0,0 +1,1 @@+[ { mapKey = "foo", mapValue = 1 } ]
+ tasty/data/map-simple.toml view
@@ -0,0 +1,1 @@+foo = 1