Removed all the PassR and PassMR stuff, now we just have Pass and PassM

This commit is contained in:
Neil Brown 2008-06-03 16:30:10 +00:00
parent 21329287e2
commit 9066d4112b
3 changed files with 12 additions and 30 deletions

View File

@ -44,7 +44,7 @@ import UsageCheckAlgorithms
import UsageCheckUtils import UsageCheckUtils
import Utils import Utils
usageCheckPass :: A.AST -> PassMR A.AST usageCheckPass :: A.AST -> PassM A.AST
usageCheckPass t = do g' <- buildFlowGraph labelFunctions t usageCheckPass t = do g' <- buildFlowGraph labelFunctions t
(g, roots) <- case g' of (g, roots) <- case g' of
Left err -> dieP (findMeta t) err Left err -> dieP (findMeta t) err

View File

@ -20,11 +20,11 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module Pass where module Pass where
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer import Control.Monad.Writer
import Data.Generics import Data.Generics
import Data.List import Data.List
import Data.Ord
import qualified Data.Set as Set import qualified Data.Set as Set
import System.IO import System.IO
@ -38,20 +38,13 @@ import Utils
-- | The monad in which AST-mangling passes operate. -- | The monad in which AST-mangling passes operate.
type PassM = ErrorT ErrorReport (StateT CompState (StateT [WarningReport] IO)) type PassM = ErrorT ErrorReport (StateT CompState (StateT [WarningReport] IO))
type PassMR = ErrorT ErrorReport (ReaderT CompState (StateT [WarningReport] IO))
instance Die PassM where instance Die PassM where
dieReport = throwError dieReport = throwError
instance Die PassMR where
dieReport = throwError
instance Warn PassM where instance Warn PassM where
warnReport w = lift $ lift $ modify (++ [w]) warnReport w = lift $ lift $ modify (++ [w])
instance Warn PassMR where
warnReport w = lift $ lift $ modify (++ [w])
-- | The type of a pass function. -- | The type of a pass function.
-- This is as generic as possible. Passes are used on 'A.AST' in normal use, -- This is as generic as possible. Passes are used on 'A.AST' in normal use,
-- but for explicit descent and testing it's useful to be able to run them -- but for explicit descent and testing it's useful to be able to run them
@ -59,46 +52,35 @@ instance Warn PassMR where
type PassType = (forall s. Data s => s -> PassM s) type PassType = (forall s. Data s => s -> PassM s)
-- | A description of an AST-mangling pass. -- | A description of an AST-mangling pass.
data Monad m => Pass_ m = Pass { data Pass = Pass {
passCode :: PassType passCode :: PassType
, passName :: String , passName :: String
, passPre :: Set.Set Property , passPre :: Set.Set Property
, passPost :: Set.Set Property , passPost :: Set.Set Property
, passEnabled :: CompState -> Bool , passEnabled :: CompState -> Bool
} }
instance Monad m => Eq (Pass_ m) where instance Eq Pass where
x == y = passName x == passName y x == y = passName x == passName y
instance Monad m => Ord (Pass_ m) where instance Ord Pass where
compare x y = compare (passName x) (passName y) compare = comparing passName
type Pass = Pass_ PassM
type PassR = Pass_ PassMR
-- | A property that can be asserted and tested against the AST. -- | A property that can be asserted and tested against the AST.
data Property = Property { data Property = Property {
propName :: String propName :: String
, propCheck :: A.AST -> PassMR () , propCheck :: A.AST -> PassM ()
} }
instance Eq Property where instance Eq Property where
x == y = propName x == propName y x == y = propName x == propName y
instance Ord Property where instance Ord Property where
compare x y = compare (propName x) (propName y) compare = comparing propName
instance Show Property where instance Show Property where
show = propName show = propName
runPassR :: (A.AST -> PassMR A.AST) -> (A.AST -> PassM A.AST)
runPassR p t
= do st <- get
(r, w) <- liftIO $ flip runStateT [] $ runReaderT (runErrorT (p t)) st
case r of
Left err -> throwError err
Right result -> mapM_ warnReport w >> return result
runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState, [WarningReport]) runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState, [WarningReport])
runPassM cs pass runPassM cs pass
= liftM flatten $ flip runStateT [] $ flip runStateT cs $ runErrorT pass = liftM flatten $ flip runStateT [] $ flip runStateT cs $ runErrorT pass

View File

@ -51,7 +51,7 @@ commonPasses opts = concat $
[ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes [ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes
, enablePassesWhen csUsageChecking , enablePassesWhen csUsageChecking
[pass "Usage checking" Prop.agg_namesDone [Prop.parUsageChecked] [pass "Usage checking" Prop.agg_namesDone [Prop.parUsageChecked]
(passOnlyOnAST "usageCheckPass" $ runPassR usageCheckPass)] (passOnlyOnAST "usageCheckPass" usageCheckPass)]
-- If usage checking is turned off, the pass list will break unless we insert this dummy item: -- If usage checking is turned off, the pass list will break unless we insert this dummy item:
, enablePassesWhen (not . csUsageChecking) , enablePassesWhen (not . csUsageChecking)
[pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked] [pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked]
@ -122,10 +122,10 @@ calculatePassList
checks = [pass ("[" ++ propName prop ++ "]") checks = [pass ("[" ++ propName prop ++ "]")
[] []
[] []
(passOnlyOnAST "prop" $ runPassR $ checkProp prop) (passOnlyOnAST "prop" $ checkProp prop)
| prop <- Set.toList props] | prop <- Set.toList props]
checkProp :: Property -> A.AST -> PassMR A.AST checkProp :: Property -> A.AST -> PassM A.AST
checkProp prop ast = propCheck prop ast >> return ast checkProp prop ast = propCheck prop ast >> return ast
-- | If something isn't right, it gives back a list containing a single pass -- | If something isn't right, it gives back a list containing a single pass