From 998cf1c005dde11e03dc6ba2df7f08e2e3d88deb Mon Sep 17 00:00:00 2001
From: Neil Brown <neil@twistedsquare.com>
Date: Thu, 9 Apr 2009 10:00:03 +0000
Subject: [PATCH] Fixed various bits of type-inference in OccamTypes

---
 common/Types.hs         |  4 ++--
 frontends/OccamTypes.hs | 31 +++++++++++++++++++++++++++----
 2 files changed, 29 insertions(+), 6 deletions(-)

diff --git a/common/Types.hs b/common/Types.hs
index d34b850..043dfae 100644
--- a/common/Types.hs
+++ b/common/Types.hs
@@ -337,9 +337,9 @@ returnTypesOfIntrinsic m s
 
 -- | Get the items in a channel's protocol (for typechecking).
 -- Returns Left if it's a simple protocol, Right if it's tagged.
-protocolItems :: (CSMR m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])])
+protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => a -> m (Either [A.Type] [(A.Name, [A.Type])])
 protocolItems v
-    =  do chanT <- typeOfVariable v
+    =  do chanT <- astTypeOf v
           t <- case chanT of
                  A.Chan _ t -> return t
                  A.ChanEnd _ _ t -> return t
diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs
index bc689d3..bf950e0 100644
--- a/frontends/OccamTypes.hs
+++ b/frontends/OccamTypes.hs
@@ -344,7 +344,7 @@ checkAllocMobile m rawT me
           case t of
             A.Mobile innerT ->
                do case innerT of
-                    A.Array ds _ -> mapM_ (checkFullDimension m) ds
+                    A.Array ds _ -> ok --mapM_ (checkFullDimension m) ds
                     _ -> ok
                   case me of
                     Just e ->
@@ -652,6 +652,7 @@ inferTypes = occamOnlyPass "Infer types"
           `extOpS` doStructured
           `extOp` doProcess
           `extOp` doVariable
+          `extOp` doVariant
 
     recurse :: Recurse
     recurse = makeRecurse ops
@@ -815,8 +816,28 @@ inferTypes = occamOnlyPass "Infer types"
            iis' <- sequence [inTypeContext (Just t) $ recurse ii
                             | (t, ii) <- zip ts iis]
            return $ A.InputSimple m iis'
+    doInputMode v (A.InputCase m sv)
+      = do ct <- astTypeOf v
+           inTypeContext (Just ct) (recurse sv) >>* A.InputCase m
     doInputMode _ im = inTypeContext (Just A.Int) $ descend im
 
+    doVariant :: Transform A.Variant
+    doVariant (A.Variant m n iis p)
+      = do ctx <- getTypeContext
+           ets <- case ctx of
+             Just x -> protocolItems 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 :: Data a => Transform (A.Structured a)
     doStructured (A.Spec mspec s@(A.Specification m n st) body)
         =  do st' <- runReaderT (doSpecType n st) body
@@ -1030,8 +1051,8 @@ inferTypes = occamOnlyPass "Infer types"
                     im' <- doInputMode v' im
                     return $ A.Input m v' im'
             A.Input m v im@(A.InputCase {})
-              -> do im' <- recurse im
-                    v' <- recurse v
+              -> do v' <- recurse v
+                    im' <- doInputMode v' im
                     return $ A.Input m v' im'
             _ -> descend p
       where
@@ -1060,7 +1081,9 @@ inferTypes = occamOnlyPass "Infer types"
                   ae' <- inTypeContext (Just at) $ recurse ae
                   return $ A.OutCounted m ce' ae'
         doOutputItem A.Any o = noTypeContext $ recurse o
-        doOutputItem t o = inTypeContext (Just t) $ recurse o
+        doOutputItem t (A.OutExpression m e)
+          = inTypeContext (Just t) (recurse e >>= inferAllocMobile m t)
+              >>* A.OutExpression m
 
     doVariable :: Transform A.Variable
     doVariable (A.SubscriptedVariable m s v)