From 7525138c9624c6cf63a01697ae7c0fd0e49f5c92 Mon Sep 17 00:00:00 2001
From: Adam Sampson <ats@offog.org>
Date: Tue, 1 Apr 2008 12:01:09 +0000
Subject: [PATCH] Defined types for tree traversals, and moved them to their
 own file.

We now have three kinds of canned tree traversals, all of which are smart about
which types they're applied to: explicit-descent transformations,
implicit-descent transformations, and implicit-descent checks. I've only
provided depth-first application of the latter two, but we could do
breadth-first in the future if necessary.
---
 Makefile.am              |  1 +
 frontends/OccamPasses.hs |  1 +
 frontends/OccamTypes.hs  | 26 ++++++-----
 frontends/RainTypes.hs   |  1 +
 pass/Pass.hs             | 38 ----------------
 pass/Traversal.hs        | 95 ++++++++++++++++++++++++++++++++++++++++
 6 files changed, 112 insertions(+), 50 deletions(-)
 create mode 100644 pass/Traversal.hs

diff --git a/Makefile.am b/Makefile.am
index 16bafbe..cd07b58 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -116,6 +116,7 @@ tock_SOURCES_hs += frontends/StructureOccam.hs
 tock_SOURCES_hs += pass/Pass.hs
 tock_SOURCES_hs += pass/PassList.hs
 tock_SOURCES_hs += pass/Properties.hs
+tock_SOURCES_hs += pass/Traversal.hs
 tock_SOURCES_hs += transformations/SimplifyComms.hs
 tock_SOURCES_hs += transformations/SimplifyExprs.hs
 tock_SOURCES_hs += transformations/SimplifyProcs.hs
diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs
index 003cca9..e669c9d 100644
--- a/frontends/OccamPasses.hs
+++ b/frontends/OccamPasses.hs
@@ -31,6 +31,7 @@ import OccamTypes
 import Pass
 import qualified Properties as Prop
 import ShowCode
+import Traversal
 import Types
 
 -- | Occam-specific frontend passes.
diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs
index ad0c0ba..0022c0e 100644
--- a/frontends/OccamTypes.hs
+++ b/frontends/OccamTypes.hs
@@ -32,6 +32,7 @@ import Intrinsics
 import Metadata
 import Pass
 import ShowCode
+import Traversal
 import Types
 
 -- | A successful check.
@@ -162,11 +163,11 @@ checkExpressionType :: A.Type -> A.Expression -> PassM ()
 checkExpressionType et e = typeOfExpression e >>= checkType (findMeta e) et
 
 -- | Check that an expression is of integer type.
-checkExpressionInt :: A.Expression -> PassM ()
+checkExpressionInt :: Check A.Expression
 checkExpressionInt e = checkExpressionType A.Int e
 
 -- | Check that an expression is of boolean type.
-checkExpressionBool :: A.Expression -> PassM ()
+checkExpressionBool :: Check A.Expression
 checkExpressionBool e = checkExpressionType A.Bool e
 
 --}}}
@@ -293,6 +294,7 @@ checkAbbrev m orig new
         (A.ValAbbrev, _) -> bad
         _ -> ok
   where
+    bad :: PassM ()
     bad = dieP m $ "You can't abbreviate " ++ showAM orig ++ " as " ++ showAM new
 
     showAM :: A.AbbrevMode -> String
@@ -360,7 +362,7 @@ checkAllocMobile m rawT me
             _ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t
 
 -- | Check that a variable is writable.
-checkWritable :: A.Variable -> PassM ()
+checkWritable :: Check A.Variable
 checkWritable v
     =  do am <- abbrevModeOfVariable v
           case am of
@@ -478,7 +480,7 @@ checkNamesDistinct m ns
     dupes = nub (ns \\ nub ns)
 
 -- | Check a 'Replicator'.
-checkReplicator :: A.Replicator -> PassM ()
+checkReplicator :: Check A.Replicator
 checkReplicator (A.For _ _ start count)
     =  do checkExpressionInt start
           checkExpressionInt count
@@ -489,7 +491,7 @@ checkReplicator (A.ForEach _ _ e)
 -- | Check a 'Structured', applying the given check to each item found inside
 -- it. This assumes that processes and specifications will be checked
 -- elsewhere.
-checkStructured :: Data t => (t -> PassM ()) -> A.Structured t -> PassM ()
+checkStructured :: Data t => Check t -> Check (A.Structured t)
 checkStructured doInner (A.Rep _ rep s)
     = checkReplicator rep >> checkStructured doInner s
 checkStructured doInner (A.Spec _ spec s)
@@ -552,7 +554,7 @@ checkTypes t =
 checkVariables :: Data t => t -> PassM t
 checkVariables = checkDepthM doVariable
   where
-    doVariable :: A.Variable -> PassM ()
+    doVariable :: Check A.Variable
     doVariable (A.SubscriptedVariable m s v)
         =  do t <- typeOfVariable v
               checkSubscript m s t
