122 lines
3.6 KiB
Haskell
122 lines
3.6 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Main where
|
|
|
|
import Codegen.Codegen (generateCode)
|
|
import GHC.IO.Handle.Text (hPutStrLn)
|
|
import Grammar.ErrM (Err)
|
|
import Grammar.Par (myLexer, pProgram)
|
|
import Grammar.Print (printTree)
|
|
|
|
-- import Interpreter (interpret)
|
|
import Control.Monad (when)
|
|
import Data.List.Extra (isSuffixOf)
|
|
import LambdaLifter.LambdaLifter (lambdaLift)
|
|
import Renamer.Renamer (rename)
|
|
import System.Directory (createDirectory, doesPathExist,
|
|
getDirectoryContents,
|
|
removeDirectoryRecursive,
|
|
setCurrentDirectory)
|
|
import System.Environment (getArgs)
|
|
import System.Exit (exitFailure, exitSuccess)
|
|
import System.IO (stderr)
|
|
import System.Process.Extra (spawnCommand, waitForProcess)
|
|
import TypeChecker.TypeChecker (typecheck)
|
|
|
|
main :: IO ()
|
|
main =
|
|
getArgs >>= \case
|
|
[] -> print "Required file path missing"
|
|
("-d": s : _) -> main' True s
|
|
(s : _) -> main' False s
|
|
|
|
main' :: Bool -> String -> IO ()
|
|
main' debug s = do
|
|
file <- readFile s
|
|
|
|
printToErr "-- Parse Tree -- "
|
|
parsed <- fromSyntaxErr . pProgram $ myLexer file
|
|
printToErr $ printTree parsed
|
|
|
|
printToErr "\n-- Renamer --"
|
|
let renamed = rename parsed
|
|
printToErr $ printTree renamed
|
|
|
|
printToErr "\n-- TypeChecker --"
|
|
typechecked <- fromTypeCheckerErr $ typecheck renamed
|
|
printToErr $ printTree typechecked
|
|
|
|
printToErr "\n-- Lambda Lifter --"
|
|
let lifted = lambdaLift typechecked
|
|
printToErr $ printTree lifted
|
|
|
|
printToErr "\n -- Printing compiler output to stdout --"
|
|
compiled <- fromCompilerErr $ generateCode lifted
|
|
--putStrLn compiled
|
|
|
|
check <- doesPathExist "output"
|
|
when check (removeDirectoryRecursive "output")
|
|
createDirectory "output"
|
|
writeFile "output/llvm.ll" compiled
|
|
if debug then debugDotViz else putStrLn compiled
|
|
|
|
|
|
-- interpred <- fromInterpreterErr $ interpret lifted
|
|
-- putStrLn "\n-- interpret"
|
|
-- print interpred
|
|
|
|
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 = hPutStrLn stderr
|
|
|
|
fromCompilerErr :: Err a -> IO a
|
|
fromCompilerErr =
|
|
either
|
|
( \err -> do
|
|
putStrLn "\nCOMPILER ERROR"
|
|
putStrLn err
|
|
exitFailure
|
|
)
|
|
pure
|
|
|
|
fromSyntaxErr :: Err a -> IO a
|
|
fromSyntaxErr =
|
|
either
|
|
( \err -> do
|
|
putStrLn "\nSYNTAX ERROR"
|
|
putStrLn err
|
|
exitFailure
|
|
)
|
|
pure
|
|
|
|
fromTypeCheckerErr :: Err a -> IO a
|
|
fromTypeCheckerErr =
|
|
either
|
|
( \err -> do
|
|
putStrLn "\nTYPECHECKER ERROR"
|
|
putStrLn err
|
|
exitFailure
|
|
)
|
|
pure
|
|
|
|
fromInterpreterErr :: Err a -> IO a
|
|
fromInterpreterErr =
|
|
either
|
|
( \err -> do
|
|
putStrLn "\nINTERPRETER ERROR"
|
|
putStrLn err
|
|
exitFailure
|
|
)
|
|
pure
|