Merged latest patches from trunk into Polyplate

common/ShowCode.hs

@@ -241,6 +241,8 @@ instance ShowOccam A.Type where
   showOccamM A.Any = tell ["ANY"]
   showOccamM (A.Timer _) = tell ["TIMER"]
   showOccamM A.Time = tell ["TIME"]
+  showOccamM A.Infer = tell ["inferred type"]
+  showOccamM A.Barrier = tell ["BARRIER"]
   showOccamM (A.UnknownVarType _ en)
     = do tell ["(inferred type for: "]
          either showName (tell . (:[]) . show) en

pass/Pass.hs

@@ -56,8 +56,10 @@ instance Warn PassM where
 -- against AST fragments of other types as well.
 type PassType t = t -> PassM t
 
-type PassOnOps ops
-  = (PolyplateM t ops () PassM, PolyplateM t () ops PassM) => Pass t
+type PassOnOpsM m ops
+  = (PolyplateM t ops () m, PolyplateM t () ops m) => Pass t
+
+type PassOnOps ops = PassOnOpsM PassM ops
 
 type CheckOnOps ops
   = (PolyplateSpine t ops () (PassM ())) => Pass t

pass/Traversal.hs

@@ -19,7 +19,7 @@ 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, TransformStructured'
+    TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM'
   , CheckM, Check
   , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct
   , ExtOpQS, extOpQS
@@ -205,3 +205,7 @@ type TransformStructured ops
 type TransformStructured' ops
   = (PolyplateM (A.Structured t) () ops PassM
     ,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t)
+
+type TransformStructuredM' m ops
+  = (PolyplateM (A.Structured t) () ops m
+    ,PolyplateM (A.Structured t) ops () m , Data t) => A.Structured t -> m (A.Structured t)

transformations/SimplifyProcs.hs

@@ -20,7 +20,8 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module SimplifyProcs (simplifyProcs, fixLowReplicators) where
 
 import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
+import Data.Maybe
 import qualified Data.Set as Set
 
 import qualified AST as A
@@ -42,18 +43,23 @@ simplifyProcs =
       , flattenAssign
       ]
 
+type ForkM = StateT [A.Name] PassM
+type ForkOps = ExtOpM ForkM (ExtOpMS ForkM BaseOp) A.Process
+
 -- | Add an extra barrier parameter to every PROC for FORKING
-addForkNames :: Pass
+addForkNames :: PassOnOpsM ForkM ForkOps
 addForkNames = occamOnlyPass "Add FORK labels" [] []
   (flip evalStateT [] . recurse)
   where
-    ops = baseOp `extOpS` doStructured `extOp` doProcess
+    ops :: ForkOps
+    ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
 
-    recurse, descend :: Data a => a -> StateT [A.Name] PassM a
-    recurse = makeRecurse ops
-    descend = makeDescend ops
+    recurse :: RecurseM ForkM ForkOps
+    recurse = makeRecurseM ops
+    descend :: DescendM ForkM ForkOps
+    descend = makeDescendM ops
 
-    doProcess :: A.Process -> StateT [A.Name] PassM A.Process
+    doProcess :: A.Process -> ForkM A.Process
     doProcess (A.Fork m Nothing p)
       = do (f:_) <- get
            p' <- recurse p
@@ -67,7 +73,7 @@ addForkNames = occamOnlyPass "Add FORK labels" [] []
              _ -> return $ A.ProcCall m n (A.ActualVariable (A.Variable m f) : as)
     doProcess p = descend p
 
-    doStructured :: Data a => A.Structured a -> StateT [A.Name] PassM (A.Structured a)
+    doStructured :: TransformStructuredM' ForkM ForkOps
     doStructured (A.Spec m spec@(A.Specification _ n (A.Forking _)) scope)
       = do modify (n:)
            scope' <- recurse scope

transformations/SimplifyTypes.hs

@@ -46,9 +46,15 @@ resolveNamedTypes
            (Prop.agg_namesDone
             ++ [Prop.expressionTypesChecked, Prop.processTypesChecked])
            [Prop.typesResolvedInAST, Prop.typesResolvedInState]
-           (\t -> do get >>= resolve >>= put
-                     resolve t)
+           (\t -> do get >>= resolve >>= flatten >>= put
+                     resolve t >>= flatten)
   where
     resolve :: PassTypeOn A.Type
-    resolve = applyTopDownM (underlyingType emptyMeta)
+    resolve = applyTopDownM (resolveUserType emptyMeta)
 
+    flatten :: PassTypeOn A.Type
+    flatten = applyBottomUpM doType
+      where
+        doType :: Transform A.Type
+        doType (A.Array dsA (A.Array dsB t)) = return $ A.Array (dsA++dsB) t
+        doType t = return t