From 6cbdc0e13bc6be70206ebad4a4242aa87ae250c4 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Thu, 20 Nov 2008 13:35:44 +0000 Subject: [PATCH] Finally merged the list of warnings into CompState rather than having its own StateT monad --- Main.hs | 4 ++-- backends/GenerateCTest.hs | 2 +- common/OccamEDSL.hs | 2 +- common/TestHarness.hs | 4 ++-- common/TestUtils.hs | 4 ++-- data/CompState.hs | 8 +++++--- pass/Pass.hs | 12 +++++------- 7 files changed, 18 insertions(+), 18 deletions(-) diff --git a/Main.hs b/Main.hs index a7edf41..3de9dcd 100644 --- a/Main.hs +++ b/Main.hs @@ -188,8 +188,8 @@ main = do -- Run the compiler. v <- runPassM initState operation case v of - (Left e, _, ws) -> showWarnings ws >> dieIO e - (Right r, _, ws) -> showWarnings ws + (Left e, cs) -> showWarnings (csWarnings cs) >> dieIO e + (Right r, cs) -> showWarnings (csWarnings cs) removeFiles :: [FilePath] -> IO () removeFiles = mapM_ (\file -> catch (removeFile file) doNothing) diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index 0074862..03473d8 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -110,7 +110,7 @@ evalCGen :: CGen () -> GenOps -> CompState -> IO (Either Errors.ErrorReport [Str evalCGen act ops state = evalCGen' (runReaderT act ops) state evalCGen' :: CGen' () -> CompState -> IO (Either Errors.ErrorReport [String]) -evalCGen' act state = runPassM state pass >>* (\(x,_,_) -> x) +evalCGen' act state = runPassM state pass >>* fst where pass = execStateT act (Left []) >>* (\(Left x) -> x) diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs index b941899..0f5604b 100644 --- a/common/OccamEDSL.hs +++ b/common/OccamEDSL.hs @@ -375,7 +375,7 @@ testOccamPassWarn str check code pass (exp, expS) = runState expm emptyState (inp, inpS) = runState inpm emptyState pass' = pass {passCode = \x -> do y <- passCode pass x - b <- lift (lift get) >>* check + b <- lift get >>* (check . csWarnings) when (not b) $ dieP emptyMeta $ str ++ " warnings not as expected" return y} diff --git a/common/TestHarness.hs b/common/TestHarness.hs index 53b8a41..256365f 100644 --- a/common/TestHarness.hs +++ b/common/TestHarness.hs @@ -60,7 +60,7 @@ defaultState fr = emptyState {csUsageChecking = True, csFrontend = fr} -- | 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,_,_) <- runPassM (defaultState FrontendOccam) compilation +testOccam source = do (result,_) <- runPassM (defaultState FrontendOccam) compilation return $ case result of Left (_,err) -> Just err Right _ -> Nothing @@ -70,7 +70,7 @@ testOccam source = do (result,_,_) <- runPassM (defaultState FrontendOccam) comp >>= runPasses (getPassList $ defaultState FrontendOccam) testRain :: String -> IO (Maybe String) -testRain source = do (result,_,_) <- runPassM (defaultState FrontendRain) compilation +testRain source = do (result,_) <- runPassM (defaultState FrontendRain) compilation return $ case result of Left (_,err) -> Just err Right _ -> Nothing diff --git a/common/TestUtils.hs b/common/TestUtils.hs index c1b7007..3296680 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -497,13 +497,13 @@ runPass :: (Data b, TestMonad m r) => Pass -> b -- ^ The actual pass. -> CompState -- ^ The state to use to run the pass. -> m (CompState, Either ErrorReport b) -- ^ The resultant state, and either an error or the successful outcome of the pass. -runPass actualPass src startState = liftM (\(x,y,_) -> (y,x)) $ +runPass actualPass src startState = liftM revPair $ runIO (runPassM startState $ passCode actualPass src) runPass' :: TestMonad m r => PassM b -> CompState -> m (CompState, Either ErrorReport b) runPass' actualPass startState - = runIO (runPassM startState actualPass) >>* \(x,y,_) -> (y,x) + = runIO (runPassM startState actualPass) >>* revPair -- | A test that runs a given AST pass and checks that it succeeds. testPass :: diff --git a/data/CompState.hs b/data/CompState.hs index 3257e89..8957c70 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -31,7 +31,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified AST as A -import Errors (Die, dieP, ErrorReport, Warn, WarningType(..), warnP) +import Errors (Die, dieP, ErrorReport, Warn, WarningType(..), warnP, WarningReport) import Metadata import OrdAST () import UnifyType @@ -125,7 +125,8 @@ data CompState = CompState { csParProcs :: Set A.Name, csUnifyLookup :: Map UnifyIndex UnifyValue, csUnifyPairs :: [(UnifyValue, UnifyValue)], - csUnifyId :: Int + csUnifyId :: Int, + csWarnings :: [WarningReport] } deriving (Data, Typeable) @@ -165,7 +166,8 @@ emptyState = CompState { csParProcs = Set.empty, csUnifyLookup = Map.empty, csUnifyPairs = [], - csUnifyId = 0 + csUnifyId = 0, + csWarnings = [] } -- | Class of monads which keep a CompState. diff --git a/pass/Pass.hs b/pass/Pass.hs index 4754179..0eb27e6 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -37,13 +37,14 @@ import TreeUtils import Utils -- | The monad in which AST-mangling passes operate. -type PassM = ErrorT ErrorReport (StateT CompState (StateT [WarningReport] IO)) +type PassM = ErrorT ErrorReport (StateT CompState IO) instance Die PassM where dieReport = throwError instance Warn PassM where - warnReport w = lift $ lift $ modify (++ [w]) + warnReport w = lift $ modify $ + \cs -> cs { csWarnings = csWarnings cs ++ [w] } -- | The type of a pass function. -- This is as generic as possible. Passes are used on 'A.AST' in normal use, @@ -81,12 +82,9 @@ instance Ord Property where instance Show Property where show = propName -runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState, [WarningReport]) +runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState) runPassM cs pass - = liftM flatten $ flip runStateT [] $ flip runStateT cs $ runErrorT pass - where - flatten :: ((a, b), c) -> (a, b, c) - flatten ((x, y), z) = (x, y, z) + = flip runStateT cs $ runErrorT pass enablePassesWhen :: (CompState -> Bool) -> [Pass] -> [Pass] enablePassesWhen f