Skip to content

Commit c8fbc37

Browse files
Gabriella439Gabriella439
authored
Refactor dhall-toml code (#2548)
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.
1 parent e8c8790 commit c8fbc37

File tree

2 files changed

+381
-288
lines changed

2 files changed

+381
-288
lines changed

‎dhall-toml/src/Dhall/DhallToToml.hs

Lines changed: 184 additions & 139 deletions
Original file line numberDiff line numberDiff line change
@@ -103,34 +103,36 @@ module Dhall.DhallToToml
103103
, CompileError
104104
) where
105105

106-
import Control.Exception (Exception, throwIO)
106+
import Control.Exception (Exception)
107107
import Control.Monad (foldM)
108108
import Data.Foldable (toList)
109109
import Data.List.NonEmpty (NonEmpty ((:|)))
110110
import Data.Text (Text)
111111
import Data.Version (showVersion)
112112
import Data.Void (Void)
113113
import Dhall.Core (DhallDouble (..), Expr)
114+
import Dhall.Map (Map)
114115
import Dhall.Toml.Utils (fileToDhall, inputToDhall)
115116
import Prettyprinter (Pretty)
116-
import Toml.Type.Key (Key (Key, unKey), Piece (Piece))
117-
import Toml.Type.Printer (pretty)
117+
import Toml.Type.Key (Key(..), Piece (Piece))
118+
import Toml.Type.AnyValue (AnyValue(..))
118119
import Toml.Type.TOML (TOML)
119120

120-
import qualified Data.Bifunctor as Bifunctor
121+
import qualified Data.List.NonEmpty as NonEmpty
121122
import qualified Data.Sequence as Seq
122123
import qualified Data.Text as Text
123124
import qualified Data.Text.IO as Text.IO
124125
import qualified Dhall.Core as Core
125126
import qualified Dhall.Map as Map
126127
import qualified Dhall.Pretty
127128
import qualified Dhall.Util
128-
import qualified Options.Applicative as OA
129+
import qualified Options.Applicative as Options
129130
import qualified Paths_dhall_toml as Meta
130131
import qualified Prettyprinter.Render.Text as Pretty
131-
import qualified Toml.Type.AnyValue as Toml.AnyValue
132-
import qualified Toml.Type.TOML as Toml.TOML
133-
import qualified Toml.Type.Value as Toml.Value
132+
import qualified Toml.Type.AnyValue as AnyValue
133+
import qualified Toml.Type.Printer as Printer
134+
import qualified Toml.Type.TOML as TOML
135+
import qualified Toml.Type.Value as Value
134136

135137
-- $setup
136138
--
@@ -226,15 +228,15 @@ insert = Text.unpack . Pretty.renderStrict . Dhall.Pretty.layout . Dhall.Util.in
226228
>>> import Toml.Type.Printer
227229
>>> f = makeRecordField
228230
>>> let toml = dhallToToml $ RecordLit [("foo", f $ NaturalLit 1), ("bar", f $ TextLit "ABC")]
229-
>>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Toml.Value.Integer 1)),("bar",AnyValue (Toml.Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []})
231+
>>> toml == Right (TOML {tomlPairs = HashMap.fromList [("foo",AnyValue (Value.Integer 1)),("bar",AnyValue (Value.Text "ABC"))], tomlTables = HashMap.fromList [], tomlTableArrays = HashMap.fromList []})
230232
True
231233
>>> fmap Toml.Type.Printer.pretty toml
232234
Right "bar = \"ABC\"\nfoo = 1\n"
233235
-}
234236
dhallToToml :: Expr s Void -> Either CompileError TOML
235-
dhallToToml e0 = do
236-
r <- assertRecordLit (Core.normalize e0)
237-
toTomlTable r
237+
dhallToToml expression = do
238+
record <- assertRecordLit (Core.normalize expression)
239+
toTomlTable record
238240

