diff --git a/Main.hs b/Main.hs index 19fe3d2..826752a 100644 --- a/Main.hs +++ b/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 diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index 55b4603..0318a2e 100644 --- a/backends/GenerateCTest.hs +++ b/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)) diff --git a/common/CompState.hs b/common/CompState.hs index 02e16ec..02ac5ac 100644 --- a/common/CompState.hs +++ b/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 diff --git a/common/Pass.hs b/common/Pass.hs index e5bc0db..6ff4387 100644 --- a/common/Pass.hs +++ b/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 () diff --git a/common/TestHarness.hs b/common/TestHarness.hs index 6684215..ec2f5a2 100644 --- a/common/TestHarness.hs +++ b/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 diff --git a/common/TestUtils.hs b/common/TestUtils.hs index 8051626..d0c5ce2 100644 --- a/common/TestUtils.hs +++ b/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 :: diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 602ec0f..afea471 100644 --- a/frontends/ParseOccam.hs +++ b/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 -- 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 --}}} diff --git a/frontends/RainTypesTest.hs b/frontends/RainTypesTest.hs index fb0870f..12ea33d 100644 --- a/frontends/RainTypesTest.hs +++ b/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