@@ -574,7 +576,7 @@ checkVariables = checkDepthM doVariable
 checkExpressions :: Data t => t -> PassM t
 checkExpressions = checkDepthM doExpression
   where
-    doExpression :: A.Expression -> PassM ()
+    doExpression :: Check A.Expression
     doExpression (A.Monadic _ op e) = checkMonadicOp op e
     doExpression (A.Dyadic _ op le re) = checkDyadicOp op le re
     doExpression (A.MostPos m t) = checkNumeric m t
@@ -629,7 +631,7 @@ checkExpressions = checkDepthM doExpression
 checkSpecTypes :: Data t => t -> PassM t
 checkSpecTypes = checkDepthM doSpecType
   where
-    doSpecType :: A.SpecType -> PassM ()
+    doSpecType :: Check A.SpecType
     doSpecType (A.Place _ e) = checkExpressionInt e
     doSpecType (A.Declaration _ _) = ok
     doSpecType (A.Is m am t v)
@@ -700,7 +702,7 @@ checkSpecTypes = checkDepthM doSpecType
         =  do fromT <- typeOfExpression e
               checkRetypes m fromT t
 
-    unexpectedAM :: Meta -> PassM ()
+    unexpectedAM :: Check Meta
     unexpectedAM m = dieP m "Unexpected abbreviation mode"
 
 --}}}
@@ -709,7 +711,7 @@ checkSpecTypes = checkDepthM doSpecType
 checkProcesses :: Data t => t -> PassM t
 checkProcesses = checkDepthM doProcess
   where
-    doProcess :: A.Process -> PassM ()
+    doProcess :: Check A.Process
     doProcess (A.Assign m vs el)
         =  do vts <- mapM (typeOfVariable) vs
               mapM_ checkWritable vs
@@ -748,7 +750,7 @@ checkProcesses = checkDepthM doProcess
                  checkActuals m (A.Name m A.ProcName n) fs as
             Nothing -> dieP m $ n ++ " is not an intrinsic procedure"
 
-    doAlternative :: A.Alternative -> PassM ()
+    doAlternative :: Check A.Alternative
     doAlternative (A.Alternative m v im _)
         = case im of
             A.InputTimerRead _ _ ->
@@ -760,7 +762,7 @@ checkProcesses = checkDepthM doProcess
     doAlternative (A.AlternativeSkip _ e _)
         = checkExpressionBool e
 
-    doChoice :: A.Choice -> PassM ()
+    doChoice :: Check A.Choice
     doChoice (A.Choice _ e _) = checkExpressionBool e
 
     doInput :: A.Variable -> A.InputMode -> PassM ()
diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs
index 95c674b..229b562 100644
--- a/frontends/RainTypes.hs
+++ b/frontends/RainTypes.hs
@@ -28,6 +28,7 @@ import EvalConstants
 import Metadata
 import Pass
 import ShowCode
+import Traversal
 import Types
 
 
diff --git a/pass/Pass.hs b/pass/Pass.hs
index 5d48bd0..8dd886f 100644
--- a/pass/Pass.hs
+++ b/pass/Pass.hs
@@ -28,7 +28,6 @@ import System.IO
 import qualified AST as A
 import CompState
 import Errors
-import GenericUtils
 import Metadata
 import PrettyShow
 import TreeUtils
@@ -150,7 +149,6 @@ runPasses (p:ps) ast
           debug $ "}}}"
           runPasses ps ast'
 
-
 -- | Print a message if above the given verbosity level.
 verboseMessage :: (CSM m, MonadIO m) => Int -> String -> m ()
 verboseMessage n s
@@ -195,42 +193,6 @@ makeGeneric top
         `extM` (return :: String -> m String)
         `extM` (return :: Meta -> m Meta)
 
