Fixed all the conflicts while merging into the Polyplate branch

Main.hs

@@ -276,10 +276,12 @@ compileFull inputFile moutputFile
                           ("-", Nothing) -> dieReport (Nothing, "Must specify an output file when using full-compile mode")
                           (file, _) -> return file
 
-          let extension = case csBackend optsPS of
+          let (cExtension, hExtension)
-                            BackendC -> ".c"
+                        = case csBackend optsPS of
-                            BackendCPPCSP -> ".cpp"
+                            BackendC -> (".tock.c", ".tock.h")
-                            _ -> ""
+                            BackendCPPCSP -> (".tock.cpp", ".tock.hpp")
+                            BackendCHP -> (".hs", error "CHP backend")
+                            _ -> ("", "")
 
           -- Translate input file to C/C++
           let cFile = outputFile ++ cExtension
@@ -330,9 +332,17 @@ compileFull inputFile moutputFile
 
             -- For C++, just compile the source file directly into a binary
             BackendCPPCSP ->
-              exec $ cxxCommand cFile outputFile
+              do cs <- lift getCompState
-                (csCompilerFlags optsPS ++ " " ++ csCompilerLinkFlags optsPS)
+                 if csHasMain optsPS
+                   then let otherOFiles = [usedFile ++ ".tock.o"
+                                          | usedFile <- Set.toList $ csUsedFiles cs]
+                     in exec $ cxxCommand cFile outputFile
+                          (concat (intersperse " " otherOFiles) ++ " " ++ csCompilerFlags optsPS ++ " " ++ csCompilerLinkFlags optsPS)
+                   else exec $ cxxCommand cFile (outputFile ++ ".tock.o")
+                          ("-c " ++ csCompilerFlags optsPS)
 
+            BackendCHP ->
+              exec $ hCommand cFile outputFile
             _ -> dieReport (Nothing, "Cannot use specified backend: "
                                      ++ show (csBackend optsPS)
                                      ++ " with full-compile mode")
@@ -477,8 +487,10 @@ compile mode fn (outHandles@(outHandle, _), headerName)
                  let generator :: A.AST -> PassM ()
                      generator
                        = case csBackend optsPS of
-                           BackendC -> generateC outHandle
+                           BackendC -> generateC outHandles headerName
-                           BackendCPPCSP -> generateCPPCSP outHandle
+                           BackendCHP -> generateCHP outHandle
+                           BackendCPPCSP -> generateCPPCSP outHandles headerName
+
                            BackendDumpAST -> liftIO . hPutStr outHandle . pshow
                            BackendSource -> (liftIO . hPutStr outHandle) <.< showCode
                  generator ast2

backends/BackendPasses.hs

@@ -21,7 +21,8 @@ module BackendPasses (backendPasses, transformWaitFor, declareSizesArray) where
 
 import Control.Monad.Error
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
+import Data.Generics.Polyplate
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
@@ -39,8 +40,8 @@ import Traversal
 import Types
 import Utils
 
