From 94e3bcd7fe8130d72fabe4b627d0d79166e2e530 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 25 Apr 2007 16:42:17 +0000 Subject: [PATCH] Recast the driver and most of the components into the PassM monad --- fco2/GenerateC.hs | 13 ++++----- fco2/Main.hs | 74 ++++++++++++++++++++++++++++++----------------- fco2/Parse.hs | 14 +++++---- fco2/Pass.hs | 56 +++++++++++------------------------ 4 files changed, 79 insertions(+), 78 deletions(-) diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 93bf9aa..0749928 100644 --- a/fco2/GenerateC.hs +++ b/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"] diff --git a/fco2/Main.hs b/fco2/Main.hs index 3b8cc3d..50ce7d7 100644 --- a/fco2/Main.hs +++ b/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" diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 708ee48..7732f39 100644 --- a/fco2/Parse.hs +++ b/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) --}}} diff --git a/fco2/Pass.hs b/fco2/Pass.hs index 8b825d3..6f967bf 100644 --- a/fco2/Pass.hs +++ b/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 $ "}}}"