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 :: A.Process -> PassM String
-generateC st ast
+generateC ast
-    =  do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st
+    =  do (a, w) <- runWriterT (genTopLevel ast)
-          case v of
+          return $ concat w
-            Left e -> dieIO e
-            Right (_, ss) -> return $ concat ss
 
 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"
+  -- Run the compiler.
-  state0a <- loadSource fn state0
+  v <- evalStateT (runErrorT (compile fn)) initState
-  debugIO state0a "}}}"
+  case v of
+    Left e -> dieIO e
+    Right r -> return ()
 
-  debugIO state0a "{{{ Parse"
+-- | Compile a file.
-  progressIO state0a $ "Parse"
+-- This is written in the PassM monad -- as are most of the things it calls --
-  (ast1, state1) <- parseProgram fn state0a
+-- because then it's very easy to pass the state around.
-  debugASTIO state1 ast1
+compile :: String -> PassM ()
-  debugIO state1 "}}}"
+compile fn
+  =  do optsPS <- get
 
-  if psParseOnly state1 then
+        debug "{{{ Preprocess"
-      putStrLn $ show ast1
+        loadSource fn
-    else do
+        debug "}}}"
-      progressIO state1 "Passes:"
-      (ast2, state2) <- runPass (runPasses passes) ast1 state1
 
-      debugIO state2 "{{{ Generate C"
+        debug "{{{ Parse"
-      progressIO state2 "Generate C"
+        progress "Parse"
-      c <- generateC state2 ast2
+        ast1 <- parseProgram fn
-      case psOutputFile state2 of
+        debugAST ast1
-        "-" -> putStr c
+        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 progressIO state2 $ "Writing output file " ++ file
+            do progress $ "Writing output file " ++ file
-             f <- openFile file WriteMode
+               f <- liftIO $ openFile file WriteMode
-             hPutStr f c
+               liftIO $ hPutStr f output
-             hClose f
+               liftIO $ hClose f
-      debugIO state2 "}}}"
+
-      progressIO state2 "Done"
+        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 :: String -> PassM ()
-loadSource file ps = execStateT (runErrorT (load file file)) ps
+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 :: String -> PassM A.Process
-parseProgram file ps
+parseProgram file
-    =  do (f, ps') <- parseFile file ps
+    =  do ps <- get
-          return (f $ A.Main emptyMeta, ps')
+          (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 ()
+-- | Print a progress message.
-verboseMessageIO n ps s = when (psVerboseLevel ps >= n) $ hPutStrLn stderr s
+progress :: (PSM m, MonadIO m) => String -> m ()
-
--- | Print a progress message if appropriate.
-progress :: String -> PassM ()
 progress = verboseMessage 1
 
--- | Print a progress message if appropriate (in the IO monad).
+-- | Print a debugging message.
-progressIO :: ParseState -> String -> IO ()
+debug :: (PSM m, MonadIO m) => String -> m ()
-progressIO = verboseMessageIO 1
-
--- | Print a debugging message if appropriate.
-debug :: String -> PassM ()
 debug = verboseMessage 2
 
--- | Print a debugging message if appropriate (in the IO monad).
+-- | Dump the AST and parse state.
-debugIO :: ParseState -> String -> IO ()
+debugAST :: (PSM m, MonadIO m) => A.Process -> m ()
-debugIO = verboseMessageIO 2
-
--- | Dump the AST and parse state if appropriate.
-debugAST :: A.Process -> PassM ()
 debugAST p
-    =  do ps <- get
+    =  do debug $ "{{{ AST"
-          liftIO $ debugASTIO ps p
+          debug $ pshow p
-
+          debug $ "}}}"
--- | Dump the AST and parse state if appropriate (in the IO monad).
+          debug $ "{{{ State"
-debugASTIO :: ParseState -> A.Process -> IO ()
+          ps <- get
-debugASTIO ps p
+          debug $ pshow ps
-    =  do debugIO ps $ "{{{ AST"
+          debug $ "}}}"
-          debugIO ps $ pshow p
-          debugIO ps $ "}}}"
-          debugIO ps $ "{{{ State"
-          debugIO ps $ pshow ps
-          debugIO ps $ "}}}"