diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/dhall-toml.cabal b/dhall-toml.cabal --- a/dhall-toml.cabal +++ b/dhall-toml.cabal @@ -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 diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -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 + ] diff --git a/src/Dhall/DhallToToml.hs b/src/Dhall/DhallToToml.hs --- a/src/Dhall/DhallToToml.hs +++ b/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 }' @@ -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 diff --git a/src/Dhall/Toml/Utils.hs b/src/Dhall/Toml/Utils.hs --- a/src/Dhall/Toml/Utils.hs +++ b/src/Dhall/Toml/Utils.hs @@ -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 diff --git a/src/Dhall/TomlToDhall.hs b/src/Dhall/TomlToDhall.hs --- a/src/Dhall/TomlToDhall.hs +++ b/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, @@ -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 diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -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 diff --git a/tasty/data/map-complex-schema.dhall b/tasty/data/map-complex-schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-complex-schema.dhall @@ -0,0 +1,1 @@ +{ foo : List { mapKey : Text, mapValue : { baz : Natural } } } diff --git a/tasty/data/map-complex.dhall b/tasty/data/map-complex.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-complex.dhall @@ -0,0 +1,1 @@ +{ foo = [ { mapValue = { baz = 1 }, mapKey = "bar" } ] } diff --git a/tasty/data/map-complex.toml b/tasty/data/map-complex.toml new file mode 100644 --- /dev/null +++ b/tasty/data/map-complex.toml @@ -0,0 +1,2 @@ +[foo.bar] + baz = 1 diff --git a/tasty/data/map-empty-schema.dhall b/tasty/data/map-empty-schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-empty-schema.dhall @@ -0,0 +1,1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/tasty/data/map-empty.dhall b/tasty/data/map-empty.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-empty.dhall @@ -0,0 +1,1 @@ +[] : List { mapKey : Text, mapValue : Natural } diff --git a/tasty/data/map-empty.toml b/tasty/data/map-empty.toml new file mode 100644 --- /dev/null +++ b/tasty/data/map-empty.toml diff --git a/tasty/data/map-simple-schema.dhall b/tasty/data/map-simple-schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-simple-schema.dhall @@ -0,0 +1,1 @@ +List { mapKey : Text, mapValue : Natural } diff --git a/tasty/data/map-simple.dhall b/tasty/data/map-simple.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/map-simple.dhall @@ -0,0 +1,1 @@ +[ { mapKey = "foo", mapValue = 1 } ] diff --git a/tasty/data/map-simple.toml b/tasty/data/map-simple.toml new file mode 100644 --- /dev/null +++ b/tasty/data/map-simple.toml @@ -0,0 +1,1 @@ +foo = 1