239241
-- empty union alternative like < A | B >.A
240242
pattern UnionEmpty :: Text -> Expr s a
@@ -243,158 +245,201 @@ pattern UnionEmpty x <- Core.Field (Core.Union _) (Core.FieldSelection _ x _)
243245
pattern UnionApp :: Expr s a -> Expr s a
244246
pattern UnionApp x <- Core.App (Core.Field (Core.Union _) _) x
245247

246-
assertRecordLit :: Expr Void Void -> Either CompileError (Map.Map Text (Core.RecordField Void Void))
248+
assertRecordLit
249+
:: Expr Void Void
250+
-> Either CompileError (Map Text (Core.RecordField Void Void))
247251
assertRecordLit (Core.RecordLit r) = Right r
248252
assertRecordLit (UnionApp x) = assertRecordLit x
249253
assertRecordLit e = Left $ NotARecord e
250254

251-
toTomlTable :: Map.Map Text (Core.RecordField Void Void) -> Either CompileError TOML
255+
toTomlTable :: Map Text (Core.RecordField Void Void) -> Either CompileError TOML
252256
toTomlTable r = foldM (toTomlRecordFold []) (mempty :: TOML) (Map.toList r)
253257

254-
toTomlRecordFold :: [Piece] -> TOML -> (Text, Core.RecordField Void Void) -> Either CompileError TOML
255-
toTomlRecordFold curKey toml' (key', val) = toToml toml' newKey (Core.recordFieldValue val)
256-
where
257-
append :: [Piece] -> Piece -> NonEmpty Piece
258-
append [] y = y :| []
259-
append (x:xs) y = x :| xs ++ [y]
260-
newKey = Key $ append curKey $ Piece key'
261-
262-
263-
264-
toToml :: TOML -> Key -> Expr Void Void -> Either CompileError TOML
265-
toToml toml key expr = case expr of
266-
Core.BoolLit a -> return $ insertPrim (Toml.Value.Bool a)
267-
Core.NaturalLit a -> return $ insertPrim (Toml.Value.Integer $ toInteger a)
268-
Core.IntegerLit a -> return $ insertPrim (Toml.Value.Integer a)
269-
Core.DoubleLit (DhallDouble a) -> return $ insertPrim (Toml.Value.Double a)
270-
Core.TextLit (Core.Chunks [] a) -> return $ insertPrim (Toml.Value.Text a)
271-
Core.App Core.None _ -> return toml
272-
Core.Some a -> toToml toml key a
273-
UnionEmpty a -> return $ insertPrim (Toml.Value.Text a)
274-
UnionApp a -> toToml toml key a
258+
toTomlRecordFold
259+
:: [Piece]
260+
-> TOML
261+
-> (Text, Core.RecordField Void Void)
262+
-> Either CompileError TOML
263+
toTomlRecordFold curKey toml (key, val) =
264+
toToml toml (Piece key :| curKey) (Core.recordFieldValue val)
265+
266+
toToml :: TOML -> NonEmpty Piece -> Expr Void Void -> Either CompileError TOML
267+
toToml toml pieces expr = case expr of
268+
Core.BoolLit a ->
269+
insertPrim (Value.Bool a)
270+
271+
Core.NaturalLit a ->
272+
insertPrim (Value.Integer (toInteger a))
273+
274+
Core.IntegerLit a ->
275+
insertPrim (Value.Integer a)
276+
277+
Core.DoubleLit (DhallDouble a) ->
278+
insertPrim (Value.Double a)
279+
280+
Core.TextLit (Core.Chunks [] a) ->
281+
insertPrim (Value.Text a)
282+
283+
UnionEmpty a ->
284+
insertPrim (Value.Text a)
285+
286+
UnionApp a ->
287+
toToml toml pieces a
288+
289+
Core.Some a ->
290+
toToml toml pieces a
291+
292+
Core.App Core.None _ ->
293+
return toml
294+
275295
Core.ListLit _ a -> case toList a of
276-
-- empty array
277-
[] -> return $ insertPrim (Toml.Value.Array [])
278296
-- TODO: unions need to be handled here as well, it's a bit tricky
279297
-- because they also have to be probed for being a "simple"
280298
-- array of table
281299
union@(UnionApp (Core.RecordLit _)) : unions -> do
282-
tables' <- case mapM assertRecordLit (union :| unions) of
283-
Right x -> mapM toTomlTable x
284-
Left (NotARecord e) -> Left (HeterogeneousArray e)
285-
Left x -> Left x
286-
return $ Toml.TOML.insertTableArrays key tables' toml
300+
insertTables (union :| unions)
287301

