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

Improved dump output

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