Switched the Pass and Traversal modules over to Polyplate, breaking most of the other modules
This commit is contained in:
Neil Brown
parent
e78a30c231
commit
a3bcb32937
61
pass/Pass.hs
61
pass/Pass.hs
|
|
@ -23,6 +23,7 @@ import Control.Monad.Error
|
|||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Generics
|
||||
import Data.Generics.Polyplate
|
||||
import Data.List
|
||||
import Data.Ord
|
||||
import qualified Data.Set as Set
|
||||
|
|
@ -53,21 +54,35 @@ instance Warn PassM where
|
|||
-- 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
|
||||
-- against AST fragments of other types as well.
|
||||
type PassType = (forall s. Data s => s -> PassM s)
|
||||
type PassType t = t -> PassM t
|
||||
|
||||
type PassOnOps ops
|
||||
= (PolyplateM t ops () PassM, PolyplateM t () ops PassM) => Pass t
|
||||
|
||||
type PassASTOnOps ops
|
||||
= (PolyplateM A.AST ops () PassM, PolyplateM A.AST () ops PassM) => Pass A.AST
|
||||
|
||||
type PassTypeOnOps ops
|
||||
= (PolyplateM t ops () PassM, PolyplateM t () ops PassM) => PassType t
|
||||
|
||||
type PassOn t = PassOnOps (OneOpM PassM t)
|
||||
type PassOn2 s t = PassOnOps (TwoOpM PassM s t)
|
||||
type PassTypeOn t = PassTypeOnOps (OneOpM PassM t)
|
||||
|
||||
|
||||
-- | A description of an AST-mangling pass.
|
||||
data Pass = Pass {
|
||||
passCode :: PassType
|
||||
data Pass t = Pass {
|
||||
passCode :: PassType t
|
||||
, passName :: String
|
||||
, passPre :: Set.Set Property
|
||||
, passPost :: Set.Set Property
|
||||
, passEnabled :: CompState -> Bool
|
||||
}
|
||||
|
||||
instance Eq Pass where
|
||||
instance Eq (Pass t) where
|
||||
x == y = passName x == passName y
|
||||
|
||||
instance Ord Pass where
|
||||
instance Ord (Pass t) where
|
||||
compare = comparing passName
|
||||
|
||||
-- | A property that can be asserted and tested against the AST.
|
||||
|
|
@ -89,30 +104,17 @@ runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState)
|
|||
runPassM cs pass
|
||||
= flip runStateT cs $ runErrorT pass
|
||||
|
||||
enablePassesWhen :: (CompState -> Bool) -> [Pass] -> [Pass]
|
||||
enablePassesWhen :: (CompState -> Bool) -> [Pass A.AST] -> [Pass A.AST]
|
||||
enablePassesWhen f
|
||||
= map (\p -> p { passEnabled = \c -> f c && (passEnabled p c) })
|
||||
|
||||
-- | A helper to run a pass at the top-level, or deliver an error otherwise
|
||||
passOnlyOnAST :: forall t. Data t => String -> (A.AST -> PassM A.AST) -> t -> PassM t
|
||||
passOnlyOnAST name func x
|
||||
= case cast x :: Maybe A.AST of
|
||||
Nothing -> dieP emptyMeta $ name ++ " only operates at top-level"
|
||||
Just x' ->
|
||||
do y <- func x'
|
||||
case cast y :: Maybe t of
|
||||
Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level"
|
||||
Just y' -> return y'
|
||||
passOnlyOnAST :: String -> (A.AST -> PassM A.AST) -> (A.AST -> PassM A.AST)
|
||||
passOnlyOnAST name = id
|
||||
|
||||
-- For all functions of this type, do NOT use dollar before the pass.
|
||||
-- That is, do not write: pass "" [] [] $ some code
|
||||
-- On GHC 6.6 (without impredicative polymorphism from 6.8.1) this
|
||||
-- will force the RHS (some code) to become monomorphic, where in fact
|
||||
-- it needs to remain polymorphic. So just bracket the code for the
|
||||
-- pass instead, and everything will be fine
|
||||
type PassMaker = String -> [Property] -> [Property] -> PassType -> Pass
|
||||
type PassMaker t = String -> [Property] -> [Property] -> PassType t -> Pass t
|
||||
|
||||
passMakerHelper :: (CompState -> Bool) -> PassMaker
|
||||
passMakerHelper :: (CompState -> Bool) -> PassMaker t
|
||||
passMakerHelper f name pre post code
|
||||
= Pass { passCode = code
|
||||
, passName = name
|
||||
|
|
@ -121,30 +123,27 @@ passMakerHelper f name pre post code
|
|||
, passEnabled = f
|
||||
}
|
||||
|
||||
rainOnlyPass :: PassMaker
|
||||
rainOnlyPass :: PassMaker t
|
||||
rainOnlyPass = passMakerHelper $ (== FrontendRain) . csFrontend
|
||||
|
||||
occamOnlyPass :: PassMaker
|
||||
occamOnlyPass :: PassMaker t
|
||||
occamOnlyPass = passMakerHelper $ (== FrontendOccam) . csFrontend
|
||||
|
||||
occamAndCOnlyPass :: PassMaker
|
||||
occamAndCOnlyPass = passMakerHelper $
|
||||
\st -> (csFrontend st == FrontendOccam) && (csBackend st == BackendC)
|
||||
|
||||
cOnlyPass :: PassMaker
|
||||
cOnlyPass :: PassMaker t
|
||||
cOnlyPass = passMakerHelper $ (== BackendC) . csBackend
|
||||
|
||||
cppOnlyPass :: PassMaker
|
||||
cppOnlyPass :: PassMaker t
|
||||
cppOnlyPass = passMakerHelper $ (== BackendCPPCSP) . csBackend
|
||||
|
||||
cOrCppOnlyPass :: PassMaker
|
||||
cOrCppOnlyPass = passMakerHelper $ (`elem` [BackendC, BackendCPPCSP]) . csBackend
|
||||
|
||||
pass :: PassMaker
|
||||
pass = passMakerHelper (const True)
|
||||
|
||||
-- | Compose a list of passes into a single pass by running them in the order given.
|
||||
runPasses :: [Pass] -> (A.AST -> PassM A.AST)
|
||||
runPasses :: [Pass A.AST] -> (A.AST -> PassM A.AST)
|
||||
runPasses [] ast = return ast
|
||||
runPasses (p:ps) ast
|
||||
= do debug $ "{{{ " ++ passName p
|
||||
|
|
|
|||
|
|
@ -18,32 +18,24 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
||||
-- | Traversal strategies over the AST and other data types.
|
||||
module Traversal (
|
||||
OpsM, Ops
|
||||
, TransformM, Transform
|
||||
TransformM, Transform
|
||||
, CheckM, Check
|
||||
, baseOp, extOp, extOpS
|
||||
, makeDepth, extOpD, extOpSD
|
||||
, makeCheck, extOpC
|
||||
, RecurseM, Recurse, makeRecurse
|
||||
, DescendM, Descend, makeDescend
|
||||
, applyDepthM, applyDepthSM, applyDepthM2
|
||||
, checkDepthM, checkDepthM2
|
||||
, fastListify
|
||||
, ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS
|
||||
, module Data.Generics.Polyplate
|
||||
, module Data.Generics.Polyplate.Schemes
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import Data.Generics.Polyplate
|
||||
import Data.Generics.Polyplate.Schemes
|
||||
|
||||
|
||||
import qualified AST as A
|
||||
import GenericUtils
|
||||
import NavAST
|
||||
import Pass
|
||||
|
||||
-- | A set of generic operations.
|
||||
type OpsM m = ([TypeKey], TypeSet, DescendM m -> RecurseM m)
|
||||
|
||||
-- | As 'OpsM', but specialised for 'PassM'.
|
||||
type Ops = OpsM PassM
|
||||
|
||||
-- | A transformation for a single 'Data' type.
|
||||
type TransformM m t = t -> m t
|
||||
|
||||
|
|
@ -58,157 +50,48 @@ type CheckM m t = t -> m ()
|
|||
-- | As 'CheckM', but specialised for 'PassM'.
|
||||
type Check t = CheckM PassM t
|
||||
|
||||
-- | An empty set of operations.
|
||||
baseOp :: forall m. Monad m => OpsM m
|
||||
baseOp = ([], makeTypeSet [], id)
|
||||
type ExtOpMP opT t = ExtOpM PassM opT t
|
||||
|
||||
-- | Add a 'TransformM' to a set, to be applied with explicit descent
|
||||
-- (that is, the transform will be responsible for recursing into child
|
||||
-- elements itself).
|
||||
extOp :: forall m t. (Monad m, Data t) => OpsM m -> TransformM m t -> OpsM m
|
||||
extOp (tks, _, g) f
|
||||
= (tks',
|
||||
makeTypeSet tks',
|
||||
(\descend -> g descend `extM` f))
|
||||
where
|
||||
tks' = typeKey (undefined :: t) : tks
|
||||
type ExtOpMS m opT =
|
||||
(A.Structured () -> m (A.Structured ()),
|
||||
(A.Structured A.Alternative -> m (A.Structured A.Alternative),
|
||||
(A.Structured A.Choice -> m (A.Structured A.Choice),
|
||||
(A.Structured A.ExpressionList -> m (A.Structured A.ExpressionList),
|
||||
(A.Structured A.Option -> m (A.Structured A.Option),
|
||||
(A.Structured A.Process -> m (A.Structured A.Process),
|
||||
(A.Structured A.Variant -> m (A.Structured A.Variant),
|
||||
opT)))))))
|
||||
type ExtOpMSP opT = ExtOpMS PassM opT
|
||||
|
||||
-- | As 'extOp', but for transformations that work on all 'A.Structured' types.
|
||||
extOpS :: forall m. Monad m =>
|
||||
OpsM m
|
||||
-> (forall t. Data t => TransformM m (A.Structured t))
|
||||
-> OpsM m
|
||||
extOpS ops f
|
||||
extOpMS :: forall m opT op0T.
|
||||
(PolyplateM (A.Structured ()) () op0T m,
|
||||
PolyplateM (A.Structured A.Alternative) () op0T m,
|
||||
PolyplateM (A.Structured A.Choice) () op0T m,
|
||||
PolyplateM (A.Structured A.ExpressionList) () op0T m,
|
||||
PolyplateM (A.Structured A.Option) () op0T m,
|
||||
PolyplateM (A.Structured A.Process) () op0T m,
|
||||
PolyplateM (A.Structured A.Variant) () op0T m,
|
||||
PolyplateM (A.Structured ()) op0T () m,
|
||||
PolyplateM (A.Structured A.Alternative) op0T () m,
|
||||
PolyplateM (A.Structured A.Choice) op0T () m,
|
||||
PolyplateM (A.Structured A.ExpressionList) op0T () m,
|
||||
PolyplateM (A.Structured A.Option) op0T () m,
|
||||
PolyplateM (A.Structured A.Process) op0T () m,
|
||||
PolyplateM (A.Structured A.Variant) op0T () m) =>
|
||||
opT ->
|
||||
-- Pairing the next two arguments allows us to apply this function infix:
|
||||
(op0T, -- just a type witness
|
||||
forall t. (Data t, PolyplateM (A.Structured t) () op0T m
|
||||
, PolyplateM (A.Structured t) op0T () m) =>
|
||||
A.Structured t -> m (A.Structured t)) ->
|
||||
ExtOpMS m opT
|
||||
extOpMS ops (_, f)
|
||||
= ops
|
||||
`extOp` (f :: TransformM m (A.Structured A.Variant))
|
||||
`extOp` (f :: TransformM m (A.Structured A.Process))
|
||||
`extOp` (f :: TransformM m (A.Structured A.Option))
|
||||
`extOp` (f :: TransformM m (A.Structured A.ExpressionList))
|
||||
`extOp` (f :: TransformM m (A.Structured A.Choice))
|
||||
`extOp` (f :: TransformM m (A.Structured A.Alternative))
|
||||
`extOp` (f :: TransformM m (A.Structured ()))
|
||||
`extOpM` (f :: A.Structured A.Variant -> m (A.Structured A.Variant))
|
||||
`extOpM` (f :: A.Structured A.Process -> m (A.Structured A.Process))
|
||||
`extOpM` (f :: A.Structured A.Option -> m (A.Structured A.Option))
|
||||
`extOpM` (f :: A.Structured A.ExpressionList -> m (A.Structured A.ExpressionList))
|
||||
`extOpM` (f :: A.Structured A.Choice -> m (A.Structured A.Choice))
|
||||
`extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative))
|
||||
`extOpM` (f :: A.Structured () -> m (A.Structured ()))
|
||||
|
||||
-- | Generate an operation that applies a 'TransformM' with automatic
|
||||
-- depth-first descent.
|
||||
makeDepth :: forall m t. (Monad m, Data t) =>
|
||||
OpsM m -> TransformM m t -> TransformM m t
|
||||
makeDepth ops f v = descend v >>= f
|
||||
where
|
||||
descend :: DescendM m
|
||||
descend = makeDescend ops
|
||||
|
||||
-- | Add a 'TransformM' to a set, to be applied with automatic depth-first
|
||||
-- descent.
|
||||
extOpD :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> TransformM m t -> OpsM m
|
||||
extOpD ops ops0 f = ops `extOp` (makeDepth ops0 f)
|
||||
|
||||
-- | As 'extOpD', but for transformations that work on all 'A.Structured' types.
|
||||
extOpSD :: forall m. Monad m =>
|
||||
OpsM m
|
||||
-> OpsM m
|
||||
-> (forall t. Data t => TransformM m (A.Structured t))
|
||||
-> OpsM m
|
||||
extOpSD ops ops0 f = ops `extOpS` (makeDepth ops0 f)
|
||||
|
||||
-- | Generate an operation that applies a 'CheckM' with automatic
|
||||
-- depth-first descent.
|
||||
makeCheck :: forall m t. (Monad m, Data t) =>
|
||||
OpsM m -> CheckM m t -> TransformM m t
|
||||
makeCheck ops f v = descend v >> f v >> return v
|
||||
where
|
||||
descend :: DescendM m
|
||||
descend = makeDescend ops
|
||||
|
||||
-- | Add a 'CheckM' to a set, to be applied with automatic depth-first descent.
|
||||
extOpC :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> CheckM m t -> OpsM m
|
||||
extOpC ops ops0 f = ops `extOp` (makeCheck ops0 f)
|
||||
|
||||
-- | A function that applies a generic operation.
|
||||
-- This applies the operations in the set to the provided value.
|
||||
--
|
||||
-- This is the type of function that you want to use to apply a generic
|
||||
-- operation; a pass in Tock is usually the application of a 'RecurseM' to the
|
||||
-- AST. It's also what you should use when you're writing a pass that uses
|
||||
-- explicit descent, and you want to explicitly recurse into one of the
|
||||
-- children of a value that one of your transformations has been applied to.
|
||||
type RecurseM m = (forall t. Data t => t -> m t)
|
||||
|
||||
-- | As 'RecurseM', but specialised for 'PassM'.
|
||||
type Recurse = RecurseM PassM
|
||||
|
||||
-- | Build a 'RecurseM' function from a set of operations.
|
||||
makeRecurse :: forall m. Monad m => OpsM m -> RecurseM m
|
||||
makeRecurse ops@(_, _, f) = f descend
|
||||
where
|
||||
descend :: DescendM m
|
||||
descend = makeDescend ops
|
||||
|
||||
-- | A function that applies a generic operation.
|
||||
-- This applies the operations in the set to the immediate children of the
|
||||
-- provided value, but not to the value itself.
|
||||
--
|
||||
-- You should use this type of operation when you're writing a traversal with
|
||||
-- explicit descent, and you want to descend into all the children of a value
|
||||
-- that one of your transformations has been applied to.
|
||||
type DescendM m = (forall t. Data t => t -> m t)
|
||||
|
||||
-- | As 'DescendM', but specialised for 'PassM'.
|
||||
type Descend = DescendM PassM
|
||||
|
||||
-- | Build a 'DescendM' function from a set of operations.
|
||||
makeDescend :: forall m. Monad m => OpsM m -> DescendM m
|
||||
makeDescend ops@(_, ts, _) = gmapMFor ts recurse
|
||||
where
|
||||
recurse :: RecurseM m
|
||||
recurse = makeRecurse ops
|
||||
|
||||
-- | Apply a transformation, recursing depth-first.
|
||||
applyDepthM :: forall m t1. (Monad m, Data t1) =>
|
||||
TransformM m t1 -> (forall s. Data s => s -> m s)
|
||||
applyDepthM f1 = makeRecurse ops
|
||||
where
|
||||
ops :: OpsM m
|
||||
ops = baseOp `extOp` makeDepth ops f1
|
||||
|
||||
-- | As 'applyDepthM', but for transformations that work on all 'A.Structured'
|
||||
-- types.
|
||||
applyDepthSM :: forall m s. (Monad m, Data s) =>
|
||||
(forall t. Data t => TransformM m (A.Structured t)) -> s -> m s
|
||||
applyDepthSM f1 = makeRecurse ops
|
||||
where
|
||||
ops :: OpsM m
|
||||
ops = extOpSD baseOp ops f1
|
||||
|
||||
-- | Apply two transformations, recursing depth-first.
|
||||
applyDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
|
||||
TransformM m t1 -> TransformM m t2 -> s -> m s
|
||||
applyDepthM2 f1 f2 = makeRecurse ops
|
||||
where
|
||||
ops :: OpsM m
|
||||
ops = baseOp `extOp` makeDepth ops f1
|
||||
`extOp` makeDepth ops f2
|
||||
|
||||
-- | Apply a check, recursing depth-first.
|
||||
checkDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
|
||||
CheckM m t1 -> s -> m s
|
||||
checkDepthM f1 = makeRecurse ops
|
||||
where
|
||||
ops :: OpsM m
|
||||
ops = baseOp `extOp` makeCheck ops f1
|
||||
|
||||
-- | Apply two checks, recursing depth-first.
|
||||
checkDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
|
||||
CheckM m t1 -> CheckM m t2 -> s -> m s
|
||||
checkDepthM2 f1 f2 = makeRecurse ops
|
||||
where
|
||||
ops :: OpsM m
|
||||
ops = baseOp `extOp` makeCheck ops f1
|
||||
`extOp` makeCheck ops f2
|
||||
|
||||
-- | Lists all the items (in arbitrary order) that meet the given criteria. Just
|
||||
-- like the Data.Generics listify function, only faster
|
||||
fastListify :: forall s t. (Data s, Data t) => (t -> Bool) -> s -> [t]
|
||||
fastListify f x = execState (applyDepthM f' x) []
|
||||
where
|
||||
f' :: t -> State [t] t
|
||||
f' y = when (f y) (modify (y:)) >> return y
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user