Commit ed12bb6d authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Improved dump output

parent eabfdfd7
{- |
Module : $Header$
Description : Environment containing the module's information
Copyright : (c) 2011 - 2013 Björn Peemöller
Copyright : (c) 2011 - 2015 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -57,14 +57,14 @@ initCompilerEnv mid = CompilerEnv
-- |Show the 'CompilerEnv'
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = show $ vcat
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Language Etensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors " $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
[ header "Module Identifier " $ textS $ moduleIdent env
, header "Language Extensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "Module Aliases " $ ppMap $ aliasEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
, header "Type Constructors " $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
]
where
header hdr content = hang (text hdr <+> colon) 4 content
......@@ -76,7 +76,8 @@ ppMap = ppAL . Map.toList
-- |Pretty print an association list
ppAL :: (Show a, Show b) => [(a, b)] -> Doc
ppAL xs = vcat $ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs
ppAL xs = vcat
$ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs
where showXs = map (\(a,b) -> (show a, show b)) xs
keyWidth = maximum (0 : map (length .fst) showXs)
pad s n = take n (s ++ repeat ' ')
......@@ -207,19 +207,19 @@ data DumpLevel
-- |Description and flag of dump levels
dumpLevel :: [(DumpLevel, String, String)]
dumpLevel = [ (DumpParsed , "dump-parse", "parse tree" )
, (DumpKindChecked , "dump-kc" , "kind checker output" )
, (DumpSyntaxChecked, "dump-sc" , "syntax checker output" )
, (DumpPrecChecked , "dump-pc" , "precedence checker output")
, (DumpTypeChecked , "dump-tc" , "type checker output" )
, (DumpExportChecked, "dump-ec" , "export checker output" )
, (DumpQualified , "dump-qual" , "qualifier output" )
, (DumpDesugared , "dump-ds" , "desugarer output" )
, (DumpSimplified , "dump-simpl", "simplifier output" )
, (DumpLifted , "dump-lift" , "lifting output" )
, (DumpTranslated , "dump-trans", "translated output" )
, (DumpCaseCompleted, "dump-cc" , "case completed output" )
, (DumpFlatCurry , "dump-flat" , "FlatCurry code" )
dumpLevel = [ (DumpParsed , "dump-parse", "parsing" )
, (DumpKindChecked , "dump-kc" , "kind checking" )
, (DumpSyntaxChecked, "dump-sc" , "syntax checking" )
, (DumpPrecChecked , "dump-pc" , "precedence checking" )
, (DumpTypeChecked , "dump-tc" , "type checking" )
, (DumpExportChecked, "dump-ec" , "export checking" )
, (DumpQualified , "dump-qual" , "qualification" )
, (DumpDesugared , "dump-ds" , "desugaring" )
, (DumpLifted , "dump-lift" , "lifting" )
, (DumpSimplified , "dump-simpl", "simplification" )
, (DumpTranslated , "dump-trans", "pattern matching compilation")
, (DumpCaseCompleted, "dump-cc" , "case completion" )
, (DumpFlatCurry , "dump-flat" , "translation into FlatCurry" )
]
-- |Description and flag of language extensions
......@@ -432,12 +432,12 @@ debugDescriptions =
, \ opts -> opts { dbDumpLevels = [] })
, ( "dump-env" , "additionally dump compiler environment"
, \ opts -> opts { dbDumpEnv = True })
, ( "dump-raw" , "dump as raw AST (instead of pretty printed)"
, ( "dump-raw" , "dump as raw AST (instead of pretty printing)"
, \ opts -> opts { dbDumpRaw = True })
] ++ map toDescr dumpLevel
where
toDescr (flag, name, desc)
= (name , "dump " ++ desc
= (name , "dump code after " ++ desc
, \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
addFlag :: Eq a => a -> [a] -> [a]
......
......@@ -21,6 +21,7 @@ module Modules
import qualified Control.Exception as C (catch, IOException)
import Control.Monad (liftM, unless, when)
import Data.Char (toUpper)
import qualified Data.Map as Map (elems)
import Data.Maybe (fromMaybe)
import System.Directory (getTemporaryDirectory, removeFile)
......@@ -350,15 +351,23 @@ dumpWith opts view lvl res@(env, mdl) = do
-- |Translate FlatCurry into the intermediate language 'IL'
-- |The 'dump' function writes the selected information to standard output.
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
doDump opts (level, env, dump)
= when (level `elem` dbDumpLevels opts) $ liftIO $ do
putStrLn (heading (capitalize $ lookupHeader dumpLevel) '=')
when (dbDumpEnv opts) $ do
putStrLn (heading "Environment" '-')
putStrLn (showCompilerEnv env)
putStrLn (heading "Source Code" '-')
putStrLn dump
where
header = lookupHeader dumpLevel
heading h s = '\n' : h ++ '\n' : replicate (length h) s
lookupHeader [] = "Unknown dump level " ++ show level
lookupHeader ((l,_,h):lhs)
| level == l = h
| otherwise = lookupHeader lhs
capitalize = unwords . map firstUpper . words
firstUpper "" = ""
firstUpper (c:cs) = toUpper c : cs
errModuleFileMismatch :: ModuleIdent -> Message
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment