Added a Warn monad for warnings, and incorporated a WriterT monad into the PassM stack to support the Warn monad, then changed all the rest of the code accordingly, including adding a Warn instance for the GenParser parser that hides it in the state

Main.hs

@@ -22,6 +22,7 @@ module Main (main) where
 import Control.Monad.Error
 import Control.Monad.Identity
 import Control.Monad.State
+import Control.Monad.Writer
 import Data.Either
 import Data.Generics
 import Data.Maybe
@@ -145,10 +146,10 @@ main = do
             ModeFull -> evalStateT (compileFull fn) []
 
   -- Run the compiler.
-  v <- evalStateT (runErrorT operation) initState
+  v <- runWriterT $ evalStateT (runErrorT operation) initState
   case v of
-    Left e -> dieIO e
-    Right r -> return ()
+    (Left e, ws) -> showWarnings ws >> dieIO e
+    (Right r, ws) -> showWarnings ws
 
 removeFiles :: [FilePath] -> IO ()
 removeFiles = mapM_ (\file -> catch (removeFile file) doNothing)
@@ -252,8 +253,6 @@ compile mode fn outHandle
         debugAST ast1
         debug "}}}"
 
-        showWarnings
-
         output <-
           case mode of
             ModeParse -> return $ pshow ast1
@@ -290,8 +289,6 @@ compile mode fn outHandle
 
                  return code
 
-        showWarnings
-
         liftIO $ hPutStr outHandle output
 
         progress "Done"
@@ -304,7 +301,5 @@ postCAnalyse fn outHandle
           progress "Analysing assembly"
           output <- analyseAsm asm
 
-          showWarnings
-
           liftIO $ hPutStr outHandle output
 

backends/GenerateCTest.hs

@@ -49,6 +49,7 @@ import GenerateCBased
 import GenerateCPPCSP
 import Metadata
 import TestUtils
+import Utils
 
 -- | A few helper functions for writing certain characters (that won't appear in our generated C/C++ source)
 -- to the WriterT monad.  Useful as simple placeholders/special values during testers.
@@ -105,7 +106,10 @@ assertGenFail n act
                            else assertFailure $ n ++ " pass succeeded when expected to fail, output: " ++ (subRegex (mkRegex "/\\*\\*/") (concat ss) "")
 
 evalCGen :: CGen () -> GenOps -> CompState -> IO (Either Errors.ErrorReport [String])
-evalCGen act ops state = evalStateT (runErrorT $ execWriterT $ runReaderT act ops) state
+evalCGen act ops state = evalCGen' (runReaderT act ops) state
+
+evalCGen' :: CGen' () -> CompState -> IO (Either Errors.ErrorReport [String])
+evalCGen' act state = runWriterT (evalStateT (runErrorT $ execWriterT act) state) >>* fst
 
 -- | Checks that running the test for the C and C++ backends produces the right output for each.
 testBothS :: 
@@ -132,7 +136,7 @@ testBothFailS testName act startState = TestList
 
 -- | Checks that the given output of a backend satisfies the given regex, and returns the matched groups.
 testRS :: String -> String -> CGen' () -> State CompState () -> IO [String]
-testRS testName exp act startState = assertGenR testName exp (evalStateT (runErrorT (execWriterT act)) state)
+testRS testName exp act startState = assertGenR testName exp (evalCGen' act state)
   where
     state = execState startState emptyState
 
@@ -881,7 +885,7 @@ testIf = TestList
    e :: A.Expression
    e = undefined
    p :: A.Process
-   p = undefined 
+   p = undefined
    over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
 
 testWhile :: Test
@@ -1096,7 +1100,7 @@ testMobile :: Test
 testMobile = TestList
  [
   testBoth "testMobile 0" "malloc(#(Int Left False))" "new Int" (local over (tcall3 genAllocMobile emptyMeta (A.Mobile A.Int) Nothing))
-  ,TestCase $ assertGen "testMobile 1/C++" "new Int($)" $ (evalStateT (runErrorT (execWriterT $ flip runReaderT (over cppgenOps) $ call genAllocMobile emptyMeta (A.Mobile A.Int) (Just undefined))) emptyState)
+  ,TestCase $ assertGen "testMobile 1/C++" "new Int($)" $ (evalCGen (call genAllocMobile emptyMeta (A.Mobile A.Int) (Just undefined)) (over cppgenOps) emptyState)
   
   ,testBoth "testMobile 100" "if(@!=NULL){free(@);@=NULL;}" "if(@!=NULL){delete @;@=NULL;}"
     (local over (tcall2 genClearMobile emptyMeta undefined))

common/CompState.hs

@@ -72,7 +72,6 @@ data CompState = CompState {
     csUnscopedNames :: Map String String,
     csNameCounter :: Int,
     csTypeContext :: [Maybe A.Type],
-    csWarnings :: [String],
 
     -- Set by passes
     csNonceCounter :: Int,
@@ -103,7 +102,6 @@ emptyState = CompState {
     csUnscopedNames = Map.empty,
     csNameCounter = 0,
     csTypeContext = [],
-    csWarnings = [],
 
     csNonceCounter = 0,
     csFunctionReturns = Map.empty,
@@ -146,6 +144,14 @@ instance (CSMR m, Error e) => CSMR (ErrorT e m) where
 instance (CSMR m, Monoid w) => CSMR (WriterT w m) where
   getCompState = lift getCompState
 
+type WarningReport = (Maybe Meta, String)
+
+class Monad m => Warn m where
+  warnReport :: WarningReport -> m ()
+
+--instance (MonadWriter [WarningReport] m) => Warn m where
+--  warnReport r = tell [r]
+
 --{{{  name definitions
 -- | Add the definition of a name.
 defineName :: CSM m => A.Name -> A.NameDef -> m ()
@@ -167,12 +173,14 @@ lookupNameOrError n err
 
 --{{{  warnings
 -- | Add a warning with no source position.
-addPlainWarning :: CSM m => String -> m ()
-addPlainWarning msg = modify (\ps -> ps { csWarnings = msg : csWarnings ps })
+addPlainWarning :: Warn m => String -> m ()
+addPlainWarning msg = warnReport (Nothing, msg)
+  -- modify (\ps -> ps { csWarnings = msg : csWarnings ps })
 
 -- | Add a warning.
-addWarning :: CSM m => Meta -> String -> m ()
-addWarning m s = addPlainWarning $ "Warning: " ++ show m ++ ": " ++ s
+addWarning :: Warn m => Meta -> String -> m ()
+addWarning m s = warnReport (Just m, s)
+  -- addPlainWarning $ "Warning: " ++ show m ++ ": " ++ s
 --}}}
 
 --{{{  pulled items

common/Pass.hs

@@ -22,6 +22,7 @@ module Pass where
 import Control.Monad.Error
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Writer
 import Data.Generics
 import Data.List
 import System.IO
@@ -34,24 +35,30 @@ import PrettyShow
 import TreeUtils
 
 -- | The monad in which AST-mangling passes operate.
-type PassM = ErrorT ErrorReport (StateT CompState IO)
-type PassMR = ErrorT ErrorReport (ReaderT CompState IO)
+type PassM = ErrorT ErrorReport (StateT CompState (WriterT [WarningReport]  IO))
+type PassMR = ErrorT ErrorReport (ReaderT CompState (WriterT [WarningReport]  IO))
 
 instance Die PassM where
   dieReport = throwError
 
 instance Die PassMR where
   dieReport = throwError
+  
+instance Warn PassM where
+  warnReport w = tell [w]
+
+instance Warn PassMR where
+  warnReport w = tell [w]
 
 -- | The type of an AST-mangling pass.
 type Pass = A.AST -> PassM A.AST
 
 runPassR :: PassMR a -> PassM a
 runPassR p = do st <- get
-                r <- liftIO $ runReaderT (runErrorT p) st
+                (r,w) <- liftIO $ runWriterT $ runReaderT (runErrorT p) st
                 case r of
                   Left err -> throwError err
-                  Right result -> return result
+                  Right result -> tell w >> return result
 
 -- | Compose a list of passes into a single pass.
 runPasses :: [(String, Pass)] -> Pass
@@ -71,16 +78,17 @@ verboseMessage n s
           when (csVerboseLevel ps >= n) $
             liftIO $ hPutStrLn stderr s
 
+{-
 -- | Print a warning message.
 warn :: (CSM m, MonadIO m) => String -> m ()
 warn = verboseMessage 0
-
--- | Print out any warnings stored.
-showWarnings :: (CSM m, MonadIO m) => m ()
-showWarnings
-    =  do ps <- get
-          sequence_ $ map warn (reverse $ csWarnings ps)
-          put $ ps { csWarnings = [] }
+-}
+-- | Print out a list of warnings
+showWarnings ::  MonadIO m => [WarningReport] -> m ()
+showWarnings = mapM_ printWarning
+  where
+    printWarning (Just m, s) = liftIO $ hPutStrLn stderr $ show m ++ " " ++ s
+    printWarning (Nothing, s) = liftIO $ hPutStrLn stderr s
 
 -- | Print a progress message.
 progress :: (CSM m, MonadIO m) => String -> m ()

common/TestHarness.hs

@@ -35,6 +35,7 @@ module TestHarness (automaticTest, automaticTimeTest) where
 
 import Control.Monad.Error
 import Control.Monad.State
+import Control.Monad.Writer
 import Data.List
 import Data.Maybe
 import System.IO
@@ -62,7 +63,7 @@ defaultState = emptyState {csUsageChecking = True}
 -- | Tests if compiling the given source gives any errors.
 -- If there are errors, they are returned.  Upon success, Nothing is returned
 testOccam :: String -> IO (Maybe String)
-testOccam source = do result <- evalStateT (runErrorT compilation) defaultState
+testOccam source = do (result,_) <- runWriterT $ evalStateT (runErrorT compilation) defaultState
                       return $ case result of
                                  Left (_,err) -> Just err
                                  Right _  -> Nothing

common/TestUtils.hs

@@ -40,6 +40,7 @@ module TestUtils where
 
 import Control.Monad.Error
 import Control.Monad.State
+import Control.Monad.Writer
 import Data.Generics
 import qualified Data.Map as Map
 import System.Time
@@ -322,7 +323,7 @@ runPass ::
   PassM b                            -- ^ The actual pass.
   -> CompState                       -- ^ The state to use to run the pass.
   -> IO (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass.
-runPass actualPass startState = (liftM (\(x,y) -> (y,x))) (runStateT (runErrorT actualPass) startState)
+runPass actualPass startState = (liftM (\((x,y),_) -> (y,x))) (runWriterT $ runStateT (runErrorT actualPass) startState)
 
 -- | A test that runs a given AST pass and checks that it succeeds.
 testPass :: 

frontends/ParseOccam.hs

@@ -21,6 +21,7 @@ module ParseOccam (parseOccamProgram) where
 
 import Control.Monad (liftM, when)
 import Control.Monad.State (MonadState, modify, get, put)
+import Control.Monad.Writer (tell)
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
@@ -41,17 +42,29 @@ import Types
 import Utils
 
 --{{{ the parser monad
-type OccParser = GenParser Token CompState
+type OccParser = GenParser Token ([WarningReport], CompState)
 
 -- | Make MonadState functions work in the parser monad.
 -- This came from <http://hackage.haskell.org/trac/ghc/ticket/1274> -- which means
 -- it'll probably be in a future GHC release anyway.
+{-
 instance MonadState st (GenParser tok st) where
   get = getState
   put = setState
+-}
+instance CSMR (GenParser tok (a,CompState)) where
+  getCompState = getState >>* snd
 
-instance CSMR (GenParser tok CompState) where
-  getCompState = getState
+-- We can expose only part of the state to make it look like we are only using
+-- CompState:
+instance MonadState CompState (GenParser tok (a,CompState)) where
+  get = getState >>* snd
+  put st = do (other, _) <- getState
+              setState (other, st)
+
+instance Warn (GenParser tok ([WarningReport], b)) where
+  warnReport w = do (ws, other) <- getState
+                    setState (ws ++ [w], other)
 
 instance Die (GenParser tok st) where
   dieReport (Just m, err) = fail $ packMeta m err
@@ -410,7 +423,7 @@ noTypeContext = inTypeContext Nothing
 --{{{ name scoping
 findName :: A.Name -> OccParser A.Name
 findName thisN
-    =  do st <- getState
+    =  do st <- get
           origN <- case lookup (A.nameName thisN) (csLocalNames st) of
                      Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
                      Just n -> return n
@@ -420,13 +433,13 @@ findName thisN
 
 makeUniqueName :: String -> OccParser String
 makeUniqueName s
-    =  do st <- getState
-          setState $ st { csNameCounter = csNameCounter st + 1 }
+    =  do st <- get
+          put $ st { csNameCounter = csNameCounter st + 1 }
           return $ s ++ "_u" ++ show (csNameCounter st)
 
 findUnscopedName :: A.Name -> OccParser A.Name
 findUnscopedName n@(A.Name m nt s)
-    =  do st <- getState
+    =  do st <- get
           case Map.lookup s (csUnscopedNames st) of
             Just s' -> return $ A.Name m nt s'
             Nothing ->
@@ -456,11 +469,11 @@ scopeIn n@(A.Name m nt s) t am
 
 scopeOut :: A.Name -> OccParser ()
 scopeOut n@(A.Name m nt s)
-    =  do st <- getState
+    =  do st <- get
           let lns' = case csLocalNames st of
                        (s, _):ns -> ns
                        otherwise -> dieInternal (Just m, "scopeOut trying to scope out the wrong name")
-          setState $ st { csLocalNames = lns' }
+          put $ st { csLocalNames = lns' }
 
 -- FIXME: Do these with generics? (going carefully to avoid nested code blocks)
 scopeInRep :: A.Replicator -> OccParser A.Replicator
@@ -1979,7 +1992,7 @@ topLevelItem = handleSpecs (allocation <|> specification) topLevelItem
                       -- Stash the current locals so that we can either restore them
                       -- when we get back to the file we included this one from, or
                       -- pull the TLP name from them at the end.
-                      updateState $ (\ps -> ps { csMainLocals = csLocalNames ps })
+                      modify $ (\ps -> ps { csMainLocals = csLocalNames ps })
                       return $ A.Several m []
                       
 
@@ -1987,11 +2000,11 @@ topLevelItem = handleSpecs (allocation <|> specification) topLevelItem
 -- A source file is really a series of specifications, but the later ones need to
 -- have the earlier ones in scope, so we can't parse them separately.
 -- Instead, we nest the specifications
-sourceFile :: OccParser (A.AST, CompState)
+sourceFile :: OccParser (A.AST, [WarningReport], CompState)
 sourceFile
     =   do p <- topLevelItem
-           s <- getState
-           return (p, s)
+           (w, s) <- getState
+           return (p, w, s)
 --}}}
 --}}}
 
@@ -1999,7 +2012,7 @@ sourceFile
 -- | Parse a token stream with the given production.
 runTockParser :: [Token] -> OccParser t -> CompState -> PassM t
 runTockParser toks prod cs
-    =  do case runParser prod cs "" toks of
+    =  do case runParser prod ([], cs) "" toks of
             Left err -> dieReport (Nothing, "Parse error: " ++ show err)
             Right r -> return r
 
@@ -2007,8 +2020,9 @@ runTockParser toks prod cs
 parseOccamProgram :: [Token] -> PassM A.AST
 parseOccamProgram toks
     =  do cs <- get
-          (p, cs') <- runTockParser toks sourceFile cs
+          (p, ws, cs') <- runTockParser toks sourceFile cs
           put cs'
+          tell ws
           return p
 --}}}
 

frontends/RainTypesTest.hs

@@ -21,6 +21,7 @@ module RainTypesTest where
 
 import Control.Monad.State
 import Control.Monad.Error
+import Control.Monad.Writer
 import Data.Generics
 import Test.HUnit hiding (State)
 
@@ -34,6 +35,7 @@ import TagAST
 import TestUtils
 import TreeUtils
 import Types
+import Utils
 
 -- | Tests that constants in expressions are folded properly.  TODO these tests could do with a lot of expanding.
 -- It may even be easiest to use QuickCheck for the testing.
@@ -379,7 +381,7 @@ checkExpressionTest = TestList
                               if (e /= act) then pass' (10000 + n) t (mkPattern e) e else return ()
             where
               errorOrType :: IO (Either ErrorReport A.Type)
-              errorOrType = evalStateT (runErrorT $ typeOfExpression e) (execState state emptyState)
+              errorOrType = ((runWriterT (evalStateT (runErrorT $ typeOfExpression e) (execState state emptyState))) :: IO (Either ErrorReport A.Type, [WarningReport])) >>* fst
   
   
   fail :: Int -> ExprHelper -> Test