288302
record@(Core.RecordLit _) : records -> do
289-
tables' <- case mapM assertRecordLit (record :| records) of
290-
Right x -> mapM toTomlTable x
291-
Left (NotARecord e) -> Left (HeterogeneousArray e)
292-
Left x -> Left x
293-
return $ Toml.TOML.insertTableArrays key tables' toml
303+
insertTables (record :| records)
304+
294305
-- inline array
295-
a' -> do
296-
anyList <- mapM toAny a'
297-
let arrayEither = Toml.AnyValue.toMArray anyList
298-
array <- Bifunctor.first (const $ HeterogeneousArray expr) arrayEither
299-
return $ insertPrim array
300-
Core.RecordLit r ->
301-
let
302-
(inline, nested) = Map.partition (isInline . Core.recordFieldValue) r
303-
in
304-
if null inline
305-
-- if the table doesn't have inline elements, don't register
306-
-- the table, only its non-inlined children. Ex:
307-
-- [a] # bad
308-
-- [b]
309-
-- c = 1
310-
-- [a.b] # good
311-
-- c = 1
312-
then foldM (toTomlRecordFold $ toList $ unKey key) toml (Map.toList nested)
313-
else do
314-
-- the order here is important, at least for testing, because
315-
-- the PrefixMap inside TOML is dependent on insert order
316-
inlinePairs <- foldM (toTomlRecordFold []) mempty (Map.toList inline)
317-
nestedPairs <- foldM (toTomlRecordFold []) inlinePairs (Map.toList nested)
318-
return $ Toml.TOML.insertTable key nestedPairs toml
319-
_ -> Left $ Unsupported expr
320-
where
321-
insertPrim :: Toml.Value.Value a -> TOML
322-
insertPrim val = Toml.TOML.insertKeyVal key val toml
323-
324-
-- checks if the value should be represented as an inline key/value
325-
-- pair. Elements that are inlined are those that do not have a
326-
-- [header] or [[header]]. One edge case is tables within multiple
327-
-- arrays, though not currently supported by tomland, can only
328-
-- be represented as inline tables.
329-
isInline v = case v of
330-
Core.BoolLit _ -> True
331-
Core.IntegerLit _ -> True
332-
Core.NaturalLit _ -> True
333-
Core.DoubleLit _ -> True
334-
Core.TextLit _ -> True
335-
Core.ListLit _ s -> case Seq.lookup 0 s of
336-
Nothing -> True
337-
Just (Core.BoolLit _) -> True
338-
Just (Core.NaturalLit _) -> True
339-
Just (Core.DoubleLit _) -> True
340-
Just (Core.TextLit _) -> True
341-
Just (Core.ListLit _ _) -> True
342-
_ -> False
343-
_ -> False
344-
345-
rightAny = Right . Toml.AnyValue.AnyValue
346-
347-
-- toAny is a helper function for making lists so it returns a list
348-
-- specific error, in particular tomland's inability to represent
349-
-- tables in multi-dimensional arrays
350-
toAny :: Expr Void Void -> Either CompileError Toml.AnyValue.AnyValue
351-
toAny e = case e of
352-
Core.BoolLit x -> rightAny $ Toml.Value.Bool x
353-
Core.IntegerLit x -> rightAny $ Toml.Value.Integer x
354-
Core.NaturalLit x -> rightAny $ Toml.Value.Integer $ toInteger x
355-
Core.DoubleLit (DhallDouble x) -> rightAny $ Toml.Value.Double x
356-
Core.TextLit (Core.Chunks [] x) -> rightAny $ Toml.Value.Text x
357-
UnionEmpty x -> rightAny $ Toml.Value.Text x
358-
UnionApp x -> toAny x
359-
Core.ListLit _ x -> do
360-
anyList <- mapM toAny $ toList x
361-
case Toml.AnyValue.toMArray anyList of
362-
Right x' -> rightAny x'
363-
Left _ -> Left $ HeterogeneousArray expr
364-
Core.RecordLit _ -> Left $ UnsupportedArray e
365-
_ -> Left $ Unsupported e
306+
expressions -> do
307+
anyValues <- mapM toAnyValue expressions
308+
309+
case AnyValue.toMArray anyValues of
310+
Left _ -> Left (HeterogeneousArray expr)
311+
Right array -> insertPrim array
312+
313+
Core.RecordLit r -> do
314+
let (inline, nested) =
315+
Map.partition (isInline . Core.recordFieldValue) r
316+
317+
-- the order here is important, at least for testing, because the
318+
-- PrefixMap inside TOML is dependent on insert order
319+
let pairs = Map.toList inline <> Map.toList nested
320+
321+
if null inline
322+
-- if the table doesn't have inline elements, don't register the table,
323+
-- only its non-inlined children. Ex:
324+
-- [a] # bad
325+
-- [b]
326+
-- c = 1
327+
-- [a.b] # good
328+
-- c = 1
329+
then do
330+
foldM (toTomlRecordFold (toList pieces)) toml pairs
331+
else do
332+
newPairs <- foldM (toTomlRecordFold []) mempty pairs
333+
return (TOML.insertTable key newPairs toml)
334+
_ ->
335+
Left (Unsupported expr)
336+
where
337+
key :: Key
338+
key = Key (NonEmpty.reverse pieces)
339+
340+
insertPrim :: Value.Value a -> Either CompileError TOML
341+
insertPrim val = return (TOML.insertKeyVal key val toml)
342+
343+
insertTables :: NonEmpty (Expr Void Void) -> Either CompileError TOML
344+
insertTables expressions = do
345+
tables <- case mapM assertRecordLit expressions of
346+
Right x -> mapM toTomlTable x
347+
Left (NotARecord e) -> Left (HeterogeneousArray e)
348+
Left x -> Left x
349+
return (TOML.insertTableArrays key tables toml)
350+
351+
-- checks if the value should be represented as an inline key/value pair.
352+
-- Elements that are inlined are those that do not have a [header] or
353+
-- [[header]]. One edge case is tables within multiple arrays, though not
354+
-- currently supported by tomland, can only be represented as inline tables.
355+
isInline v = case v of
356+
Core.BoolLit _ -> True
357+
Core.IntegerLit _ -> True
358+
Core.NaturalLit _ -> True
359+
Core.DoubleLit _ -> True
360+
Core.TextLit _ -> True
361+
Core.ListLit _ s -> case Seq.lookup 0 s of
362+
Nothing -> True
363+
Just (Core.BoolLit _) -> True
364+
Just (Core.NaturalLit _) -> True
365+
Just (Core.DoubleLit _) -> True
366+
Just (Core.TextLit _) -> True
367+
Just (Core.ListLit _ _) -> True
368+
_ -> False
369+
_ -> False
370+
371+
-- toAnyValue is a helper function for making lists so it returns a list
372+
-- specific error, in particular tomland's inability to represent tables in
373+
-- multi-dimensional arrays
374+
toAnyValue :: Expr Void Void -> Either CompileError AnyValue
375+
toAnyValue expression = case expression of
376+
Core.BoolLit x ->
377+
Right (AnyValue (Value.Bool x))
378+
Core.IntegerLit x ->
379+
Right (AnyValue (Value.Integer x))
380+
Core.NaturalLit x ->
381+
Right (AnyValue (Value.Integer (toInteger x)))
382+
Core.DoubleLit (DhallDouble x) ->
383+
Right (AnyValue (Value.Double x))
384+
Core.TextLit (Core.Chunks [] x) ->
385+
Right (AnyValue (Value.Text x))
386+
UnionEmpty x ->
387+
Right (AnyValue (Value.Text x))
388+
UnionApp x ->
389+
toAnyValue x
390+
Core.ListLit _ x -> do
391+
anyList <- mapM toAnyValue (toList x)
392+
case AnyValue.toMArray anyList of
393+
Right x' -> Right (AnyValue x')
394+
Left _ -> Left (HeterogeneousArray expr)
395+
Core.RecordLit _ ->
396+
Left (UnsupportedArray expression)
397+
_ ->
398+
Left (Unsupported expression)
366399

