Debugging information to stderr, and only shown if -v is given

fco/Main.hs

@@ -2,8 +2,10 @@
 
 module Main where
 
+import List
 import System
 import System.Console.GetOpt
+import System.IO
 
 import Parse
 import Tree
@@ -15,19 +17,21 @@ import PhaseOutput
 
 phaseList = [phaseSource, phaseIntermediate, phaseOutput]
 
-doPhases :: [Phase] -> Node -> IO Node
-doPhases [] n = do return n
-doPhases (p:ps) n = do
-  n' <- runPhase p n
-  n'' <- doPhases ps n'
+doPhases :: [Phase] -> Node -> Progress -> IO Node
+doPhases [] n progress = do return n
+doPhases (p:ps) n progress = do
+  n' <- runPhase p n progress
+  n'' <- doPhases ps n' progress
   return n''
 
-data Flag = ParseOnly
+data Flag = ParseOnly | Verbose
   deriving Eq
 
 options :: [OptDescr Flag]
 options =
-  [ Option ['p'] ["parse-only"] (NoArg ParseOnly) "parse input files and output S-expression" ]
+  [ Option ['p'] ["parse-only"] (NoArg ParseOnly) "parse input files and output S-expression"
+  , Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
+  ]
 
 getOpts :: [String] -> IO ([Flag], [String])
 getOpts argv =
@@ -36,6 +40,9 @@ getOpts argv =
     (_,_,errs) -> error (concat errs ++ usageInfo header options)
   where header = "Usage: fco [OPTION...] SOURCEFILE"
 
+numberedListing :: String -> String
+numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
+
 main :: IO ()
 main = do
   argv <- getArgs
@@ -45,20 +52,26 @@ main = do
               [fn] -> fn
               _ -> error "Must specify a single input file"
 
-  putStrLn $ "Compiling " ++ fn
-  putStrLn ""
+  let progress = if Verbose `elem` opts then hPutStrLn stderr else (\s -> return ())
 
-  parsed <- parseSourceFile fn
-  putStrLn ""
+  progress $ "Compiling " ++ fn
+  progress ""
+
+  preprocessed <- readSource fn
+  progress $ "Preprocessed: "
+  progress $ numberedListing preprocessed
+  progress $ ""
+
+  let parsed = parseSource preprocessed
 
   if ParseOnly `elem` opts
     then do
       putStrLn $ show (nodeToSExp parsed)
     else do
-      putStrLn $ "Parsed: " ++ show parsed
-      putStrLn ""
+      progress $ "Parsed: " ++ show parsed
+      progress ""
 
-      out <- doPhases phaseList parsed
-      putStrLn ""
-      putStrLn $ "After phases: " ++ show out
+      out <- doPhases phaseList parsed progress
+      progress ""
+      progress $ "After phases: " ++ show out
 

fco/Parse.hs

@@ -1,6 +1,6 @@
 -- Parse occam code
 
-module Parse (parseSourceFile, prepare) where
+module Parse (readSource, parseSource) where
 
 import Data.List
 import Text.ParserCombinators.Parsec
@@ -764,18 +764,21 @@ flatten ls = concat $ intersperse "\n" $ flatten' ls 0
 
 -- XXX Doesn't handle preprocessor instructions.
 
-prepare d = flatten $ lines (d ++ "\n" ++ mainMarker)
+preprocess :: String -> String
+preprocess d = flatten $ lines (d ++ "\n" ++ mainMarker)
 
-numberedListing :: String -> String
-numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
-
-parseSourceFile :: String -> IO Node
-parseSourceFile fn
-  = do  f <- IO.openFile fn IO.ReadMode
+readSource :: String -> IO String
+readSource fn = do
+  f <- IO.openFile fn IO.ReadMode
   d <- IO.hGetContents f
-        let prep = prepare d
-        putStrLn $ "Prepared: " ++ numberedListing prep
-        return $ case (parse sourceFile "occam" prep) of
+  let prep = preprocess d
+  return prep
+
+-- -------------------------------------------------------------
+
+parseSource :: String -> Node
+parseSource prep
+  = case (parse sourceFile "occam" prep) of
       Left err -> error ("Parsing error: " ++ (show err))
       Right defs -> defs
 

fco/Pass.hs

@@ -4,6 +4,8 @@ module Pass where
 
 import Tree
 
+type Progress = (String -> IO ())
+
 -- This is actually a fraction of a pass: an operation upon the tree.
 -- The arguments are:
 -- - "next": the next pass to try if this one doesn't match;
@@ -30,13 +32,14 @@ runPasses passes = top
 
 data Phase = Phase String [Pass] [(String, Pass)]
 
-runPhase :: Phase -> Node -> IO Node
-runPhase (Phase name bases passes) n = do putStrLn $ "Phase: " ++ name
+runPhase :: Phase -> Node -> Progress -> IO Node
+runPhase (Phase name bases passes) n progress = do
+  progress $ "Phase: " ++ name
   runPhase' (reverse passes) n
   where
     runPhase' :: [(String, Pass)] -> Node -> IO Node
     runPhase' [] n = do return n
     runPhase' ((name, p):ps) n = do rest <- runPhase' ps n
-                                    putStrLn $ "  Pass: " ++ name
+                                    progress $ "  Pass: " ++ name
                                     return $ runPasses (p : bases) rest