-squashArrays :: [Pass]
+backendPasses :: [Pass A.AST]
-squashArrays =
+backendPasses =
     -- Note that removeDirections is only for C, whereas removeUnneededDirections
     -- is for all backends
   [ removeDirectionsForC
@@ -59,8 +60,8 @@ prereq = Prop.agg_namesDone ++ Prop.agg_typesDone ++ Prop.agg_functionsGone ++ [
 -- | Remove all variable directions for the C backend.
 -- They're unimportant in occam code once the directions have been checked,
 -- and this somewhat simplifies the work of the later passes.
-removeDirections :: Pass
+removeDirectionsForC :: PassOn A.Variable
-removeDirections
+removeDirectionsForC
     = occamAndCOnlyPass "Remove variable directions"
                     prereq
                     [Prop.directionsRemoved]
@@ -193,20 +194,28 @@ findVarSizes skip (A.VariableSizes m v)
        mn <- getSizes m (A.VariableSizes m v) es
        return (mn, fmap (A.Variable m) mn, es)
 
+type DeclSizeOps = (ExtOpMSP BaseOp) `ExtOpMP` A.Process
 
 -- | Declares a _sizes array for every array, statically sized or dynamically sized.
 -- For each record type it declares a _sizes array too.
-declareSizesArray :: PassOnStruct
+declareSizesArray :: PassASTOnOps DeclSizeOps
 declareSizesArray = occamOnlyPass "Declare array-size arrays"
   (prereq ++ [Prop.slicesSimplified, Prop.arrayConstructorsRemoved])
   [Prop.arraySizesDeclared]
-  (applyDepthSM doStructured)
+  (passOnlyOnAST "declareSizesArray"
+  (\t -> do pushPullContext
+            t' <- recurse t >>= applyPulled
+            popPullContext
+            return t'
+            ))
   where
-    ops :: OpsM PassM
+    ops :: DeclSizeOps
-    ops = baseOp `extOpS` doStructured `extOp` doProcess
+    ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
-    recurse, descend :: Data a => Transform a
+
-    recurse = makeRecurse ops
+    recurse :: RecurseM PassM DeclSizeOps
-    descend = makeDescend ops
+    recurse = makeRecurseM ops
+    descend :: DescendM PassM DeclSizeOps
+    descend = makeDescendM ops
     
     defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM ()
     defineSizesName m n spec
@@ -289,7 +298,9 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
         lit = A.ArrayListLiteral m $ A.Several m $ map (A.Only m) es
         t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int
 
-    doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
+    doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps () PassM
+                           , PolyplateM (A.Structured a) () DeclSizeOps PassM)
+                    => Transform (A.Structured a)
     doStructured str@(A.Spec m sp@(A.Specification m' n spec) s)
       = do t <- typeOfSpec spec
            case (spec, t) of
@@ -329,43 +340,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
                   return $ A.Spec m (A.Specification m n newspec) s'
              _ -> descend str
     doStructured s = descend s
-
-    transformExternal :: Meta -> ExternalType -> [A.Formal] -> PassM [A.Formal]
-    transformExternal m extType args
-      = do (args', newargs) <- transformFormals (Just extType) m args
-           sequence_ [defineSizesName m n (A.Declaration m t)
-                     | A.Formal _ t n <-  newargs]
-           return args'
-
--- | A pass for adding _sizes parameters to PROC arguments
--- TODO in future, only add _sizes for variable-sized parameters
-addSizesFormalParameters :: Pass
-addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers"
-  (prereq ++ [Prop.arraySizesDeclared])
-  []
-  (applyDepthM doSpecification)
-  where
-    doSpecification :: Bool -> A.Specification -> PassM A.Specification
-    doSpecification ext (A.Specification m n (A.Proc m' sm args body))
-      = do (args', newargs) <- transformFormals ext m args
-           let newspec = A.Proc m' sm args' body
-           modify (\cs -> cs {csNames = Map.adjust (\nd -> nd { A.ndSpecType = newspec }) (A.nameName n) (csNames cs)})
-           mapM_ (recordArg m') newargs
-           return $ A.Specification m n newspec
-    doSpecification _ st = return st
     
-    recordArg :: Meta -> A.Formal -> PassM ()
+    transformFormals :: Maybe ExternalType -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal])
-    recordArg m (A.Formal am t n)
-      =  defineName n $ A.NameDef {
-                         A.ndMeta = m
-                        ,A.ndName = A.nameName n
-                        ,A.ndOrigName = A.nameName n
-                        ,A.ndSpecType = A.Declaration m t
-                        ,A.ndAbbrevMode = A.ValAbbrev
-                        ,A.ndNameSource = A.NameNonce
-                        ,A.ndPlacement = A.Unplaced}
-    
-    transformFormals :: Bool -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal])
     transformFormals _ _ [] = return ([],[])
     transformFormals ext m ((f@(A.Formal am t n)):fs)
       = case (t, ext) of
@@ -396,13 +372,6 @@ addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers"
           _ -> do (rest, new) <- transformFormals ext m fs
                   return (f : rest, new)
 
--- | A pass for adding _sizes parameters to actuals in PROC calls
-addSizesActualParameters :: Pass
-addSizesActualParameters = occamOnlyPass "Add array-size arrays to PROC calls"
-  (prereq ++ [Prop.arraySizesDeclared])
-  []
-  (applyDepthM doProcess)
-  where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.ProcCall m n params)
       = do ext <- getCompState >>* csExternals >>* lookup (A.nameName n)
@@ -462,12 +431,12 @@ simplifySlices = occamOnlyPass "Simplify array slices"
 
 -- | Finds all processes that have a MOBILE parameter passed in Abbrev mode, and
 -- add the communication back at the end of the process.
-mobileReturn :: Pass
+{-
+mobileReturn :: PassOnOps (ExtOpMSP BaseOp `ExtOpMP` A.Process)
 mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse
   where
-    ops = baseOp `extOpS` doStructured `extOp` doProcess
+    ops = baseOp `extOpMS` doStructured `extOpM` doProcess
 
-    descend, recurse :: Data a => Transform a
     descend = makeDescend ops
     recurse = makeRecurse ops
 
@@ -542,3 +511,4 @@ mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse
                      modifyName n (\nd -> nd {A.ndSpecType = newSpec})
                      return $ A.Spec msp (A.Specification m n newSpec) scope'
     doStructured s = descend s
+-}

backends/GenerateC.hs

@@ -912,6 +912,7 @@ cgenArraySubscript check v es
     -- smart C compiler should be able to work it out...
     genPlainSub :: (Int -> CGen ()) -> [(Meta, CGen ())] -> [Int] -> [CGen ()]
     genPlainSub _ [] _ = []
+    genPlainSub _ (_:_) [] = [dieP (findMeta v) "Fewer subscripts than dimensions in genPlainSub"]
     genPlainSub genDim ((m,e):es) (sub:subs)
         = gen : genPlainSub genDim es subs
       where

backends/GenerateCHP.hs

@@ -44,6 +44,7 @@ import Control.Monad.Trans
 import Data.Char
 import Data.Generics
 import Data.List
+import Data.Maybe
 import System.IO
 import Text.Printf
 
@@ -143,7 +144,7 @@ genSpec (A.Specification _ n (A.Proc _ _ params body))
        genName n
        sequence [genName pn >> tell [" "] | A.Formal _ _ pn <- params]
        tell ["= "]
-       withIndent $ genProcess body
+       withIndent $ genProcess (fromJust body)
   where
     doFormalAndArrow :: A.Formal -> CGen ()
     doFormalAndArrow (A.Formal _ t _)
@@ -155,6 +156,7 @@ genSpec (A.Specification _ n (A.Declaration _ t))
        tell ["\n"]
        genName n
        tell [" = error \"Variable ", A.nameName n, " used uninitialised\"\n"]
+{-
 genSpec (A.Specification _ n (A.IsExpr _ _ t e))
   = do genName n
        tell [" :: "]
@@ -164,6 +166,7 @@ genSpec (A.Specification _ n (A.IsExpr _ _ t e))
        tell [" = "]
        genExpression e
        tell ["\n"]
+-}
 genSpec _ = genMissing "genSpec" >> tell ["\n"]
 
 genProcess :: A.Process -> CGen ()

common/EvalLiterals.hs

@@ -184,13 +184,9 @@ evalByteLiteral m _ _ = throwError (Just m, "Bad BYTE literal")
 -- | Resolve a datatype into its underlying type -- i.e. if it's a named data
 -- type, then return the underlying real type. This will recurse.
 underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-underlyingType m = applyDepthM doType
+underlyingType m = applyTopDownM (resolveUserType m)
-  where
+    -- After resolving a user type, we have to recurse
-    doType :: A.Type -> m A.Type
+    -- on the resulting type, so we must use a top-down transformation.
-    -- This is fairly subtle: after resolving a user type, we have to recurse
-    -- on the resulting type.
-    doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m
-    doType t = return t
 
 -- | Like underlyingType, but only do the "outer layer": if you give this a
 -- user type that's an array of user types, then you'll get back an array of
@@ -202,3 +198,4 @@ resolveUserType m (A.UserDataType n)
             A.DataType _ t -> resolveUserType m t
             _ -> dieP m $ "Not a type name: " ++ show n
 resolveUserType _ t = return t
+

common/GenericUtils.hs

@@ -1,245 +0,0 @@
-{-
-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/>.
--}
-
--- | Utilities for generic operations.
---
--- This code was inspired by Neil Mitchell's Uniplate library.
--- 'typeContains' is faster than PlateData's equivalent at the cost of some
--- flexibility: it'll only work for types that it knows about (which can be
--- added to in the definition of 'contains').
-module GenericUtils (
-    TypeKey, typeKey
-  , TypeSet, makeTypeSet
-  , containsTypes
-  , gmapMFor
-  , gmapMForRoute
-  , routeModify, routeGet, routeSet, Route(..), (@->), routeIdentity, routeId, routeList
-  , route22, route23, route33, route34, route44, route45, route55
-  ) where
-
-import Control.Monad.Identity
-import Control.Monad.State
-import Data.Generics
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IntSet
-import Data.List
-import Data.Typeable
-import System.IO.Unsafe
-
-import qualified AST as A
-import Data.Generics.Polyplate.Route
-import TreeUtils
-import Utils
-
--- | A type identifier.
-type TypeKey = Int
-
--- | Given a witness for a type, return its 'TypeKey'.
-typeKey :: Typeable a => a -> TypeKey
-typeKey x = unsafePerformIO $ typeRepKey $ typeOf x
-
--- | Given a witness for a type, return witnesses for all the types that its
--- constructors take.
-constrArgTypes :: (Data a, Typeable a) => a -> [DataBox]
-constrArgTypes x = if isAlgType dtype then concatMap f constrs else []
-  where
-    f constr = gmapQ DataBox (asTypeOf (fromConstr constr) x)
-    constrs = dataTypeConstrs dtype
-    dtype = dataTypeOf x
-
--- | Given a witness for a type, return a map from type keys to witnesses for
--- all the types it contains recursively.
-containedTypes :: (Data a, Typeable a) => a -> IntMap DataBox
-containedTypes start = containedTypes' (DataBox start) IntMap.empty
-  where
-    containedTypes' :: DataBox -> IntMap DataBox -> IntMap DataBox
-    containedTypes' box@(DataBox thisType) seen
-        = if thisKey `IntMap.member` seen
-            then seen
-            else foldl (\s t -> containedTypes' t s)
-                       (IntMap.insert thisKey box seen)
-                       (constrArgTypes thisType)
-      where
-        thisKey = typeKey thisType
-
--- | A map from type keys to the other type keys reachable from them.
-type ContainsMap = IntMap IntSet
-
--- | A map of reachable types.
--- At the moment this only knows about types reachable from the AST.
-contains :: ContainsMap
-contains = IntMap.fromList [(typeKey t,
-                             IntMap.keysSet $ containedTypes t)
-                            | DataBox t <- IntMap.elems allTypes]
-  where
-    allTypes = containedTypes (undefined :: A.AST)
-
--- | Does a value contain any of the listed types?
--- (A value always contains its own type.)
-containsTypes :: Data t => t -> [TypeKey] -> Bool
-containsTypes x targets
-    = or $ map containsType targets
-  where
-    start :: TypeKey
-    start = typeKey x
-
-    containsType :: TypeKey -> Bool
-    containsType target
-      | start == target = True
-      | otherwise       = case IntMap.lookup start contains of
-                            Just set -> target `IntSet.member` set
-                            Nothing -> True  -- can't tell, so it might be
-
--- | A decision about what to do when we find a particular type during a
--- generic operation.
-data TypeDecision =
-  -- | This is one of the types we're looking for.
-  Hit
-  -- | This isn't one of the types we're looking for, but it might contain one
-  -- of them.
-  | Through
-  -- | This isn't one of the types we're looking for, and there's no need to
-  -- look inside it.
-  | Miss
-
--- | A set of type information for use by 'gmapMFor'.
-type TypeSet = IntMap TypeDecision
-
--- | Make a 'TypeSet' from a list of 'TypeKey's.
-makeTypeSet :: [TypeKey] -> TypeSet
-makeTypeSet targets
-    = IntMap.fromList [(tk, decide tk)
-                       | tk <- IntMap.keys contains]
-  where
-    decide :: TypeKey -> TypeDecision
-    decide tk
-      | tk `elem` targets             = Hit
-      | tk `IntSet.member` allThrough = Through
-      | otherwise                     = Miss
-
-    allThrough :: IntSet
-    allThrough
-        = IntSet.fromList $ filter containsThis $ IntMap.keys contains
-      where
-        containsThis tk
-            = case IntMap.lookup tk contains of
-                Just set -> or $ map (`IntSet.member` set) targets
-                Nothing -> False
-
--- | Type-smart generic mapM.
--- This is like 'gmapM', but it only applies the function to arguments that
--- could contain any of the target types.
-gmapMFor :: (Monad m, Data t) =>
-            TypeSet                           -- ^ Target types
-            -> (forall s. Data s => s -> m s) -- ^ Function to apply
-            -> (t -> m t)                     -- ^ Generic operation
-gmapMFor typeset f = gmapM (each f)
-  where
-    each :: (Monad m, Data t) =>
-            (forall s. Data s => s -> m s) -> (t -> m t)
-    each f x
-        = case IntMap.lookup (typeKey x) typeset of
-            Just Hit -> f x
-            Just Through -> gmapM (each f) x
-            Just Miss -> return x
-            Nothing -> return x
-
-
--- | Acts just like gmapMFor, except that it also tells you the route to the node
--- that your generic function is being applied to.
-gmapMForRoute :: forall m t. (Monad m, Data t) =>
-  TypeSet ->
-  (forall s. Data s => (s, Route s t) -> m s)
-  -> (t -> m t)
-gmapMForRoute typeset f = gmapMWithRoute (each f)
-  where
-    each :: Data u => (forall s. Data s => (s, Route s t) -> m s)
-             -> ((u, Route u t) -> m u)
-    each f (x, route)
-        = case IntMap.lookup (typeKey x) typeset of
-            Just Hit -> f (x, route)
-            Just Through -> gmapMWithRoute (\(y, route') -> each f (y, route @-> route')) x
-            Just Miss -> return x
-            Nothing -> return x
-
--- A helper for gmapMForRoute that maps over the direct children and supplies routes
-gmapMWithRoute :: forall a m. (Monad m, Data a) => (forall b. Data b => (b, Route
-  b a) -> m b) -> a -> m a
-gmapMWithRoute f = gmapFuncs [GM {unGM = f' n} | n <- [0..]]
-  where
-    f' :: Int -> (forall b. Data b => b -> m b)
-    f' n x = f (x, makeRoute' n)
-
--- Given a number, makes a route function for that child:
-makeRoute' :: (Data s, Data t) => Int -> Route s t
-makeRoute' target = makeRoute [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]])
-
-decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a)
-decomp22 con f1 = decomp2 con return f1
-
-decomp23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a1 -> m a1) -> (a -> m a)
-decomp23 con f1 = decomp3 con return f1 return
-
-decomp33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a2 -> m a2) -> (a -> m a)
-decomp33 con f2 = decomp3 con return return f2
-
-decomp34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  (a0 -> a1 -> a2 -> a3 -> a) -> (a2 -> m a2) -> (a -> m a)
-decomp34 con f2 = decomp4 con return return f2 return
-
-decomp44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  (a0 -> a1 -> a2 -> a3 -> a) -> (a3 -> m a3) -> (a -> m a)
-decomp44 con f3 = decomp4 con return return return f3
-
-decomp45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a3 -> m a3) -> (a -> m a)
-decomp45 con f3 = decomp5 con return return return f3 return
-
-decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
-decomp55 con f4 = decomp5 con return return return return f4
-
-route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b
-route22 route con = route @-> makeRoute [1] (decomp22 con)
-
-route23 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a1 b
-route23 route con = route @-> makeRoute [1] (decomp23 con)
-
-route33 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a2 b
-route33 route con = route @-> makeRoute [2] (decomp33 con)
-
-route34 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a2 b
-route34 route con = route @-> makeRoute [2] (decomp34 con)
-
-route44 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a3 b
-route44 route con = route @-> makeRoute [3] (decomp44 con)
-
-route45 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a3 b
-route45 route con = route @-> makeRoute [3] (decomp45 con)
-
-route55 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a4 b
-route55 route con = route @-> makeRoute [4] (decomp55 con)
-
--- TODO we should be able to provide versions of these that do not need to know
--- the constructor or the arity

