From c5cf095f7701810ae412dbdf61c9e5be1a7b00fa Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Tue, 21 Nov 2023 06:24:34 -0800 Subject: [PATCH] Refactor `dhall-toml` code This is a (mostly) behavior-preserving refactor of the `dhall-toml` package since I was planning on working on #2509 and wanted to first refactor the code a bit more to my liking. The only actual change is that the `Show` instance for `CompilerError` is now the derived one and I moved that logic to the `displayException` method. --- dhall-toml/src/Dhall/DhallToToml.hs | 323 +++++++++++++++----------- dhall-toml/src/Dhall/TomlToDhall.hs | 346 ++++++++++++++++------------ 2 files changed, 381 insertions(+), 288 deletions(-) diff --git a/dhall-toml/src/Dhall/DhallToToml.hs b/dhall-toml/src/Dhall/DhallToToml.hs index 2b248e527..12ae146a6 100644 --- a/dhall-toml/src/Dhall/DhallToToml.hs +++ b/dhall-toml/src/Dhall/DhallToToml.hs @@ -103,7 +103,7 @@ module Dhall.DhallToToml , 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 +111,14 @@ import Data.Text (Text) 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 +126,13 @@ import qualified Dhall.Core as Core 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 +228,15 @@ insert = Text.unpack . Pretty.renderStrict . Dhall.Pretty.layout . Dhall.Util.in >>> 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 +245,201 @@ pattern UnionEmpty x <- Core.Field (Core.Union _) (Core.FieldSelection _ x _) 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 + :: 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 -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' - - - -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 +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)) + + 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.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 - - -- 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 - - rightAny = Right . Toml.AnyValue.AnyValue - - -- 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 + 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 + + -- 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) + _ -> + Left (Unsupported expr) + where + key :: Key + key = Key (NonEmpty.reverse pieces) + + 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/dhall-toml/src/Dhall/TomlToDhall.hs b/dhall-toml/src/Dhall/TomlToDhall.hs index d189b7ab9..c545b3446 100644 --- a/dhall-toml/src/Dhall/TomlToDhall.hs +++ b/dhall-toml/src/Dhall/TomlToDhall.hs @@ -118,35 +118,34 @@ module Dhall.TomlToDhall , 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,150 +154,186 @@ data CompileError | InvalidToml TomlParseError | InternalError String | MissingKey String + deriving (Show) -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 - -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) - -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) +tomlToDhall schema toml = objectToDhall (Core.normalize schema) (tomlToObject toml) - -- 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)) - - in case rights (toList (Map.mapWithKey f m)) of - [] -> Left $ Incompatible exprType (Prim (AnyValue v)) - x:_ -> Right $ x - - _ -> Left $ Incompatible exprType (Prim (AnyValue v)) +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) --- 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" + (Core.Integer, Value.Integer a) -> + Right (Core.IntegerLit a) - -- 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.Natural, Value.Integer a) -> + Right (Core.NaturalLit (fromInteger a)) - in case rights (toList (Map.mapWithKey f m)) of - [] -> Left $ Incompatible exprType value - x:_ -> Right $ x + (Core.Double, Value.Double a) -> + Right (Core.DoubleLit (DhallDouble a)) - (Core.App Core.List t, Array []) -> Right $ Core.ListLit (Just t) [] + (Core.Text, Value.Text a) -> + Right (Core.TextLit (Core.Chunks [] a)) - (Core.App Core.List t, Array a) -> do - l <- mapM (toDhall t) a - return $ Core.ListLit Nothing (Seq.fromList l) + (_, Value.Zoned _) -> + Left (Unimplemented "toml time values") - (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) + (_, Value.Local _) -> + Left (Unimplemented "toml time values") - (_, Prim (AnyValue v)) -> tomlValueToDhall exprType v + (_, Value.Day _) -> + Left (Unimplemented "toml time values") - (ty, obj) -> Left $ Incompatible ty obj + (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, _) -> 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))) + + case rights (toList (Map.mapWithKey f m)) of + [] -> Left (Incompatible type_ (Prim (AnyValue value))) + x : _ -> Right x + + _ -> + Left (Incompatible type_ (Prim (AnyValue value))) + +-- TODO: keep track of the path for more helpful error messages +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, _) -> 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) + + 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.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 = + 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)) + + expressions <- Map.traverseWithKey process (fmap Core.recordFieldValue record) + + return (Core.RecordLit (fmap Core.makeRecordField 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 - -tablesToObject :: Toml.PrefixTree.PrefixMap TOML -> Object -tablesToObject tables - = foldl' (<>) (Table HashMap.empty) - $ map prefixTreeToObject - $ HashMap.elems tables +sparseObject (Key (piece :| [])) value = + Table (HashMap.singleton piece value) +sparseObject (Key (piece :| piece' : pieces)) value = + Table (HashMap.singleton piece (sparseObject (Key (piece' :| pieces)) value)) -prefixTreeToObject :: PrefixTree TOML -> Object -prefixTreeToObject (Toml.PrefixTree.Leaf key toml) - = sparseObject key (tomlToObject toml) -prefixTreeToObject (Toml.PrefixTree.Branch prefix _ toml) - = sparseObject prefix (tablesToObject toml) +tablesToObject :: PrefixMap TOML -> Object +tablesToObject = fold . map prefixTreeToObject . HashMap.elems -tableArraysToObject :: HashMap.HashMap Key (NonEmpty TOML) -> Object -tableArraysToObject arrays - = foldl' (<>) (Table HashMap.empty) - $ HashMap.mapWithKey sparseObject - $ fmap (Array . fmap tomlToObject . toList) arrays +prefixTreeToObject :: PrefixTree TOML -> Object +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 @@ -306,38 +341,51 @@ data Options = Options , 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