Recast the driver and most of the components into the PassM monad

fco2/GenerateC.hs

@@ -12,24 +12,23 @@ import Text.Printf
 import qualified AST as A
 import Metadata
 import ParseState
+import Pass
 import Errors
 import TLP
 import Types
 
 --{{{  monad definition
-type CGen = WriterT [String] (ErrorT String (StateT ParseState IO))
+type CGen = WriterT [String] PassM
 
 instance Die CGen where
   die = throwError
 --}}}
 
 --{{{  top-level
-generateC :: ParseState -> A.Process -> IO String
-generateC st ast
-    =  do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st
-          case v of
-            Left e -> dieIO e
-            Right (_, ss) -> return $ concat ss
+generateC :: A.Process -> PassM String
+generateC ast
+    =  do (a, w) <- runWriterT (genTopLevel ast)
+          return $ concat w
 
 genTLPChannel :: TLPChannel -> CGen ()
 genTLPChannel TLPIn = tell ["in"]

fco2/Main.hs

@@ -1,11 +1,15 @@
 -- | Driver for the compiler.
 module Main where
 
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.State
 import List
 import System
 import System.Console.GetOpt
 import System.IO
 
+import Errors
 import GenerateC
 import Parse
 import ParseState
@@ -60,34 +64,52 @@ main = do
               [fn] -> fn
               _ -> error "Must specify a single input file"
 
-  state0 <- foldl (>>=) (return emptyState) opts
+  initState <- foldl (>>=) (return emptyState) opts
 
-  debugIO state0 "{{{ Preprocess"
-  state0a <- loadSource fn state0
-  debugIO state0a "}}}"
+  -- Run the compiler.
+  v <- evalStateT (runErrorT (compile fn)) initState
+  case v of
+    Left e -> dieIO e
+    Right r -> return ()
 
-  debugIO state0a "{{{ Parse"
-  progressIO state0a $ "Parse"
-  (ast1, state1) <- parseProgram fn state0a
-  debugASTIO state1 ast1
-  debugIO state1 "}}}"
+-- | Compile a file.
+-- This is written in the PassM monad -- as are most of the things it calls --
+-- because then it's very easy to pass the state around.
+compile :: String -> PassM ()
+compile fn
+  =  do optsPS <- get
 
-  if psParseOnly state1 then
-      putStrLn $ show ast1
-    else do
-      progressIO state1 "Passes:"
-      (ast2, state2) <- runPass (runPasses passes) ast1 state1
+        debug "{{{ Preprocess"
+        loadSource fn
+        debug "}}}"
 
-      debugIO state2 "{{{ Generate C"
-      progressIO state2 "Generate C"
-      c <- generateC state2 ast2
-      case psOutputFile state2 of
-        "-" -> putStr c
-        file ->
-          do progressIO state2 $ "Writing output file " ++ file
-             f <- openFile file WriteMode
-             hPutStr f c
-             hClose f
-      debugIO state2 "}}}"
-      progressIO state2 "Done"
+        debug "{{{ Parse"
+        progress "Parse"
+        ast1 <- parseProgram fn
+        debugAST ast1
+        debug "}}}"
+
+        output <-
+          if psParseOnly optsPS
+            then return $ show ast1
+            else
+              do progress "Passes:"
+                 ast2 <- (runPasses passes) ast1
+
+                 debug "{{{ Generate C"
+                 progress "Generate C"
+                 c <- generateC ast2
+                 debug "}}}"
+
+                 return c
+
+        case psOutputFile optsPS of
+          "-" -> liftIO $ putStr output
+          file ->
+            do progress $ "Writing output file " ++ file
+               f <- liftIO $ openFile file WriteMode
+               liftIO $ hPutStr f output
+               liftIO $ hClose f
+
+        progress "Done"
 

fco2/Parse.hs

@@ -1735,8 +1735,8 @@ mangleModName mod
 -- We have to do this now, before entering the parser, because the parser
 -- doesn't run in the IO monad. If there were a monad transformer version of
 -- Parsec then we could just open files as we need them.
-loadSource :: String -> ParseState -> IO ParseState
-loadSource file ps = execStateT (runErrorT (load file file)) ps
+loadSource :: String -> PassM ()
+loadSource file = load file file
   where
     load :: String -> String -> PassM ()
     load file realName
@@ -1773,9 +1773,11 @@ parseFile file ps
     replaceMain (A.Main _) np = np
 
 -- | Parse the top level source file in a program.
-parseProgram :: Monad m => String -> ParseState -> m (A.Process, ParseState)
-parseProgram file ps
-    =  do (f, ps') <- parseFile file ps
-          return (f $ A.Main emptyMeta, ps')
+parseProgram :: String -> PassM A.Process
+parseProgram file
+    =  do ps <- get
+          (f, ps') <- parseFile file ps
+          put ps'
+          return (f $ A.Main emptyMeta)
 --}}}
 

fco2/Pass.hs

@@ -19,14 +19,6 @@ instance Die PassM where
 -- | The type of an AST-mangling pass.
 type Pass = A.Process -> PassM A.Process
 
--- | Run a pass, dying with the appropriate error if it fails.
-runPass :: Pass -> A.Process -> ParseState -> IO (A.Process, ParseState)
-runPass pass ast st
-    =  do (v, ps) <- runStateT (runErrorT (pass ast)) st
-          case v of
-            Left e -> dieIO e
-            Right r -> return (r, ps)
-
 -- | Compose a list of passes into a single pass.
 runPasses :: [(String, Pass)] -> A.Process -> PassM A.Process
 runPasses [] ast = return ast
@@ -38,43 +30,29 @@ runPasses ((s, p):ps) ast
           debug $ "}}}"
           runPasses ps ast'
 
-verboseMessage :: Int -> String -> PassM ()
+-- | Print a message if above the given verbosity level.
+verboseMessage :: (PSM m, MonadIO m) => Int -> String -> m ()
 verboseMessage n s
     =  do ps <- get
-          liftIO $ verboseMessageIO n ps s
+          when (psVerboseLevel ps >= n) $
+            liftIO $ hPutStrLn stderr s
 
-verboseMessageIO :: Int -> ParseState -> String -> IO ()
-verboseMessageIO n ps s = when (psVerboseLevel ps >= n) $ hPutStrLn stderr s
-
--- | Print a progress message if appropriate.
-progress :: String -> PassM ()
+-- | Print a progress message.
+progress :: (PSM m, MonadIO m) => String -> m ()
 progress = verboseMessage 1
 
--- | Print a progress message if appropriate (in the IO monad).
-progressIO :: ParseState -> String -> IO ()
-progressIO = verboseMessageIO 1
-
--- | Print a debugging message if appropriate.
-debug :: String -> PassM ()
+-- | Print a debugging message.
+debug :: (PSM m, MonadIO m) => String -> m ()
 debug = verboseMessage 2
 
--- | Print a debugging message if appropriate (in the IO monad).
-debugIO :: ParseState -> String -> IO ()
-debugIO = verboseMessageIO 2
-
--- | Dump the AST and parse state if appropriate.
-debugAST :: A.Process -> PassM ()
+-- | Dump the AST and parse state.
+debugAST :: (PSM m, MonadIO m) => A.Process -> m ()
 debugAST p
-    =  do ps <- get
-          liftIO $ debugASTIO ps p
-
--- | Dump the AST and parse state if appropriate (in the IO monad).
-debugASTIO :: ParseState -> A.Process -> IO ()
-debugASTIO ps p
-    =  do debugIO ps $ "{{{ AST"
-          debugIO ps $ pshow p
-          debugIO ps $ "}}}"
-          debugIO ps $ "{{{ State"
-          debugIO ps $ pshow ps
-          debugIO ps $ "}}}"
+    =  do debug $ "{{{ AST"
+          debug $ pshow p
+          debug $ "}}}"
+          debug $ "{{{ State"
+          ps <- get
+          debug $ pshow ps
+          debug $ "}}}"