Command-line options for AST and IR

1 files changed, 24 insertions, 7 deletions

diff --git a/Main.hs b/Main.hs
index 70991c0..14f3202 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE LambdaCase, TupleSections #-}
 module Main where
 
+import Control.Monad
 import System.Environment
 import System.Exit
 
@@ -14,18 +14,35 @@ import VM
 usage :: IO ()
 usage = do
     progname <- getProgName
-    putStrLn $ "Usage: " ++ progname ++ " [filename.lisp]"
+    putStrLn $ "Usage: " ++ progname ++ " [-h] [-ast] [-ir] [filename.lisp]"
+    putStrLn $ "When no filename is given, will read from stdin."
+    putStrLn $ "  -h     Show this help"
+    putStrLn $ "  -ast   Print AST after compiler macro's"
+    putStrLn $ "  -ir    Print IR after optimisation"
+
+data Options = Options { optAST :: Bool, optIR :: Bool }
+
+parseOptions' :: (Options, Maybe FilePath) -> [String] -> IO (Options, Maybe FilePath)
+parseOptions' pair [] = return pair
+parseOptions' _ ("-h":_) = usage >> exitSuccess
+parseOptions' (opt, fp) ("-ast":as) = parseOptions' (opt { optAST = True }, fp) as
+parseOptions' (opt, fp) ("-ir":as) = parseOptions' (opt { optIR = True }, fp) as
+parseOptions' _ (('-':a):_) = putStrLn ("Unknown option '" ++ a ++ "'") >> usage >> exitFailure
+parseOptions' (opt, Nothing) (f:as) = parseOptions' (opt, Just f) as
+parseOptions' (_, Just _) (_:_) = putStrLn "At most one filename argument expected" >> usage >> exitFailure
+
+parseOptions :: [String] -> IO (Options, Maybe FilePath)
+parseOptions = parseOptions' (Options False False, Nothing)
 
 main :: IO ()
 main = do
-    (mfname, source) <- getArgs >>= \case
-        [] -> (Nothing,) <$> getContents
-        [arg] -> (Just arg,) <$> readFile arg
-        _ -> usage >> exitFailure
+    (opts, mfname) <- getArgs >>= parseOptions
+    source <- maybe getContents readFile mfname
 
     prog <- parseProgram mfname source >>= either (die . show) return
     let prog' = compilerMacros prog
+    when (optAST opts) $ print prog'
     irprog <- either die return (compileProgram prog')
     let opt = optimise irprog
-    -- print opt
+    when (optIR opts) $ print opt
     vmRun opt