From fe4533c7aeb39055b4bbfcbfaab08aafad191cd6 Mon Sep 17 00:00:00 2001
From: Samuel Hammersberg <samuel.hammersberg@gmail.com>
Date: Mon, 20 Feb 2023 14:39:56 +0100
Subject: [PATCH] Added an option to output some debug info.

---
 language.cabal |  1 +
 src/Main.hs    | 55 +++++++++++++++++++++++++++++++++++---------------
 2 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/language.cabal b/language.cabal
index 8b958a5..bddbd21 100644
--- a/language.cabal
+++ b/language.cabal
@@ -49,4 +49,5 @@ executable language
       , either
       , array
       , extra
+      , directory
     default-language: GHC2021
diff --git a/src/Main.hs b/src/Main.hs
index 1831428..8309349 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,28 +2,35 @@
 
 module Main where
 
-import Compiler (compile)
-import GHC.IO.Handle.Text (hPutStrLn)
-import Grammar.ErrM (Err)
-import Grammar.Par (myLexer, pProgram)
-import Grammar.Print (printTree)
+import           Compiler             (compile)
+import           GHC.IO.Handle.Text   (hPutStrLn)
+import           Grammar.ErrM         (Err)
+import           Grammar.Par          (myLexer, pProgram)
+import           Grammar.Print        (printTree)
 
 -- import           Interpreter        (interpret)
-import LambdaLifter (lambdaLift)
-import Renamer (rename)
-import System.Environment (getArgs)
-import System.Exit (exitFailure, exitSuccess)
-import System.IO (stderr)
-import TypeChecker (typecheck)
+import           Control.Monad        (unless, when)
+import           Data.List.Extra      (isSuffixOf)
+import           LambdaLifter         (lambdaLift)
+import           Renamer              (rename)
+import           System.Directory     (createDirectory, doesPathExist,
+                                       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 =
     getArgs >>= \case
         [] -> print "Required file path missing"
-        (s : _) -> main' s
+        ("-d": s : _) -> main' True s
+        (s : _) -> main' False s
 
-main' :: String -> IO ()
-main' s = do
+main' :: Bool -> String -> IO ()
+main' debug s = do
     file <- readFile s
 
     printToErr "-- Parse Tree -- "
@@ -44,8 +51,13 @@ main' s = do
 
     printToErr "\n -- Printing compiler output to stdout --"
     compiled <- fromCompilerErr $ compile lifted
-    putStrLn compiled
-    writeFile "llvm.ll" compiled
+    --putStrLn compiled
+
+    check <- doesPathExist "output"
+    unless check (createDirectory "output")
+    writeFile "output/llvm.ll" compiled
+    if debug then debugDotViz else putStrLn compiled
+
 
     -- interpred <- fromInterpreterErr $ interpret lifted
     -- putStrLn "\n-- interpret"
@@ -53,6 +65,17 @@ main' s = do
 
     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