--- | Apply a monadic operation everywhere that it matches, going depth-first.
-applyDepthM :: forall a t. (Data a, Data t) => (a -> PassM a) -> t -> PassM t
-applyDepthM f = doGeneric `extM` (doSpecific f)
-  where
-    doGeneric :: Data t1 => t1 -> PassM t1
-    doGeneric = gmapMFor (undefined :: a) (applyDepthM f)
-
-    doSpecific :: Data t2 => (t2 -> PassM t2) -> t2 -> PassM t2
-    doSpecific f x = (doGeneric x >>= f)
-
--- | Apply two monadic operations everywhere they match in the AST, going
--- depth-first.
-applyDepthM2 :: forall a b t. (Data a, Data b, Data t) =>
-                  (a -> PassM a) -> (b -> PassM b) -> t -> PassM t
-applyDepthM2 f1 f2 = doGeneric `extM` (doSpecific f1) `extM` (doSpecific f2)
-  where
-    doGeneric :: Data t1 => t1 -> PassM t1
-    doGeneric = gmapMFor2 (undefined :: a) (undefined :: b) (applyDepthM2 f1 f2)
-
-    doSpecific :: Data t2 => (t2 -> PassM t2) -> t2 -> PassM t2
-    doSpecific f x = (doGeneric x >>= f)
-
--- | Apply a check (a monadic operation that returns nothing, but can succeed
--- or fail) everywhere it matches in the AST, going depth-first.
-checkDepthM :: forall a t. (Data a, Data t) => (a -> PassM ()) -> t -> PassM t
-checkDepthM f = doGeneric `extM` (doSpecific f)
-  where
-    doGeneric :: Data t1 => t1 -> PassM t1
-    doGeneric = gmapMFor (undefined :: a) (checkDepthM f)
-
-    doSpecific :: Data t2 => (t2 -> PassM ()) -> t2 -> PassM t2
-    doSpecific f x
-        =  do x' <- doGeneric x
-              f x'
-              return x'
-
 excludeConstr :: (Data a, CSMR m) => [Constr] -> a -> m a
 excludeConstr cons x 
   = if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x)
diff --git a/pass/Traversal.hs b/pass/Traversal.hs
new file mode 100644
index 0000000..c5cddf1
--- /dev/null
+++ b/pass/Traversal.hs
@@ -0,0 +1,95 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2008  University of Kent
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation, either version 2 of the License, or (at your
+option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License along
+with this program.  If not, see <http://www.gnu.org/licenses/>.
+-}
+
+-- | Traversal strategies over the AST and other data types.
+module Traversal (
+    ExplicitTrans, Transform, Check
+  , transformToExplicitDepth, checkToTransform
+  , applyExplicitM, applyExplicitM2
+  , applyDepthM, applyDepthM2
+  , checkDepthM
+  ) where
+
+import Data.Generics
+
+import GenericUtils
+import Pass
+
+-- | A transformation for a single 'Data' type with explicit descent.
+-- The first argument passed is a function that can be called to explicitly
+-- descend into a generic value.
+type ExplicitTrans t = Data t =>
+                       (forall s. Data s => s -> PassM s) -> t -> PassM t
+
+-- | A transformation for a single 'Data' type with implicit descent.
+-- This can be applied recursively throughout a data structure.
+type Transform t = Data t => t -> PassM t
+
+-- | A check for a single 'Data' type with implicit descent.
+-- This is like 'Transform', but it doesn't change the value; it may fail or
+-- modify the state, though.
+type Check t = Data t => t -> PassM ()
+
+-- | Make an 'ExplicitTrans' that applies a 'Transform', recursing depth-first.
+transformToExplicitDepth :: Data t => Transform t -> ExplicitTrans t
+transformToExplicitDepth f descend x = descend x >>= f
+
+-- | Make a 'Transform' that applies a 'Check'.
+checkToTransform :: Data t => Check t -> Transform t
+checkToTransform f x = f x >> return x
+
+-- | Apply an explicit transformation.
+applyExplicitM :: forall t1 s. (Data t1, Data s) =>
+                  ExplicitTrans t1 -> s -> PassM s
+applyExplicitM f1 = doGeneric `extM` (doSpecific f1)
+  where
+    doGeneric :: Data t => t -> PassM t
+    doGeneric = gmapMFor (undefined :: t1) (applyExplicitM f1)
+
+    doSpecific :: Data t => ExplicitTrans t -> t -> PassM t
+    doSpecific f x = f doGeneric x
+
+-- | Apply two explicit transformations.
+applyExplicitM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) =>
+                   ExplicitTrans t1 -> ExplicitTrans t2 -> s -> PassM s
+applyExplicitM2 f1 f2 = doGeneric `extM` (doSpecific f1)
+                               `extM` (doSpecific f2)
+  where
+    doGeneric :: Data t => t -> PassM t
+    doGeneric = gmapMFor2 (undefined :: t1) (undefined :: t2)
+                          (applyExplicitM2 f1 f2)
+
+    doSpecific :: Data t => ExplicitTrans t -> t -> PassM t
+    doSpecific f x = f doGeneric x
+
+-- | Apply a transformation, recursing depth-first.
+applyDepthM :: forall t1 s. (Data t1, Data s) =>
+               Transform t1 -> s -> PassM s
+applyDepthM f = applyExplicitM (transformToExplicitDepth f)
+
+-- | Apply two transformations, recursing depth-first.
+applyDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) =>
+                Transform t1 -> Transform t2 -> s -> PassM s
+applyDepthM2 f1 f2 = applyExplicitM2 (transformToExplicitDepth f1)
+                                     (transformToExplicitDepth f2)
+
+-- | Apply a check, recursing depth-first.
+checkDepthM :: forall t1 s. (Data t1, Data s) =>
+               Check t1 -> s -> PassM s
+checkDepthM f = applyDepthM (checkToTransform f)
+