common/Types.hs

@@ -363,28 +363,6 @@ abbrevModeOfSpec s
         A.RetypesExpr _ am _ _ -> am
         _ -> A.Original
 
--- | Resolve a datatype into its underlying type -- i.e. if it's a named data
--- type, then return the underlying real type. This will recurse.
-underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-underlyingType m = applyDepthM doType
-  where
-    doType :: A.Type -> m A.Type
-    -- This is fairly subtle: after resolving a user type, we have to recurse
-    -- on the resulting type.
-    doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m
-    doType t = return t
-
--- | Like underlyingType, but only do the "outer layer": if you give this a
--- user type that's an array of user types, then you'll get back an array of
--- user types.
-resolveUserType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-resolveUserType m (A.UserDataType n)
-    =  do st <- specTypeOfName n
-          case st of
-            A.DataType _ t -> resolveUserType m t
-            _ -> dieP m $ "Not a type name: " ++ show n
-resolveUserType _ t = return t
-
 -- | Add array dimensions to a type; if it's already an array it'll just add
 -- the new dimensions to the existing array.
 addDimensions :: [A.Dimension] -> A.Type -> A.Type

common/Utils.hs

@@ -376,5 +376,47 @@ eitherToMaybe = either (const Nothing) Just
 labelMapWithNodeId :: DynGraph gr => (Node -> a -> b) -> gr a c -> gr b c
 labelMapWithNodeId f = gmap (\(x,n,l,y) -> (x,n,f n l,y))
 
