Add a proper TLP interface checker

fco2/GenerateC.hs

@@ -13,6 +13,7 @@ import qualified AST as A
 import Metadata
 import ParseState
 import Errors
+import TLP
 import Types
 
 --{{{  monad definition
@@ -27,16 +28,21 @@ generateC st ast
             Left e -> die e
             Right (_, ss) -> return $ concat ss
 
+genTLPChannel :: TLPChannel -> CGen ()
+genTLPChannel TLPIn = tell ["in"]
+genTLPChannel TLPOut = tell ["out"]
+genTLPChannel TLPError = tell ["err"]
+
 genTopLevel :: A.Process -> CGen ()
 genTopLevel p
     =  do tell ["#include <fco_support.h>\n"]
           genProcess p
-
-          ps <- get
-          let mainName = snd $ head $ psMainLocals ps
+          (name, chans) <- tlpInterface
           tell ["void fco_main (Process *me, Channel *in, Channel *out, Channel *err) {\n"]
-          genName mainName
-          tell [" (me, in, out, err);\n"]
+          genName name
+          tell [" (me"]
+          sequence_ [tell [", "] >> genTLPChannel c | c <- chans]
+          tell [");\n"]
           tell ["}\n"]
 --}}}
 
@@ -52,9 +58,9 @@ withPS f
     =  do st <- get
           return $ f st
 
-checkJust :: Monad m => Maybe t -> m t
+checkJust :: MonadError String m => Maybe t -> m t
 checkJust (Just v) = return v
-checkJust Nothing = fail "checkJust failed"
+checkJust Nothing = throwError "checkJust failed"
 
 type SubscripterFunction = A.Variable -> A.Variable
 

fco2/Makefile

@@ -16,6 +16,7 @@ sources = \
 	PrettyShow.hs \
 	SimplifyExprs.hs \
 	SimplifyProcs.hs \
+	TLP.hs \
 	Types.hs \
 	Unnest.hs
 

fco2/Pass.hs

@@ -1,6 +1,7 @@
 -- | Common definitions for passes over the AST.
 module Pass where
 
+import Control.Monad.Error
 import Control.Monad.State
 import System.IO
 

fco2/TLP.hs

@@ -0,0 +1,53 @@
+-- | Top-level process support.
+module TLP where
+
+import Control.Monad.Error
+import Control.Monad.State
+import Data.Generics
+import Data.List
+import Data.Maybe
+
+import qualified AST as A
+import Metadata
+import ParseState
+import Types
+
+data TLPChannel = TLPIn | TLPOut | TLPError
+  deriving (Show, Eq, Typeable, Data)
+
+-- | Get the name of the TLP and the channels it uses.
+-- Fail if the process isn't using a valid interface.
+tlpInterface :: (MonadState ParseState m, MonadError String m) => m (A.Name, [TLPChannel])
+tlpInterface
+    =  do ps <- get
+          let mainName = snd $ head $ psMainLocals ps
+          formals <- case fromJust $ specTypeOfName ps mainName of
+                       A.Proc _ fs _ -> return fs
+                       _ -> throwError "Last definition is not a PROC"
+          chans <- mapM tlpChannel formals
+          when ((nub chans) /= chans) $ throwError "Channels used more than once in TLP"
+          return (mainName, chans)
+  where
+    tlpChannel :: (MonadState ParseState m, MonadError String m) => A.Formal -> m TLPChannel
+    tlpChannel (A.Formal _ (A.Chan A.Byte) n)
+        =  do ps <- get
+              let origN = A.ndOrigName $ fromJust $ psLookupName ps n
+              case lookup origN tlpChanNames of
+                Just c -> return c
+                _ -> throwError $ "TLP formal " ++ show n ++ " has unrecognised name"
+    tlpChannel (A.Formal _ _ n)
+        = throwError $ "TLP formal " ++ show n ++ " has unrecognised type"
+
+    tlpChanNames :: [(String, TLPChannel)]
+    tlpChanNames
+        = [ ("in", TLPIn)
+          , ("kb", TLPIn)
+          , ("keyb", TLPIn)
+          , ("keyboard", TLPIn)
+          , ("out", TLPOut)
+          , ("scr", TLPOut)
+          , ("screen", TLPOut)
+          , ("err", TLPError)
+          , ("error", TLPError)
+          ]
+