Make applyToOnly more general, and use it in more places.

This simplifies several bits of code that are doing things with Structureds.

backends/BackendPasses.hs

@@ -50,7 +50,7 @@ transformWaitFor = applyDepthM doAlt
   where
     doAlt :: A.Process -> PassM A.Process
     doAlt a@(A.Alt m pri s)
-      = do (s',(specs,code)) <- runStateT (applyToOnly doWaitFor s) ([],[])
+      = do (s',(specs,code)) <- runStateT (transformOnly doWaitFor s) ([],[])
            if (null specs && null code)
              then return a
              else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.Only m $ A.Alt m pri s'])) specs
@@ -59,8 +59,8 @@ transformWaitFor = applyDepthM doAlt
     addSpec :: Data a => (A.Structured a -> A.Structured a) -> A.Structured a -> A.Structured a
     addSpec spec inner = spec inner
 
-    doWaitFor :: A.Alternative -> StateT ([A.Structured A.Process -> A.Structured A.Process], [A.Structured A.Process]) PassM A.Alternative
+    doWaitFor :: Meta -> A.Alternative -> StateT ([A.Structured A.Process -> A.Structured A.Process], [A.Structured A.Process]) PassM (A.Structured A.Alternative)
-    doWaitFor a@(A.Alternative m cond tim (A.InputTimerFor m' e) p)
+    doWaitFor m'' a@(A.Alternative m cond tim (A.InputTimerFor m' e) p)
       = do (specs, init) <- get
            id <- lift $ makeNonce "waitFor"
            let n = (A.Name m A.VariableName id)
@@ -69,9 +69,9 @@ transformWaitFor = applyDepthM doAlt
                 init ++ [A.Only m $ A.Input m tim
                            (A.InputTimerRead m (A.InVariable m var)),
                          A.Only m $ A.Assign m [var] $ A.ExpressionList m [A.Dyadic m A.Plus (A.ExprVariable m var) e]])
-           return $ A.Alternative m cond tim (A.InputTimerAfter m' (A.ExprVariable m' var)) p
+           return $ A.Only m'' $ A.Alternative m cond tim (A.InputTimerAfter m' (A.ExprVariable m' var)) p
                
-    doWaitFor a = return a
+    doWaitFor m a = return $ A.Only m a
 
 append_sizes :: A.Name -> A.Name
 append_sizes n = n {A.nameName = A.nameName n ++ "_sizes"}

frontends/OccamTypes.hs

@@ -516,29 +516,15 @@ checkNamesDistinct m ns
     dupes :: [A.Name]
     dupes = nub (ns \\ nub ns)
 
--- | Check a 'Replicator'.
-checkReplicator :: Check A.Replicator
-checkReplicator (A.For _ _ start count)
-    =  do checkExpressionInt start
-          checkExpressionInt count
-checkReplicator (A.ForEach _ _ e)
-    =  do t <- astTypeOf e
-          checkSequence (findMeta e) t
-
 -- | 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 => Check t -> Check (A.Structured t)
-checkStructured doInner (A.Rep _ rep s)
+checkStructured doInner s = transformOnly checkInner s >> return ()
-    = checkReplicator rep >> checkStructured doInner s
+  where
-checkStructured doInner (A.Spec _ spec s)
+    checkInner m v
-    = checkStructured doInner s
+      =  do doInner v
-checkStructured doInner (A.ProcThen _ p s)
+            return $ A.Only m v
-    = checkStructured doInner s
-checkStructured doInner (A.Only _ i)
-    = doInner i
-checkStructured doInner (A.Several _ ss)
-    = mapM_ (checkStructured doInner) ss
 
 --}}}
 --{{{  retyping checks
@@ -1018,7 +1004,8 @@ checkTypes t =
     checkVariables t >>=
     checkExpressions >>=
     checkSpecTypes >>=
-    checkProcesses
+    checkProcesses >>=
+    checkReplicators
 
 --{{{  checkVariables
 
@@ -1305,6 +1292,20 @@ checkProcesses = checkDepthM doProcess
                 A.Any -> checkCommunicable (findMeta e) t
                 _ -> checkType (findMeta e) wantT t
 
+--}}}
+--{{{  checkReplicators
+
+checkReplicators :: PassType
+checkReplicators = checkDepthM doReplicator
+  where
+    doReplicator :: Check A.Replicator
+    doReplicator (A.For _ _ start count)
+        =  do checkExpressionInt start
+              checkExpressionInt count
+    doReplicator (A.ForEach _ _ e)
+        =  do t <- astTypeOf e
+              checkSequence (findMeta e) t
+
 --}}}
 
 --}}}

pass/Pass.hs

@@ -31,6 +31,7 @@ import System.IO
 import qualified AST as A
 import CompState
 import Errors
+import Metadata
 import PrettyShow
 import TreeUtils
 import Utils
@@ -155,12 +156,16 @@ debugAST p
           veryDebug $ pshow ps
           veryDebug $ "}}}"
 