+-- This is quite inefficient, but I can't see an easier way:
+labelMapWithNodeIdM :: (DynGraph gr, Monad m) => (Node -> a -> m b) -> gr a c -> m (gr b c)
+labelMapWithNodeIdM f gr
+  = let unsequencedMap = ufold (\(x, n, l, y) -> Map.insert n (f n l)) Map.empty gr
+    in do mp <- T.sequence unsequencedMap
+          return $ gmap (\(x,n,l,y) -> (x,n,fromJust $ Map.lookup n mp,y)) gr
+
+-- | Does a reverse lookup in a Map (looks up the key for a value).
 reverseLookup :: (Ord k, Eq v) => v -> Map.Map k v -> Maybe k
 reverseLookup x m = lookup x $ map revPair $ Map.toList m
+
+-- Where you have a wrapper for an inner monadic action, but you want to apply
+-- this to an action that has state wrapped around it:
+liftWrapStateT :: Monad m => (forall b. m b -> m b) -> StateT s m a -> StateT s m a
+liftWrapStateT wrap m
+  = do st <- get
+       (x, st') <- lift $ wrap (runStateT m st)
+       put st'
+       return x
+
+-- The foldM equivalent of foldl1:
+foldM1 :: Monad m => (a -> a -> m a) -> [a] -> m a
+foldM1 f (x:xs) = foldM f x xs
+foldM1 _ [] = fail "Empty list in foldM1"
+
+-- | A shortcut for concat and intersperse.
+-- For example, @joinWith " " names@ is the same as @concat (intersperse " "
+-- names)@
+joinWith :: [a] -> [[a]] -> [a]
+joinWith x = concat . intersperse x
+
+-- | Replaces all instances of the given sub-pattern with a replacement in a larger
+-- list
+replace :: Eq a => ([a],[a]) -> [a] -> [a]
+replace ([],_) big = big
+replace (find, repl) big
+  = let (ignore, poss) = span (/= head find) big in
+      if null poss
+        then big
+        else ignore ++ 
+               if find `isPrefixOf` poss
+                 then repl ++ replace (find, repl) (drop (length find) poss)
+                 else head poss : replace (find, repl) (tail poss)
+

flow/FlowUtils.hs

@@ -303,6 +303,8 @@ joinPairs m mod nodes
   = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge (ESeq Nothing) s e) nodes
        return (fst (head nodes), snd (last nodes))
 
