Merged the latest set of changes from the trunk into the Polyplate branch

I also added the import list to all the Data.Generics imports in the tests (as I did for the other modules recently)

Makefile.am

@@ -233,7 +233,7 @@ tocktest_SOURCES += transformations/PassTest.hs
 tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs
 tocktest_SOURCES += transformations/SimplifyTypesTest.hs
 
-pregen_sources = data/AST.hs
+pregen_sources = data/AST.hs data/CompState.hs
 pregen_sources += pregen/PregenUtils.hs
 pregen_sources += polyplate/Data/Generics/Polyplate/GenInstances.hs
 

backends/BackendPasses.hs

@@ -71,7 +71,96 @@ removeDirectionsForC
     doVariable (A.DirectedVariable _ _ v) = v
     doVariable v = v
 
-transformWaitFor :: Pass
+
+-- | Remove variable directions that are superfluous.  This prevents confusing
+-- later passes, where the user has written something like:
+-- []CHAN INT da! IS ...:
+-- foo(da!)
+--
+-- The second direction specifier is unneeded, and will confuse passes such as
+-- those adding sizes parameters (which looks for plain variables, since directed
+-- arrays should already have been pulled up).
+removeUnneededDirections :: PassOn A.Variable
+removeUnneededDirections
+  = occamOnlyPass "Remove unneeded variable directions"
+                  prereq
+                  []
+                  (applyBottomUpM doVariable)
+  where
+    doVariable :: Transform (A.Variable)
+    doVariable whole@(A.DirectedVariable m dir v)
+       = do t <- astTypeOf v
+            case t of
+              A.Chan {} -> return whole
+              A.Array _ (A.Chan {}) -> return whole
+              A.ChanEnd chanDir _ _ | dir == chanDir -> return v
+              A.Array _ (A.ChanEnd chanDir _ _) | dir == chanDir -> return v
+              _ -> diePC m $ formatCode "Direction applied to non-channel type: %" t
+    doVariable v = return v
+
+type AllocMobileOps = ExtOpMSP BaseOp `ExtOpMP` A.Process
+
+-- | Pulls up any initialisers for mobile allocations.  I think, after all the
+-- other passes have run, the only place these initialisers should be left is in
+-- assignments (and maybe not even those?) and A.Is items.
+pullAllocMobile :: PassOnOps AllocMobileOps
+pullAllocMobile = cOnlyPass "Pull up mobile initialisers" [] [] recurse
+  where
+    ops :: AllocMobileOps
+    ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
+
+    recurse :: RecurseM PassM AllocMobileOps
+    recurse = makeRecurseM ops
+    descend :: DescendM PassM AllocMobileOps
+    descend = makeDescendM ops
+    
+    doProcess :: Transform A.Process
+    doProcess (A.Assign m [v] (A.ExpressionList me [A.AllocMobile ma t (Just e)]))
+      = return $ A.Seq m $ A.Several m $ map (A.Only m) $
+          [A.Assign m [v] $ A.ExpressionList me [A.AllocMobile ma t Nothing]
+          ,A.Assign m [A.DerefVariable m v] $ A.ExpressionList me [e]
+          ]
+    doProcess p = descend p
+
+    doStructured :: TransformStructured' AllocMobileOps
+    doStructured (A.Spec mspec (A.Specification mif n
+      (A.Is mis am t (A.ActualExpression (A.AllocMobile ma tm (Just e)))))
+        body)
+      = do body' <- recurse body
+           return $ A.Spec mspec (A.Specification mif n $
+             A.Is mis am t $ A.ActualExpression $ A.AllocMobile ma tm Nothing)
+             $ A.ProcThen ma
+                 (A.Assign ma [A.DerefVariable mif $ A.Variable mif n] $ A.ExpressionList ma [e])
+                 body'
+    doStructured s = descend s
+
+-- | Turns any literals equivalent to a MOSTNEG back into a MOSTNEG
+-- The reason for doing this is that C (and presumably C++) don't technically (according
+-- to the standard) allow you to write INT_MIN directly as a constant.  GCC certainly
+-- warns about it.  So this pass takes any MOSTNEG-equivalent values (that will have been
+-- converted to constants in the constant folding earlier) and turns them back
+-- into MOSTNEG, for which the C backend uses INT_MIN and similar, which avoid
+-- this problem.
+fixMinInt :: PassOn A.Expression
+fixMinInt
+  = cOrCppOnlyPass "Turn any literals that are equal to MOSTNEG INT back into MOSTNEG INT"
+                   prereq
+                   []
+                   (applyBottomUpM doExpression)
+  where
+    doExpression :: Transform (A.Expression)
+    doExpression l@(A.Literal m t (A.IntLiteral m' s))
+      = do folded <- constantFold (A.MostNeg m t)
+           case folded of
+             (A.Literal _ _ (A.IntLiteral _ s'), _, _)
+               -> if (s == s')
+                    then return $ A.MostNeg m t
+                    else return l
+             _ -> return l -- This can happen as some literals retain the Infer
+                           -- type which fails the constant folding
+    doExpression e = return e
+
+transformWaitFor :: PassOn A.Process
 transformWaitFor = cOnlyPass "Transform wait for guards into wait until guards"
   []
   [Prop.waitForRemoved]

backends/BackendPassesTest.hs

@@ -22,7 +22,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module BackendPassesTest (qcTests) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
 import qualified Data.Map as Map
 import Test.HUnit hiding (State)
 import Test.QuickCheck

backends/GenerateCTest.hs

@@ -35,7 +35,7 @@ import Control.Monad.Error
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Monad.Writer hiding (tell)
-import Data.Generics
+import Data.Generics (Data)
 import Data.List (isInfixOf, intersperse)
 import Data.Maybe (fromMaybe)
 import Test.HUnit hiding (State)

checks/CheckFramework.hs

@@ -420,40 +420,14 @@ applyAccum _ ops = ops'
     ops' :: ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops)
     ops' = (accum, ops)
 
-    extF ::
+    accum xr = do x' <- transformMRoute () ops' xr
-       (forall a. Data a => TransFuncS acc z a) ->
+                  modify $ Map.insert (routeId $ snd xr) x'
-       (forall c. Data c => TransFuncS acc z c)
+                  return x'
-    extF = (`extMRAccS` (\(x,_) -> modify (accOneF x) >> return x))
-    
-    applyAccum' :: (forall a. Data a => TransFuncAcc acc a) ->
-           (forall b. Data b => (b, Route b A.AST) -> StateT acc (RestartT CheckOptM) b)
-    applyAccum' f (x, route)
-      = do when (findMeta x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x}
-           (x', acc) <- lift $ flip runStateT accEmpty (gmapMForRoute typeSet (extF wrap) x)
-           r <- f' (x', route, acc)
-           modify (`accJoinF` acc)
-           return r
-      where
-        wrap (y, route') = applyAccum' f (y, route @-> route')
-        
-        -- Keep applying the function while there is a Left return (which indicates
-        -- the value was replaced) until there is a Right return
-        f' (x, route, acc) = do
-          x' <- f (x, route, acc)
-          case x' of
-            Left y -> f' (y, route, foldl (flip accOneF) accEmpty (listify {-TODO-} (const True) y))
-            Right y -> return y
 
-applyTopDown :: TypeSet -> (forall a. Data a => TransFunc a) ->
+-- Keep applying the function while there is a Left return (which indicates
-             (forall b. Data b => (b, Route b A.AST) -> RestartT CheckOptM b)
+-- the value was replaced) until there is a Right return
-applyTopDown typeSet f (x, route)
+keepApplying :: Monad m => ((t, Route t outer) -> m (Either t t)) -> ((t, Route t outer) -> m t)
-      = do when (findMeta x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x}
+keepApplying f (x, route) = do
-           z <- f' (x, route)
-           gmapMForRoute typeSet (\(y, route') -> applyTopDown typeSet f (y, route @-> route')) z
-  where
-    -- Keep applying the function while there is a Left return (which indicates
-    -- the value was replaced) until there is a Right return
-    f' (x, route) = do
       x' <- f (x, route)
       case x' of
         Left y -> keepApplying f (y, route)

common/CommonTest.hs

@@ -21,7 +21,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- | A module with tests for various miscellaneous things in the common directory.
 module CommonTest (tests) where
 
-import Data.Generics
+import Data.Generics (Constr, Data, Typeable)
 import Test.HUnit hiding (State)
 
 import qualified AST as A

common/OccamEDSL.hs

@@ -30,7 +30,7 @@ module OccamEDSL (ExpInp, ExpInpT,
     becomes) where
 
 import Control.Monad.State hiding (guard)
-import Data.Generics
+import Data.Generics (Data)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Test.HUnit hiding (State)

common/TestFramework.hs

@@ -21,7 +21,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module TestFramework where
 
 import Control.Monad.Error
-import Data.Generics
+import Data.Generics (Data)
 import System.IO.Unsafe
 import Test.HUnit hiding (Testable)
 import Test.QuickCheck hiding (check)

common/TestUtils.hs

@@ -40,7 +40,7 @@ module TestUtils where
 
 import Control.Monad.State
 import Control.Monad.Writer
-import Data.Generics
+import Data.Generics (Data, Typeable)
 import qualified Data.Map as Map
 import System.Random
 import Test.HUnit hiding (State,Testable)

data/CompState.hs

@@ -23,7 +23,7 @@ import Control.Monad.Error
 import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Writer
-import Data.Generics (Data, Typeable)
+import Data.Generics (Data, Typeable, listify)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
@@ -496,6 +496,8 @@ instance FindMeta A.Name where
   findMeta = A.nameMeta
 
 -- Should stop being lazy, and put these as pattern matches:
+--
+-- TODO also, at least use Polyplate!
 findMeta_Data :: Data a => a -> Meta
 findMeta_Data = head . listify (const True)
 

data/Metadata.hs

@@ -21,7 +21,7 @@ module Metadata where
 
 {-! global : Haskell2Xml !-}
 
-import Data.Generics (Data, Typeable, listify)
+import Data.Generics (Data, Typeable)
 import Data.List
 import Numeric
 import Text.Printf

flow/FlowGraph.hs

@@ -51,7 +51,8 @@ import Data.Graph.Inductive hiding (run)
 import Data.Maybe
 
 import qualified AST as A
-import GenericUtils
+import CompState
+import Data.Generics.Polyplate.Route
 import Metadata
 import FlowUtils
 import Utils

flow/FlowGraphTest.hs

@@ -24,7 +24,7 @@ module FlowGraphTest (qcTests) where
 import Control.Monad.Identity
 import Control.Monad.State
 
-import Data.Generics
+import Data.Generics (Data)
 import Data.Graph.Inductive
 import Data.List
 import qualified Data.Map as Map
@@ -34,11 +34,14 @@ import Test.HUnit hiding (Node, State, Testable)
 import Test.QuickCheck
 
 import qualified AST as A
+import CompState
+import Data.Generics.Polyplate.Route
 import FlowGraph
 import Metadata
 import PrettyShow
 import TestFramework
 import TestUtils
+import Traversal
 import Utils
 
 -- | Makes a distinctive metatag for testing.  The function is one-to-one.
@@ -789,7 +792,7 @@ pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFu
     applyFunc (m,AlterSpec f) = routeModify f (g m)
     applyFunc (m,AlterNothing _) = return
     
-    g m = gmapM (mkM $ replaceM m (replaceMeta m))
+    g m = applyBottomUpM $ replaceM m (replaceMeta m)
 
 
 -- | It is important to have these functions in the right ratio.  The number of possible trees is

frontends/OccamPassesTest.hs

@@ -23,7 +23,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module OccamPassesTest (tests) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
 import Test.HUnit hiding (State)
 
 import qualified AST as A
@@ -32,6 +32,8 @@ import Metadata
 import qualified OccamPasses
 import Pass
 import TestUtils
+import Traversal
+import Types
 
 m :: Meta
 m = emptyMeta
@@ -138,15 +140,15 @@ testCheckConstants = TestList
     , testFail 33 (A.Option m [lit10, lit10, lit10, var] skip)
     ]
   where
-    testOK :: (PolyplateM a (TwoOpM PassM A.Dimension A.Option) () PassM
+    testOK :: (PolyplateM a (TwoOpM PassM A.Type A.Option) () PassM
-              ,PolyplateM a () (TwoOpM PassM A.Dimension A.Option) PassM
+              ,PolyplateM a () (TwoOpM PassM A.Type A.Option) PassM
               ,Show a, Data a) => Int -> a -> Test
     testOK n orig
         = TestCase $ testPass ("testCheckConstants" ++ show n)
                               orig OccamPasses.checkConstants orig
                               (return ())
-    testFail :: (PolyplateM a (TwoOpM PassM A.Dimension A.Option) () PassM
+    testFail :: (PolyplateM a (TwoOpM PassM A.Type A.Option) () PassM
-                ,PolyplateM a () (TwoOpM PassM A.Dimension A.Option) PassM
+                ,PolyplateM a () (TwoOpM PassM A.Type A.Option) PassM
                 ,Show a, Data a) => Int -> a -> Test
     testFail n orig
         = TestCase $ testPassShouldFail ("testCheckConstants" ++ show n)

frontends/OccamTypes.hs

@@ -648,6 +648,7 @@ type InferTypeOps
     `ExtOpMP` A.Alternative
     `ExtOpMP` A.Process
     `ExtOpMP` A.Variable
+    `ExtOpMP` A.Variant
 
 -- | Infer types.
 inferTypes :: Pass A.AST
@@ -658,16 +659,18 @@ inferTypes = occamOnlyPass "Infer types"
   where
     ops :: InferTypeOps
     ops = baseOp
-          `extOp` doExpression
+          `extOpMS` (ops, doStructured)
-          `extOp` doDimension
+          `extOpM` doExpression
-          `extOp` doSubscript
+          `extOpM` doDimension
-          `extOp` doArrayConstr
+          `extOpM` doSubscript
-          `extOp` doReplicator
+          `extOpM` doReplicator
-          `extOp` doAlternative
+          `extOpM` doAlternative
-          `extOp` doInputMode
+          `extOpM` doProcess
-          `extOp` doSpecification
+          `extOpM` doVariable
-          `extOp` doProcess
+          `extOpM` doVariant
-          `extOp` doVariable
+
+    recurse :: RecurseM PassM InferTypeOps
+    recurse = makeRecurseM ops
 
     descend :: DescendM PassM InferTypeOps
     descend = makeDescendM ops
@@ -834,7 +837,26 @@ inferTypes = occamOnlyPass "Infer types"
            inTypeContext (Just ct) (recurse sv) >>* A.InputCase m
     doInputMode _ im = inTypeContext (Just A.Int) $ descend im
 
-    doStructured :: Data a => Transform (A.Structured a)
+    doVariant :: Transform A.Variant
+    doVariant (A.Variant m n iis p)
+      = do ctx <- getTypeContext
+           ets <- case ctx of
+             Just x -> protocolItems m x
+             Nothing -> dieP m "Could not deduce protocol"
+           case ets of
+             Left {} -> dieP m "Simple protocol expected during input CASE"
+             Right ps -> case lookup n ps of
+               Nothing -> diePC m $ formatCode "Name % is not part of protocol %"
+                 n (fromJust ctx)
+               Just ts -> do iis' <- sequence [inTypeContext (Just t) $ recurse ii
+                                              | (t, ii) <- zip ts iis]
+                             p' <- recurse p
+                             return $ A.Variant m n iis' p'
+
+    doStructured :: ( PolyplateM (A.Structured t) InferTypeOps () PassM
+                    , PolyplateM (A.Structured t) () InferTypeOps PassM
+                    , Data t) => Transform (A.Structured t)
+
     doStructured (A.Spec mspec s@(A.Specification m n st) body)
         =  do (st', wrap) <- runReaderT (doSpecType n st) body
               -- Update the definition of each name after we handle it.
@@ -842,7 +864,11 @@ inferTypes = occamOnlyPass "Infer types"
               wrap (recurse body) >>* A.Spec mspec (A.Specification m n st')
     doStructured s = descend s
 
-    doSpecType :: Data a => A.Name -> A.SpecType -> ReaderT (A.Structured a) PassM A.SpecType
+    -- The second parameter is a modifier (wrapper) for the descent into the body
+    doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps () PassM
+                  , PolyplateM (A.Structured t) () InferTypeOps PassM
+                  , Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) PassM
+      (A.SpecType, PassM (A.Structured a) -> PassM (A.Structured a))
     doSpecType n st
         = case st of
             A.Place _ _ -> lift $ inTypeContext (Just A.Int) $ descend st >>* addId
@@ -1025,6 +1051,7 @@ inferTypes = occamOnlyPass "Infer types"
                     `extOpM` descend
                     `extOpM` descend
                     `extOpM` (doVariable r)
+                    `extOpM` descend
                 descend :: DescendM PassM InferTypeOps
                 descend = makeDescendM ops
 

frontends/OccamTypesTest.hs

@@ -22,7 +22,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module OccamTypesTest (vioTests) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
 import Test.HUnit hiding (State)
 
 import qualified AST as A

frontends/ParseRainTest.hs

@@ -35,7 +35,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- and then turn these into Patterns where any Meta tag that is "m" is ignored during the comparison.
 module ParseRainTest (tests) where
 
-import Data.Generics
+import Data.Generics (Data)
 import Prelude hiding (fail)
 import Test.HUnit
 import Text.ParserCombinators.Parsec (runParser,eof)

frontends/RainPassesTest.hs

@@ -31,7 +31,7 @@ module RainPassesTest (tests) where
 
 import Control.Monad.State
 import Control.Monad.Identity
-import Data.Generics
+import Data.Generics (Data, Typeable)
 import qualified Data.Map as Map
 import Test.HUnit hiding (State)
 

frontends/RainTypes.hs

@@ -19,7 +19,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module RainTypes (constantFoldPass, performTypeUnification) where
 
 import Control.Monad.State
-import Data.Generics (Data, showConstr, toConstr)
+import Data.Generics (Data, showConstr, toConstr, Typeable)
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe

frontends/RainTypesTest.hs

@@ -22,7 +22,7 @@ module RainTypesTest (vioTests) where
 import Control.Monad.State
 import Control.Monad.Error
 import Control.Monad.Writer
-import Data.Generics
+import Data.Generics (Data)
 import qualified Data.Map as Map
 import Test.HUnit hiding (State)
 

transformations/PassTest.hs

@@ -20,7 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module PassTest (tests) where
 
 import Control.Monad.State hiding (guard)
-import Data.Generics
+import Data.Generics (cast, Data, Typeable)
 import qualified Data.Map as Map
 import Test.HUnit hiding (State)
 

transformations/SimplifyAbbrevsTest.hs

@@ -20,7 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module SimplifyAbbrevsTest (tests) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
 import Test.HUnit hiding (State)
 
 import CompState

transformations/SimplifyTypesTest.hs

@@ -20,7 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module SimplifyTypesTest (tests) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
 import Test.HUnit hiding (State)
 
 import CompState