Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added an option to output some debug info.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-02-20 14:39:56 +01:00
parent 6749650223
commit fe4533c7ae
2 changed files with 40 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

1
language.cabal
View file

@ -49,4 +49,5 @@ executable language
, either , either
, array , array
, extra , extra
, directory
default-language: GHC2021 default-language: GHC2021

55
src/Main.hs
View file

@ -2,28 +2,35 @@
module Main where module Main where
import Compiler (compile) import Compiler (compile)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
-- import Interpreter (interpret) -- import Interpreter (interpret)
import LambdaLifter (lambdaLift) import Control.Monad (unless, when)
import Renamer (rename) import Data.List.Extra (isSuffixOf)
import System.Environment (getArgs) import LambdaLifter (lambdaLift)
import System.Exit (exitFailure, exitSuccess) import Renamer (rename)
import System.IO (stderr) import System.Directory (createDirectory, doesPathExist,
import TypeChecker (typecheck) getDirectoryContents,
setCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (stderr)
import System.Process.Extra (spawnCommand, waitForProcess)
import TypeChecker (typecheck)
main :: IO () main :: IO ()
main = main =
getArgs >>= \case getArgs >>= \case
[] -> print "Required file path missing" [] -> print "Required file path missing"
(s : _) -> main' s ("-d": s : _) -> main' True s
(s : _) -> main' False s
main' :: String -> IO () main' :: Bool -> String -> IO ()
main' s = do main' debug s = do
file <- readFile s file <- readFile s
printToErr "-- Parse Tree -- " printToErr "-- Parse Tree -- "
@ -44,8 +51,13 @@ main' s = do
printToErr "\n -- Printing compiler output to stdout --" printToErr "\n -- Printing compiler output to stdout --"
compiled <- fromCompilerErr $ compile lifted compiled <- fromCompilerErr $ compile lifted
putStrLn compiled --putStrLn compiled
writeFile "llvm.ll" compiled
check <- doesPathExist "output"
unless check (createDirectory "output")
writeFile "output/llvm.ll" compiled
if debug then debugDotViz else putStrLn compiled
-- interpred <- fromInterpreterErr $ interpret lifted -- interpred <- fromInterpreterErr $ interpret lifted
-- putStrLn "\n-- interpret" -- putStrLn "\n-- interpret"
@ -53,6 +65,17 @@ main' s = do
exitSuccess exitSuccess
debugDotViz :: IO ()
debugDotViz = do
setCurrentDirectory "output"
spawnWait "opt -dot-cfg llvm.ll -disable-output"
content <- filter (isSuffixOf ".dot") <$> getDirectoryContents "."
let commands = (\p -> "dot " <> p <> " -Tpng -o" <> p <> ".png") <$> content
mapM_ spawnWait commands
setCurrentDirectory ".."
return ()
where
spawnWait s = spawnCommand s >>= waitForProcess
printToErr :: String -> IO () printToErr :: String -> IO ()
printToErr = hPutStrLn stderr printToErr = hPutStrLn stderr