+decomp11 :: (Monad m, Data a, Typeable a0) => (a0 -> a) -> (a0 -> m a0) -> (a -> m a)
+decomp11 con f1 = decomp1 con f1
 
 decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a)
 decomp22 con f1 = decomp2 con return f1
@@ -329,6 +331,9 @@ decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3
   (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
 decomp55 con f4 = decomp5 con return return return return f4
 
+route11 :: (Data a, Typeable a0) => Route a b -> (a0 -> a) -> Route a0 b
+route11 route con = route @-> makeRoute [0] (decomp11 con)
+
 route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b
 route22 route con = route @-> makeRoute [1] (decomp22 con)
 

frontends/OccamPasses.hs

@@ -28,6 +28,7 @@ import System.IO
 
 import qualified AST as A
 import CompState
+import Errors
 import EvalConstants
 import EvalLiterals
 import GenerateC -- For nameString
@@ -55,7 +56,7 @@ occamPasses =
     , pushUpDirections
     ]
 
-writeIncFile :: Pass
+writeIncFile :: Pass A.AST
 writeIncFile = occamOnlyPass "Write .inc file" [] []
   (passOnlyOnAST "writeIncFile" (\t ->
     do out <- getCompState >>* csOutputIncFile
@@ -113,20 +114,22 @@ fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.Literal m prevT lit@(A.ArrayListLiteral _ expr))
-      = do prevT' <- underlyingType m prevT
+      = do dims <- getDims prevT
-           t' <- doExpr [] (getDims prevT') expr
+           t' <- doExpr [] dims expr
            return $ A.Literal m t' lit
       where
-        getDims :: A.Type -> [A.Dimension]
+        getDims :: A.Type -> PassM [A.Dimension]
-        getDims (A.Array ds _) = ds
+        getDims (A.Array ds _) = return ds
-        getDims t = error $ "Cannot deduce dimensions of array constructor: " ++ show t
+        getDims t@(A.UserDataType {}) = resolveUserType m t >>= getDims
+        getDims t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
 
-        innerType :: A.Type -> A.Type
+        innerType :: A.Type -> PassM A.Type
-        innerType (A.Array _ t) = t
+        innerType (A.Array _ t) = return t
-        innerType t = error $ "Cannot deduce dimensions of array constructor: " ++ show t
+        innerType t@(A.UserDataType {}) = resolveUserType m t >>= innerType
+        innerType t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
 
         doExpr :: [A.Dimension] -> [A.Dimension] -> A.Structured A.Expression -> PassM A.Type
-        doExpr prev (d:_) (A.Several m []) = return $ A.Array (prev ++ [d]) $ innerType prevT
+        doExpr prev (d:_) (A.Several m []) = innerType prevT >>* A.Array (prev ++ [d])
         doExpr prev (d:dims) (A.Several m ss@(s:_))
           = doExpr (prev ++ [d]) dims s
         doExpr prev _ (A.Only _ e)
@@ -191,17 +194,18 @@ foldConstants = occamOnlyPass "Fold constants"
               return s
 
 -- | Check that things that must be constant are.
-checkConstants :: PassOn2 A.Dimension A.Option
+checkConstants :: PassOn2 A.Type A.Option
 checkConstants = occamOnlyPass "Check mandatory constants"
   [Prop.constantsFolded, Prop.arrayConstructorTypesDone]
   [Prop.constantsChecked]
-  (applyDepthM2 doDimension doOption)
+  recurse
   where
-    ops = baseOp `extOp` doType `extOp` doOption
+    ops = baseOp `extOpM` doType `extOpM` doOption
 
-    descend, recurse :: Data a => a -> PassM a
+    descend :: DescendM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
-    descend = makeDescend ops
+    descend = makeDescendM ops
-    recurse = makeRecurse ops
+    recurse :: RecurseM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
+    recurse = makeRecurseM ops
     
     doType :: A.Type -> PassM A.Type
     -- Avoid checking that mobile dimensions are constant:

frontends/OccamTypes.hs

@@ -646,7 +646,6 @@ type InferTypeOps
     `ExtOpMP` A.Subscript
     `ExtOpMP` A.Replicator
     `ExtOpMP` A.Alternative
-    `ExtOpMP` A.InputMode
     `ExtOpMP` A.Process
     `ExtOpMP` A.Variable
 
@@ -766,12 +765,23 @@ inferTypes = occamOnlyPass "Infer types"
       where
         direct = error "Cannot direct channels passed to FUNCTIONs"
 
