Removed all the PassR and PassMR stuff, now we just have Pass and PassM
This commit is contained in:
parent
21329287e2
commit
9066d4112b
|
@ -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
|
||||||
|
|
34
pass/Pass.hs
34
pass/Pass.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue
Block a user