-applyToOnly :: (Monad m, Data a) => (a -> m a) -> A.Structured a -> m (A.Structured a)
+-- | Transform the 'A.Only' items in a 'A.Structured'.
-applyToOnly f (A.Rep m r s) = applyToOnly f s >>* A.Rep m r
+-- This can be used to convert one kind of 'A.Structured' into another.
-applyToOnly f (A.Spec m sp s) = applyToOnly f s >>* A.Spec m sp
+transformOnly :: (Monad m, Data a, Data b) =>
-applyToOnly f (A.ProcThen m p s) = applyToOnly f s >>* A.ProcThen m p
+               (Meta -> a -> m (A.Structured b))
-applyToOnly f (A.Several m ss) = mapM (applyToOnly f) ss >>* A.Several m
+               -> A.Structured a -> m (A.Structured b)
-applyToOnly f (A.Only m o) = f o >>* A.Only m
+transformOnly f (A.Rep m r s) = transformOnly f s >>* A.Rep m r
+transformOnly f (A.Spec m sp s) = transformOnly f s >>* A.Spec m sp
+transformOnly f (A.ProcThen m p s) = transformOnly f s >>* A.ProcThen m p
+transformOnly f (A.Several m ss) = mapM (transformOnly f) ss >>* A.Several m
+transformOnly f (A.Only m o) = f m o
 
 excludeConstr :: (Data a, CSMR m) => [Constr] -> a -> m a
 excludeConstr cons x 

transformations/SimplifyComms.hs

@@ -145,58 +145,35 @@ transformInputCase = applyDepthM doProcess
            return (A.Alt m pri s')
     doProcess p = return p
 
-    -- Can't easily use generics here as we're switching from one type of Structured to another
+    -- Convert Structured Variant into the equivalent Structured Option.
     doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
-    -- These entries all just burrow deeper into the structured:
+    doStructuredV chanVar = transformOnly transform
-    doStructuredV v (A.ProcThen m p s)
+      where
-      = do s' <- doStructuredV v s
+        transform m (A.Variant m' n iis p)
-           return (A.ProcThen m p s')
+            =  do (Right items) <- protocolItems chanVar
-    doStructuredV v (A.Spec m sp st)
+                  let (Just idx) = elemIndex n (fst $ unzip items)
-      = do st' <- doStructuredV v st
+                  return $ A.Only m $ A.Option m' [makeConstant m' idx] $
-           return (A.Spec m sp st')
+                    if length iis == 0
-    doStructuredV v (A.Several m ss)
+                      then p
-      = do ss' <- mapM (doStructuredV v) ss
+                      else A.Seq m' $ A.Several m'
-           return (A.Several m ss')
+                             [A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
-    doStructuredV v (A.Rep m rep s)
+                              A.Only (findMeta p) p]
-      = do s' <- doStructuredV v s
+
-           return (A.Rep m rep s')
+    -- Transform alt guards.
-    -- Transform variant options:
+    doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
-    doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
+    doStructuredA = transformOnly doAlternative
-      = do (Right items) <- protocolItems chanVar
+      where
-           let (Just idx) = elemIndex n (fst $ unzip items)
+        -- The processes that are the body of input-case guards are always
-           return $ A.Only m $ A.Option m' [makeConstant m' idx] $
+        -- skip, so we can discard them.
-             if (length iis == 0)
+        doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _)
-               then p
+          = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original
-               else A.Seq m' $ A.Several m'
+               s' <- doStructuredV v s
-                      [A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
+               return $ A.Spec m' spec $ A.Only m $ 
-                       A.Only (findMeta p) p]
+                 A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
- 
+                 A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
-    doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
+        -- Leave other guards untouched.
-    -- TODO use generics instead of this boilerplate
+        doAlternative m a = return $ A.Only m a
-    doStructuredA (A.ProcThen m p s)
-      = do s' <- doStructuredA s
-           return (A.ProcThen m p s')
-    doStructuredA (A.Spec m sp st)
-      = do st' <- doStructuredA st
-           return (A.Spec m sp st')
-    doStructuredA (A.Several m ss)
-      = do ss' <- mapM doStructuredA ss
-           return (A.Several m ss')
-    doStructuredA (A.Rep m rep s)
-      = do s' <- doStructuredA s
-           return (A.Rep m rep s')
 
-    -- Transform alt guards:
-    -- The processes that are the body of input-case guards are always skip, so we can discard them:
-    doStructuredA (A.Only m (A.Alternative m' e v (A.InputCase m'' s) _))
-      = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original
-           s' <- doStructuredV v s
-           return $ A.Spec m' spec $ A.Only m $ 
-             A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
-             A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
-    -- Leave other guards (and parts of Structured) untouched:
-    doStructuredA s = return s
-    
 transformProtocolInput :: PassType
 transformProtocolInput = applyDepthM2 doProcess doAlternative
   where

transformations/SimplifyProcs.hs

@@ -50,21 +50,12 @@ parsToProcs = applyDepthM doProcess
 
     -- FIXME This should be generic and in Pass.
     doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
-    doStructured (A.Rep m r s)
+    doStructured = transformOnly wrapProcess
-        =  do s' <- doStructured s
+      where
-              return $ A.Rep m r s'
+        wrapProcess m p
-    doStructured (A.Spec m spec s)
+          =  do s@(A.Specification _ n _) <- makeNonceProc m p
-        =  do s' <- doStructured s
+                modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
-              return $ A.Spec m spec s'
+                return $ A.Spec m s (A.Only m (A.ProcCall m n []))
-    doStructured (A.ProcThen m p s)
-        =  do s' <- doStructured s
-              return $ A.ProcThen m p s'
-    doStructured (A.Only m p)
-        =  do s@(A.Specification _ n _) <- makeNonceProc m p
-              modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
-              return $ A.Spec m s (A.Only m (A.ProcCall m n []))
-    doStructured (A.Several m ss)
-        = liftM (A.Several m) $ mapM doStructured ss
 
 -- | Turn parallel assignment into multiple single assignments through temporaries.
 removeParAssign :: PassType