-    doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a]
+        opsMatch (opA, _, tsA) (opB, _, tsB) = (opA == opB) && (tsA `typesEqForOp` tsB)
-    doActuals m n fs as
+
+        typesEqForOp :: [A.Type] -> [A.Type] -> Bool
+        typesEqForOp tsA tsB = (length tsA == length tsB) && (and $ zipWith typeEqForOp tsA tsB)
+
+        typeEqForOp :: A.Type -> A.Type -> Bool
+        typeEqForOp (A.Array ds t) (A.Array ds' t')
+          = (length ds == length ds') && typeEqForOp t t'
+        typeEqForOp t t' = t == t'
+
+    doActuals :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> A.Name -> [A.Formal] ->
+      (Meta -> A.Direction -> Transform a) -> Transform [a]
+    doActuals m n fs applyDir as
         =  do checkActualCount m n fs as
               sequence [doActual m applyDir t a | (A.Formal _ t _, a) <- zip fs as]
 
-    doActual :: Data a => Meta -> (Meta -> A.Direction -> Transform a) -> A.Type -> Transform a
+    doActual :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> (Meta -> A.Direction -> Transform a) -> A.Type -> Transform a
     doActual m applyDir (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir
     doActual m _ t a = inTypeContext (Just t) $ recurse a
                         
@@ -1014,7 +1024,6 @@ inferTypes = occamOnlyPass "Infer types"
                     `extOpM` descend
                     `extOpM` descend
                     `extOpM` descend
-                    `extOpM` descend
                     `extOpM` (doVariable r)
                 descend :: DescendM PassM InferTypeOps
                 descend = makeDescendM ops

frontends/RainPasses.hs

@@ -202,23 +202,21 @@ transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges int
                  A.For eachMeta begin newCount (makeConstant eachMeta 1)
     doSpec s = return s
 
--- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions
+transformRangeRep :: PassOn A.Expression
---
--- TODO make sure when the range has a bad order that an empty list is
--- returned
-transformRangeRep :: Pass
 transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors"
   (Prop.agg_typesDone ++ [Prop.eachRangeTransformed])
   [Prop.rangeTransformed]
-  (applyDepthM doExpression)
+  (applyBottomUpM doExpression)
   where
     doExpression :: A.Expression -> PassM A.Expression
-    doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
+    doExpression (A.Literal m t (A.RangeLiteral m' begin end))
-          =        do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev
+          = do count <- subExprs end begin >>= addOne
-                      let count = addOne $ subExprs end begin
+               let rep = A.Rep m' $ A.For m' begin count $ makeConstant m 1
-                      return $ A.ExprConstr m $ A.RepConstr m t rep
+               spec@(A.Specification _ repN _) <- defineNonce m' "rep_constr"
-                        (A.For m begin count $ makeConstant m 1)
+                 rep A.ValAbbrev
-                          (A.ExprVariable m $ A.Variable m rep)
+               return $ A.Literal m t $ A.ArrayListLiteral m' $
+                 A.Spec m' spec $ A.Only m' $
+                   (A.ExprVariable m' $ A.Variable m' repN)
     doExpression e = return e
 
 -- TODO this is almost certainly better figured out from the CFG

pass/PassList.hs

@@ -68,8 +68,8 @@ commonPasses opts = concat $
   , enablePassesWhen csUsageChecking
      [abbrevCheckPass]
   , backendPasses
-  , [pass "Removing unused variables" [] []
+--  , [pass "Removing unused variables" [] []
-      (passOnlyOnAST "checkUnusedVar" (runChecks checkUnusedVar))]
+--      (passOnlyOnAST "checkUnusedVar" (runChecks checkUnusedVar))]
   ]
 
 filterPasses :: CompState -> [Pass t] -> [Pass t]

pass/Traversal.hs

@@ -19,9 +19,9 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- | Traversal strategies over the AST and other data types.  This is now mainly
 -- a collection of extra Tock-specific utilities that go on top of Polyplate
 module Traversal (
-    TransformM, Transform, TransformStructured
+    TransformM, Transform, TransformStructured, TransformStructured'
   , CheckM, Check
-  , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct
+  , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct
   , applyBottomUpMS
   , module Data.Generics.Polyplate
   , module Data.Generics.Polyplate.Schemes
@@ -66,6 +66,7 @@ type ExtOpMS m opT =
 type ExtOpMSP opT = ExtOpMS PassM opT
 
 type PassOnStruct = PassOnOps (ExtOpMSP BaseOp)
+type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
 
 extOpMS :: forall m opT op0T.
           (PolyplateM (A.Structured ()) () op0T m,
@@ -109,3 +110,7 @@ applyBottomUpMS f = makeRecurseM ops
 
 type TransformStructured ops
   = (PolyplateM (A.Structured t) () ops PassM, Data t) => Transform (A.Structured t)
+
+type TransformStructured' ops
+  = (PolyplateM (A.Structured t) () ops PassM
+    ,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t)

pregen/GenNavAST.hs

@@ -29,128 +29,6 @@ import qualified AST
 import qualified CompState
 import qualified Errors
 
-header :: [String]
-header
-    = [ "{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
-      , "-- | Type class and instances for transformations upon the AST."
-      , "--"
-      , "-- This was inspired by Neil Mitchell's Biplate class."
-      , "--"
-      , "-- NOTE: This file is auto-generated by the GenNavAST program, "
-      , "-- and should not be edited directly."
-      , ""
-      , "module NavAST where"
-      , ""
-      , "import qualified AST"
-      , "import qualified Metadata"
-      , ""
-      , "class Monad m => Polyplate m o o0 t where"
-      , "  transformM :: o -> o0 -> Bool -> t -> m t"
-      , ""
-      ]
-
--- | Instances for a particular data type (i.e. where that data type is the
--- last argument to 'Polyplate').
-instancesFrom :: forall t. Data t => t -> [String]
-instancesFrom w
-    = baseInst ++
-      concat [otherInst c | DataBox c <- justBoxes $ astTypeMap]
-  where
-    wName = show $ typeOf w
-    wKey = typeKey w
-    wDType = dataTypeOf w
-    wCtrs = if isAlgType wDType then dataTypeConstrs wDType else []
-
-    -- The module prefix of this type, so we can use it in constructor names.
-    modPrefix
-        = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName)
-            then takeWhile (/= '.') wName ++ "."
-            else ""
-
-    ctrArgs ctr
-        = gmapQ DataBox (fromConstr ctr :: t)
-    ctrArgTypes ctr
-        = [show $ typeOf w | DataBox w <- ctrArgs ctr]
-
-    -- | An instance that describes what to do when we have no transformations
-    -- left to apply.
-    baseInst :: [String]
-    baseInst
-        = [ "instance (" ++ concat (intersperse ", " context) ++ ") =>"
-          , "         Polyplate m () o0 (" ++ wName ++ ") where"
-          ] ++
-          (if isAlgType wDType
-            -- An algebraic type: apply to each child if we're following.
-            then ["  transformM () _ False v = return v"] ++
-                 (concatMap constrCase wCtrs)
-            -- A primitive type: just return it.
-            else ["  transformM () _ _ v = return v"]) ++
-          [""]
-
-    -- | Class context for 'baseInst'.
-    -- We need an instance of Polyplate for each of the types contained within
-    -- this type, so we can recurse into them.
-    context :: [String]
-    context
-        = ["Monad m"] ++
-          ["Polyplate m o0 o0 (" ++ argType ++ ")"
-           | argType <- nub $ sort $ concatMap ctrArgTypes wCtrs]
-
-    -- | A 'transformM' case for a particular constructor of this (algebraic)
-    -- data type: pull the value apart, apply 'transformM' to each part of it,
-    -- then stick it back together.
-    constrCase :: Constr -> [String]
-    constrCase ctr
-        = [ "  transformM () " ++ (if argNums == [] then "_" else "ops") ++
-            " True (" ++ ctrInput ++ ")"
-          , "    = do"
-          ] ++
-          [ "         r" ++ show i ++ " <- transformM ops ops False a" ++ show i
-           | i <- argNums] ++
-          [ "         return (" ++ ctrResult ++ ")"
-          ]
-      where
-        (isTuple, argNums)
-          -- FIXME: Should work for 3+-tuples too
-          | ctrS == "(,)" = (True, [0 .. 1])
-          | otherwise     = (False, [0 .. ((length $ ctrArgs ctr) - 1)])
-        ctrS = show ctr
-        ctrName = modPrefix ++ ctrS
-        makeCtr vs
-            = if isTuple
-                then "(" ++ (concat $ intersperse ", " vs) ++ ")"
-                else ctrName ++ concatMap (" " ++) vs
-        ctrInput = makeCtr ["a" ++ show i | i <- argNums]
-        ctrResult = makeCtr ["r" ++ show i | i <- argNums]
-
-    containedKeys = Set.fromList [typeKey c
-                                  | DataBox c <- justBoxes $ findTypesIn w]
-
-    -- | An instance that describes how to apply -- or not apply -- a
-    -- transformation.
-    otherInst c
-        = [ "instance (Monad m, Polyplate m r o0 (" ++ wName ++ ")) =>"
-          , "         Polyplate m ((" ++ cName ++ ") -> m (" ++ cName ++ "), r)"
-          , "                   o0 (" ++ wName ++ ") where"
-          , impl
-          , ""
-          ]
-      where
-        cName = show $ typeOf c
-        cKey = typeKey c
-        impl
-          -- This type matches the transformation: apply it.
-          | wKey == cKey
-            = "  transformM (f, _) _ _ v = f v"
-          -- This type might contain the type that the transformation acts
-          -- upon: set the flag to say we need to recurse into it.
-          | cKey `Set.member` containedKeys
-            = "  transformM (_, rest) ops _ v = transformM rest ops True v"
-          -- This type can't contain the transformed type; just move on to the
-          -- next transformation.
-          | otherwise
-            = "  transformM (_, rest) ops b v = transformM rest ops b v"
-
 main :: IO ()
 main = do
   [instFileName, spineInstFileName] <- getArgs
@@ -182,7 +60,7 @@ main = do
     header isSpine moduleName =
       ["{-# OPTIONS_GHC -fallow-overlapping-instances -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds #-}"
       ,"-- | This module is auto-generated by Polyplate.  DO NOT EDIT."
-      ,"module " ++ moduleName ++ " where"
+      ,"module " ++ moduleName ++ " () where"
       ,""
       ,"import Data.Generics.Polyplate"
       ,if isSpine then "" else "import Data.Generics.Polyplate.Route"

transformations/ImplicitMobility.hs

@@ -29,11 +29,13 @@ import qualified Data.Set as Set
 import qualified Data.Traversable as T
 
 import qualified AST as A
+import CompState
+import Data.Generics.Polyplate.Route
 import Errors
 import FlowAlgorithms
 import FlowGraph
 import FlowUtils
-import GenericUtils
+import Intrinsics
 import Metadata
 import Pass
 import ShowCode
@@ -198,15 +200,18 @@ implicitMobility
               printMoveCopyDecisions decs
               effectMoveCopyDecisions g decs t)
 
-mobiliseArrays :: Pass
+mobiliseArrays :: PassASTOnStruct
 mobiliseArrays = pass "Make all arrays mobile" [] [] recurse
   where
-    ops = baseOp `extOpS` doStructured
+    ops :: ExtOpMSP BaseOp
-    recurse, descend :: Data t => Transform t
+    ops = baseOp `extOpMS` (ops, doStructured)
-    recurse = makeRecurse ops
-    descend = makeDescend ops
 
-    doStructured :: Data t => Transform (A.Structured t)
+    recurse :: RecurseM PassM (ExtOpMSP BaseOp)
+    recurse = makeRecurseM ops
+    descend :: DescendM PassM (ExtOpMSP BaseOp)
+    descend = makeDescendM ops
+
+    doStructured :: TransformStructured' (ExtOpMSP BaseOp)
     doStructured s@(A.Spec m (A.Specification m' n (A.Declaration m'' t@(A.Array ds
       innerT))) scope)
       = case innerT of
@@ -301,13 +306,15 @@ instance Dereferenceable A.Actual where
   deref m (A.ActualVariable v) = fmap A.ActualVariable $ deref m v
   deref m (A.ActualExpression e) = fmap A.ActualExpression $ deref m e
 
-inferDeref :: Pass
+inferDeref :: PassOn2 A.Process A.Variable
 inferDeref = pass "Infer mobile dereferences" [] [] recurse
   where
-    ops = baseOp `extOp` doProcess `extOp` doVariable
+    ops = baseOp `extOpM` doProcess `extOpM` doVariable
-    recurse, descend :: Data t => Transform t
+
-    recurse = makeRecurse ops
+    recurse :: RecurseM PassM (TwoOpM PassM A.Process A.Variable)
-    descend = makeDescend ops
+    recurse = makeRecurseM ops
+    descend :: DescendM PassM (TwoOpM PassM A.Process A.Variable)
+    descend = makeDescendM ops
 
     unify :: (Dereferenceable a, ASTTypeable a, ShowOccam a, ShowRain a) => Meta
       -> A.Type -> a -> PassM a

transformations/SimplifyAbbrevs.hs

@@ -183,14 +183,22 @@ updateAbbrevsInState
     = pass "Update INITIAL and RESULT abbreviations in state"
            [Prop.initialRemoved, Prop.resultRemoved]
            []
-           (\v -> get >>= applyDepthM (return . doAbbrevMode) >>= put >> return v)
+           (\v -> modify (applyBottomUp doAbbrevMode) >> return v)
   where
     doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode
     doAbbrevMode A.InitialAbbrev = A.Original
     doAbbrevMode A.ResultAbbrev = A.Abbrev
     doAbbrevMode s = s
 
-abbrevCheckPass :: Pass
+type AbbrevCheckM = StateT [Map.Map Var Bool] PassM
+type ExtAbbM a b = ExtOpM AbbrevCheckM a b
+type AbbrevCheckOps
+  = ExtOpMS AbbrevCheckM BaseOp
+      `ExtAbbM` A.Variable
+      `ExtAbbM` A.Process
+      `ExtAbbM` A.InputItem
+
+abbrevCheckPass :: (PolyplateM t AbbrevCheckOps () AbbrevCheckM, PolyplateM t () AbbrevCheckOps AbbrevCheckM) => Pass t
 abbrevCheckPass
     = pass "Abbreviation checking" [] []
            ({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse)

transformations/SimplifyExprs.hs

@@ -56,7 +56,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs"
   (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked,
         Prop.functionTypesChecked])
   [Prop.functionsRemoved]
-  (applyDepthM doSpecification)
+  (applyBottomUpM doSpecification)
   where
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification (A.Specification m n (A.Function mf smrm rts fs evp))
@@ -106,11 +106,11 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs"
 
 -- | Convert AFTER expressions to the equivalent using MINUS (which is how the
 -- occam 3 manual defines AFTER).
-removeAfter :: PassOn A.Expression
+removeAfter :: PassOn2 A.Expression A.ExpressionList
 removeAfter = pass "Convert AFTER to MINUS"
   [Prop.expressionTypesChecked]
   [Prop.afterRemoved]
-  (applyDepthM doExpression)
+  (applyBottomUpM2 doExpression doExpressionList)
   where
     doFunctionCall :: (Meta -> A.Name -> [A.Expression] -> a)
       -> Meta -> A.Name -> [A.Expression] -> PassM a
@@ -191,14 +191,11 @@ expandArrayLiterals = pass "Expand array literals"
 -- TODO for simplification, we could avoid pulling up replication counts that are known to be constants
 --
 -- TODO we should also pull up the step counts
-pullRepCounts :: PassOn2 (A.Structured A.Process) (A.Structured A.Alternative)
+pullRepCounts :: PassOn A.Process
 pullRepCounts = pass "Pull up replicator counts for SEQs, PARs and ALTs"
   (Prop.agg_namesDone ++ Prop.agg_typesDone)
   []
-  (applyDepthM2
+  (applyBottomUpM pullRepCountProc)
-    (pullRepCount :: A.Structured A.Process -> PassM (A.Structured A.Process))
-    (pullRepCount :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative))
-  )
   where
     pullRepCountStr :: Data a => Bool -> A.Structured a
       -> StateT (A.Structured A.Process -> A.Structured A.Process)

transformations/SimplifyTypes.hs

@@ -46,12 +46,9 @@ resolveNamedTypes
            (Prop.agg_namesDone
             ++ [Prop.expressionTypesChecked, Prop.processTypesChecked])
            [Prop.typesResolvedInAST, Prop.typesResolvedInState]
-           (\t -> do get >>= resolve >>= flatten >>= onCsNames (flatten <.< resolve) >>= put
+           (\t -> do get >>= resolve >>= put
-                     resolve t >>= flatten)
+                     resolve t)
   where
-    resolve :: PassType
+    resolve :: PassTypeOn A.Type
-    resolve = applyDepthM doType
+    resolve = applyTopDownM (underlyingType emptyMeta)
-      where
+
-        doType :: A.Type -> PassM A.Type
-        doType t@(A.UserDataType _) = underlyingType emptyMeta t
-        doType t = return t

transformations/Unnest.hs

@@ -77,12 +77,23 @@ freeNamesIn = doGeneric
     doSpecType st = doGeneric st
 
 -- | Replace names.
-replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
+--
-replaceNames map v = runIdentity $ applyDepthM doName v
+-- This has to have extra cleverness due to a really nasty bug.  Array types can
+-- have expressions as dimensions, and those expressions can contain free names
+-- which are being replaced.  This is fine, but when that happens we need to update
+-- CompState so that the type has the replaced name, not the old name.
+replaceNames :: PolyplateM t (TwoOpM PassM A.Name A.Specification) () PassM => [(A.Name, A.Name)] -> t -> PassM t
+replaceNames map = recurse
   where
     smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
 
-    doName :: A.Name -> Identity A.Name
+    ops :: TwoOpM PassM A.Name A.Specification
+    ops = baseOp `extOpM` doName `extOpM` doSpecification
+
+    recurse :: RecurseM PassM (TwoOpM PassM A.Name A.Specification)
+    recurse = makeRecurseM ops
+
+    doName :: Transform A.Name
     doName n = return $ Map.findWithDefault n (A.nameName n) smap
 
     doSpecification :: Transform A.Specification
@@ -192,7 +203,7 @@ removeNesting = pass "Pull nested definitions to top level"
   [Prop.nestedPulled]
   (passOnlyOnAST "removeNesting" $ \s ->
        do pushPullContext
-          s' <- (makeRecurse ops) s >>= applyPulled
+          s' <- recurse s >>= applyPulled
           popPullContext
           return s')
   where