367400
data Options = Options
368401
{ input :: Maybe FilePath
369402
, output :: Maybe FilePath
370403
}
371404

372-
parserInfo :: OA.ParserInfo Options
373-
parserInfo = OA.info
374-
(OA.helper <*> versionOption <*> optionsParser)
375-
(OA.fullDesc <> OA.progDesc "Convert Dhall to TOML")
405+
parserInfo :: Options.ParserInfo Options
406+
parserInfo = Options.info
407+
(Options.helper <*> versionOption <*> optionsParser)
408+
(Options.fullDesc <> Options.progDesc "Convert Dhall to TOML")
376409
where
377-
versionOption = OA.infoOption (showVersion Meta.version) $
378-
OA.long "version" <> OA.help "Display version"
410+
versionOption =
411+
Options.infoOption (showVersion Meta.version)
412+
(Options.long "version" <> Options.help "Display version")
413+
379414
optionsParser = do
380-
input <- OA.optional . OA.strOption $
381-
OA.long "file"
382-
<> OA.help "Read Dhall from file instead of standard input"
383-
<> fileOpts
384-
output <- OA.optional . OA.strOption $
385-
OA.long "output"
386-
<> OA.help "Write TOML to a file instead of standard output"
387-
<> fileOpts
388-
pure Options {..}
389-
fileOpts = OA.metavar "FILE" <> OA.action "file"
415+
input <- (Options.optional . Options.strOption)
416+
( Options.long "file"
417+
<> Options.help "Read Dhall from file instead of standard input"
418+
<> Options.metavar "FILE"
419+
<> Options.action "file"
420+
)
421+
422+
output <- (Options.optional . Options.strOption)
423+
( Options.long "output"
424+
<> Options.help "Write TOML to a file instead of standard output"
425+
<> Options.metavar "FILE"
426+
<> Options.action "file"
427+
)
428+
429+
pure Options{..}
390430

391431
{-| Runs the @dhall-to-toml@ command
392432
-}
393433
dhallToTomlMain :: IO ()
394434
dhallToTomlMain = do
395-
Options {..} <- OA.execParser parserInfo
435+
Options{..} <- Options.execParser parserInfo
436+
396437
resolvedExpression <- maybe inputToDhall fileToDhall input
397-
toml <- case dhallToToml resolvedExpression of
398-
Left err -> throwIO err
399-
Right toml -> return toml
400-
maybe Text.IO.putStrLn Text.IO.writeFile output $ pretty toml
438+
439+
toml <- Core.throws (dhallToToml resolvedExpression)
440+
441+
let text = Printer.pretty toml
442+
443+
case output of
444+
Just file -> Text.IO.writeFile file text
445+
Nothing -> Text.IO.putStrLn text

0 commit comments

Comments
 (0)