-- | Parse occam code into an AST.
module Parse where

-- FIXME: Need to:
-- - insert type checks
-- - remove as many trys as possible; every production should consume input
--   when it's unambiguous

import Data.List
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language (emptyDef)
import qualified IO
import Numeric (readHex)

import qualified AST as A
import Metadata
import ParseState
import Errors
import Indentation
import Types

--{{{ setup stuff for Parsec
type OccParser = GenParser Char ParseState

occamStyle
    = emptyDef
    { P.commentLine    = "--"
    , P.nestedComments = False
    , P.identStart     = letter
    , P.identLetter    = alphaNum <|> char '.'
    , P.opStart        = oneOf "+-*/\\>=<~"
    , P.opLetter       = oneOf "/\\>=<"
    , P.reservedOpNames= [
                          "+",
                          "-",
                          "*",
                          "/",
                          "\\",
                          "/\\",
                          "\\/",
                          "><",
                          "=",
                          "<>",
                          "<",
                          ">",
                          ">=",
                          "<=",
                          "-",
                          "~"
                         ]
    , P.reservedNames  = [
                          "AFTER",
                          "ALT",
                          "AND",
                          "ANY",
                          "AT",
                          "BITAND",
                          "BITNOT",
                          "BITOR",
                          "BOOL",
                          "BYTE",
                          "BYTESIN",
                          "CASE",
                          "CHAN",
                          "DATA",
                          "ELSE",
                          "FALSE",
                          "FOR",
                          "FROM",
                          "FUNCTION",
                          "IF",
                          "INT",
                          "INT16",
                          "INT32",
                          "INT64",
                          "IS",
                          "MINUS",
                          "MOSTNEG",
                          "MOSTPOS",
                          "NOT",
                          "OF",
                          "OFFSETOF",
                          "OR",
                          "PACKED",
                          "PAR",
                          "PLACE",
                          "PLACED",
                          "PLUS",
                          "PORT",
                          "PRI",
                          "PROC",
                          "PROCESSOR",
                          "PROTOCOL",
                          "REAL32",
                          "REAL64",
                          "RECORD",
                          "REM",
                          "RESHAPES",
                          "RESULT",
                          "RETYPES",
                          "ROUND",
                          "SEQ",
                          "SIZE",
                          "SKIP",
                          "STOP",
                          "TIMER",
                          "TIMES",
                          "TRUE",
                          "TRUNC",
                          "TYPE",
                          "VAL",
                          "VALOF",
                          "WHILE",
                          indentMarker,
                          outdentMarker,
                          eolMarker,
                          mainMarker
                         ]
    , P.caseSensitive  = True
    }

lexer :: P.TokenParser ParseState
lexer  = P.makeTokenParser occamStyle

-- XXX replace whitespace with something that doesn't eat \ns

whiteSpace = P.whiteSpace lexer
lexeme = P.lexeme lexer
symbol = P.symbol lexer
natural = P.natural lexer
parens = P.parens lexer
semi = P.semi lexer
identifier = P.identifier lexer
reserved = P.reserved lexer
reservedOp = P.reservedOp lexer
--}}}

--{{{ symbols
sLeft = try $ symbol "["
sRight = try $ symbol "]"
sLeftR = try $ symbol "("
sRightR = try $ symbol ")"
sAssign = try $ symbol ":="
sColon = try $ symbol ":"
sColons = try $ symbol "::"
sComma = try $ symbol ","
sSemi = try $ symbol ";"
sAmp = try $ symbol "&"
sQuest = try $ symbol "?"
sBang = try $ symbol "!"
sEq = try $ symbol "="
sApos = try $ symbol "'"
sQuote = try $ symbol "\""
sHash = try $ symbol "#"
--}}}
--{{{ keywords
sAFTER = reserved "AFTER"
sALT = reserved "ALT"
sAND = reserved "AND"
sANY = reserved "ANY"
sAT = reserved "AT"
sBITAND = reserved "BITAND"
sBITNOT = reserved "BITNOT"
sBITOR = reserved "BITOR"
sBOOL = reserved "BOOL"
sBYTE = reserved "BYTE"
sBYTESIN = reserved "BYTESIN"
sCASE = reserved "CASE"
sCHAN = reserved "CHAN"
sDATA = reserved "DATA"
sELSE = reserved "ELSE"
sFALSE = reserved "FALSE"
sFOR = reserved "FOR"
sFROM = reserved "FROM"
sFUNCTION = reserved "FUNCTION"
sIF = reserved "IF"
sINT = reserved "INT"
sINT16 = reserved "INT16"
sINT32 = reserved "INT32"
sINT64 = reserved "INT64"
sIS = reserved "IS"
sMINUS = reserved "MINUS"
sMOSTNEG = reserved "MOSTNEG"
sMOSTPOS = reserved "MOSTPOS"
sNOT = reserved "NOT"
sOF = reserved "OF"
sOFFSETOF = reserved "OFFSETOF"
sOR = reserved "OR"
sPACKED = reserved "PACKED"
sPAR = reserved "PAR"
sPLACE = reserved "PLACE"
sPLACED = reserved "PLACED"
sPLUS = reserved "PLUS"
sPORT = reserved "PORT"
sPRI = reserved "PRI"
sPROC = reserved "PROC"
sPROCESSOR = reserved "PROCESSOR"
sPROTOCOL = reserved "PROTOCOL"
sREAL32 = reserved "REAL32"
sREAL64 = reserved "REAL64"
sRECORD = reserved "RECORD"
sREM = reserved "REM"
sRESHAPES = reserved "RESHAPES"
sRESULT = reserved "RESULT"
sRETYPES = reserved "RETYPES"
sROUND = reserved "ROUND"
sSEQ = reserved "SEQ"
sSIZE = reserved "SIZE"
sSKIP = reserved "SKIP"
sSTOP = reserved "STOP"
sTIMER = reserved "TIMER"
sTIMES = reserved "TIMES"
sTRUE = reserved "TRUE"
sTRUNC = reserved "TRUNC"
sTYPE = reserved "TYPE"
sVAL = reserved "VAL"
sVALOF = reserved "VALOF"
sWHILE = reserved "WHILE"
--}}}
--{{{ markers inserted by the preprocessor
-- XXX could handle VALOF by translating each step to one { and matching multiple ones?
mainMarker = "__main"

sMainMarker = do { whiteSpace; reserved mainMarker } <?> "end of input (top-level process)"

indent = do { whiteSpace; reserved indentMarker } <?> "indentation increase"
outdent = do { whiteSpace; reserved outdentMarker } <?> "indentation decrease"
eol = do { whiteSpace; reserved eolMarker } <?> "end of line"
--}}}

--{{{ helper functions
getSourcePos :: OccParser OccSourcePos
getSourcePos
  =  do pos <- getPosition
        return $ OccSourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos)

md :: OccParser Meta
md
  =  do pos <- getSourcePos
        return [MdSourcePos pos]

tryVX :: OccParser a -> OccParser b -> OccParser a
tryVX p q = try (do { v <- p; q; return v })

tryXV :: OccParser a -> OccParser b -> OccParser b
tryXV p q = try (do { p; q })

tryXVV :: OccParser a -> OccParser b -> OccParser c -> OccParser (b, c)
tryXVV a b c = try (do { a; bv <- b; cv <- c; return (bv, cv) })

tryXVX :: OccParser a -> OccParser b -> OccParser c -> OccParser b
tryXVX a b c = try (do { a; bv <- b; c; return bv })

tryVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser (a, c)
tryVXV a b c = try (do { av <- a; b; cv <- c; return (av, cv) })

maybeSubscripted :: String -> OccParser a -> (Meta -> A.Subscript -> a -> a) -> (a -> OccParser A.Type) -> OccParser a
maybeSubscripted prodName inner subscripter typer
    =  do m <- md
          v <- inner
          t <- typer v
          subs <- postSubscripts t
          return $ foldl (\var sub -> subscripter m sub var) v subs
    <?> prodName

postSubscripts :: A.Type -> OccParser [A.Subscript]
postSubscripts t
    = (do sub <- postSubscript t
          t' <- pSubscriptType sub t
          rest <- postSubscripts t'
          return $ sub : rest)
      <|> return []

postSubscript :: A.Type -> OccParser A.Subscript
postSubscript t
    =  do m <- md
          case t of
            A.UserDataType _ ->
              do f <- tryXV sLeft fieldName
                 sRight
                 return $ A.SubscriptField m f
            A.Array _ _ ->
              do e <- tryXV sLeft intExpr
                 sRight
                 return $ A.Subscript m e
            _ ->
              fail $ "subscript of non-array/record type " ++ show t

maybeSliced :: OccParser a -> (Meta -> A.Subscript -> a -> a) -> (a -> OccParser A.Type) -> OccParser a
maybeSliced inner subscripter typer
    =  do m <- md

          (v, ff1) <- tryXVV sLeft inner fromOrFor
          t <- typer v
          case t of
            (A.Array _ _) -> return ()
            _ -> fail $ "slice of non-array type " ++ show t

          e <- intExpr
          sub <- case ff1 of
                   "FROM" ->
                     (do f <- tryXV sFOR intExpr
                         sRight
                         return $ A.SubscriptFromFor m e f)
                     <|>
                     (do sRight
                         return $ A.SubscriptFrom m e)
                   "FOR" ->
                     do sRight
                        return $ A.SubscriptFor m e

          return $ subscripter m sub v
  where
    fromOrFor :: OccParser String
    fromOrFor = (sFROM >> return "FROM") <|> (sFOR >> return "FOR")

handleSpecs :: OccParser [A.Specification] -> OccParser a -> (Meta -> A.Specification -> a -> a) -> OccParser a
handleSpecs specs inner specMarker
    =   do m <- md
           ss <- specs
           ss' <- mapM scopeInSpec ss
           v <- inner
           mapM scopeOutSpec ss'
           return $ foldl (\e s -> specMarker m s e) v ss'

-- | Like sepBy1, but not eager: it won't consume the separator unless it finds
-- another item after it.
sepBy1NE :: OccParser a -> OccParser b -> OccParser [a]
sepBy1NE item sep
    =  do i <- item
          rest <- option [] $ try (do sep
                                      sepBy1NE item sep)
          return $ i : rest

-- | Run several different parsers with a separator between them.
-- If you give it [a, b, c] and s, it'll parse [a, s, b, s, c] then
-- give you back the results from [a, b, c].
intersperseP :: [OccParser a] -> OccParser b -> OccParser [a]
intersperseP [] _ = return []
intersperseP [f] _
    =  do a <- f
          return [a]
intersperseP (f:fs) sep
    =  do a <- f
          sep
          as <- intersperseP fs sep
          return $ a : as

listType :: Meta -> [A.Type] -> OccParser A.Type
listType m l = listType' m (length l) l
  where
    listType' m len [] = fail "expected non-empty list"
    listType' m len [t] = return $ makeArrayType (A.Dimension $ makeConstant m len) t
    listType' m len (t1 : rest@(t2 : _))
        = if t1 == t2 then listType' m len rest
                      else fail "multiple types in list"

matchType :: A.Type -> A.Type -> OccParser ()
matchType et rt
    = case (et, rt) of
        ((A.Array ds t), (A.Array ds' t')) ->
          if length ds == length ds' then return () else bad
        _ -> if rt == et then return () else bad
  where
    bad = fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")"

checkMaybe :: String -> Maybe a -> OccParser a
checkMaybe msg op
    = case op of
        Just t -> return t
        Nothing -> fail msg

pTypeOf :: (ParseState -> a -> Maybe b) -> a -> OccParser b
pTypeOf f item
    =  do st <- getState
          checkMaybe "cannot compute type" $ f st item

pTypeOfVariable = pTypeOf typeOfVariable
pTypeOfLiteral = pTypeOf typeOfLiteral
pTypeOfExpression = pTypeOf typeOfExpression
pSpecTypeOfName = pTypeOf specTypeOfName

pSubscriptType :: A.Subscript -> A.Type -> OccParser A.Type
pSubscriptType sub t
    =  do st <- getState
          checkMaybe "cannot subscript type" $ subscriptType st sub t
--}}}

--{{{ name scoping
findName :: A.Name -> OccParser A.Name
findName thisN
    =  do st <- getState
          origN <- case lookup (A.nameName thisN) (psLocalNames st) of
                     Nothing -> fail $ "name " ++ A.nameName thisN ++ " not defined"
                     Just n -> return n
          if A.nameType thisN /= A.nameType origN
            then fail $ "expected " ++ show (A.nameType thisN) ++ " (" ++ A.nameName origN ++ " is " ++ show (A.nameType origN) ++ ")"
            else return $ thisN { A.nameName = A.nameName origN }

scopeIn :: A.Name -> A.SpecType -> A.AbbrevMode -> OccParser A.Name
scopeIn n@(A.Name m nt s) t am
    =  do st <- getState
          let s' = s ++ "_u" ++ (show $ psNameCounter st)
          let n' = n { A.nameName = s' }
          let nd = A.NameDef {
            A.ndMeta = m,
            A.ndName = s',
            A.ndOrigName = s,
            A.ndNameType = A.nameType n',
            A.ndType = t,
            A.ndAbbrevMode = am
          }
          setState $ psDefineName n' nd $ st {
            psNameCounter = (psNameCounter st) + 1,
            psLocalNames = (s, n') : (psLocalNames st)
            }
          return n'

scopeOut :: A.Name -> OccParser ()
scopeOut n@(A.Name m nt s)
    =  do st <- getState
          let lns' = case psLocalNames st of
                       (s, _):ns -> ns
                       otherwise -> dieInternal "scopeOut trying to scope out the wrong name"
          setState $ st { psLocalNames = lns' }

-- FIXME: Do these with generics? (going carefully to avoid nested code blocks)
scopeInRep :: A.Replicator -> OccParser A.Replicator
scopeInRep (A.For m n b c)
    =  do n' <- scopeIn n (A.Declaration m A.Int) A.ValAbbrev
          return $ A.For m n' b c

scopeOutRep :: A.Replicator -> OccParser ()
scopeOutRep (A.For m n b c) = scopeOut n

scopeInSpec :: A.Specification -> OccParser A.Specification
scopeInSpec (A.Specification m n st)
    =  do n' <- scopeIn n st (abbrevModeOfSpec st)
          return $ A.Specification m n' st

scopeOutSpec :: A.Specification -> OccParser ()
scopeOutSpec (A.Specification _ n _) = scopeOut n

scopeInFormal :: A.Formal -> OccParser A.Formal
scopeInFormal (A.Formal am t n)
    =  do n' <- scopeIn n (A.Declaration (A.nameMeta n) t) am
          return (A.Formal am t n')

scopeInFormals :: [A.Formal] -> OccParser [A.Formal]
scopeInFormals fs = mapM scopeInFormal fs

scopeOutFormals :: [A.Formal] -> OccParser ()
scopeOutFormals fs = sequence_ [scopeOut n | (A.Formal am t n) <- fs]

--}}}

--{{{ grammar productions
-- These productions are (now rather loosely) based on the ordered syntax in
-- the occam2.1 manual.
--
-- Each production is allowed to consume the thing it's trying to match.

--{{{ names
anyName :: A.NameType -> OccParser A.Name
anyName nt
    =   do m <- md
           s <- identifier
           return $ A.Name m nt s
    <?> show nt

name :: A.NameType -> OccParser A.Name
name nt
    =   do n <- anyName nt
           findName n

newName :: A.NameType -> OccParser A.Name
newName nt = anyName nt

channelName = name A.ChannelName
dataTypeName = name A.DataTypeName
functionName = name A.FunctionName
portName = name A.PortName
procName = name A.ProcName
protocolName = name A.ProtocolName
timerName = name A.TimerName
variableName = name A.VariableName

newChannelName = newName A.ChannelName
newDataTypeName = newName A.DataTypeName
newFunctionName = newName A.FunctionName
newPortName = newName A.PortName
newProcName = newName A.ProcName
newProtocolName = newName A.ProtocolName
newTimerName = newName A.TimerName
newVariableName = newName A.VariableName

-- These are special because their scope is only valid within the particular
-- record or protocol they're used in.
fieldName = anyName A.FieldName
tagName = anyName A.TagName
newFieldName = anyName A.FieldName
newTagName = anyName A.TagName
--}}}
--{{{ types
dataType :: OccParser A.Type
dataType
    =   do { sBOOL; return A.Bool }
    <|> do { sBYTE; return A.Byte }
    <|> do { sINT; return A.Int }
    <|> do { sINT16; return A.Int16 }
    <|> do { sINT32; return A.Int32 }
    <|> do { sINT64; return A.Int64 }
    <|> do { sREAL32; return A.Real32 }
    <|> do { sREAL64; return A.Real64 }
    <|> try (do { sLeft; s <- constIntExpr; sRight; t <- dataType; return $ makeArrayType (A.Dimension s) t })
    <|> do { n <- dataTypeName; return $ A.UserDataType n }
    <?> "dataType"

-- FIXME should probably make CHAN INT work, since that'd be trivial...
channelType :: OccParser A.Type
channelType
    =   do { sCHAN; sOF; p <- protocol; return $ A.Chan p }
    <|> try (do { sLeft; s <- constIntExpr; sRight; t <- channelType; return $ makeArrayType (A.Dimension s) t })
    <?> "channelType"

timerType :: OccParser A.Type
timerType
    =   do { sTIMER; return $ A.Timer }
    <|> try (do { sLeft; s <- constIntExpr; sRight; t <- timerType; return $ makeArrayType (A.Dimension s) t })
    <?> "timerType"

portType :: OccParser A.Type
portType
    =   do { sPORT; sOF; p <- dataType; return $ A.Port p }
    <|> do { m <- md; try sLeft; s <- try constIntExpr; try sRight; t <- portType; return $ makeArrayType (A.Dimension s) t }
    <?> "portType"
--}}}
--{{{ literals
literal :: OccParser A.Literal
literal
    =   try (do { m <- md; v <- real; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
    <|> try (do { m <- md; v <- integer; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
    <|> try (do { m <- md; v <- byte; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
    <|> try (do { m <- md; r <- real; return $ A.Literal m A.Real32 r })
    <|> try (do { m <- md; r <- integer; return $ A.Literal m A.Int r })
    <|> try (do { m <- md; r <- byte; return $ A.Literal m A.Byte r })
    <?> "literal"

real :: OccParser A.LiteralRepr
real
    =   try (do m <- md
                l <- digits
                char '.'
                r <- digits
                char 'e'
                e <- lexeme occamExponent
                return $ A.RealLiteral m (l ++ "." ++ r ++ "e" ++ e))
    <|> do m <- md
           l <- digits
           char '.'
           r <- lexeme digits
           return $ A.RealLiteral m (l ++ "." ++ r)
    <?> "real"

occamExponent :: OccParser String
occamExponent
    =   try (do { c <- oneOf "+-"; d <- digits; return $ c : d })
    <?> "exponent"

integer :: OccParser A.LiteralRepr
integer
    =   try (do { m <- md; d <- lexeme digits; return $ A.IntLiteral m d })
    <|> do { m <- md; sHash; d <- many1 hexDigit; return $ A.HexLiteral m d }
    <?> "integer"

digits :: OccParser String
digits
    =   many1 digit
    <?> "digits"

byte :: OccParser A.LiteralRepr
byte
    =   do { m <- md; char '\''; s <- character; sApos; return $ A.ByteLiteral m s }
    <?> "byte"

-- i.e. array literal
table :: OccParser A.Literal
table
    = maybeSubscripted "table" table' A.SubscriptedLiteral pTypeOfLiteral

table' :: OccParser A.Literal
table'
    -- FIXME Check dimensions match
    =   try (do { m <- md; (s, dim) <- stringLiteral; sLeftR; t <- dataType; sRightR; return $ A.Literal m t s })
    <|> try (do { m <- md; (s, dim) <- stringLiteral; return $ A.Literal m (A.Array [dim] A.Byte) s })
    <|> do m <- md
           es <- tryXVX sLeft (sepBy1 expression sComma) sRight
           ps <- getState
           ets <- mapM (\e -> checkMaybe "can't type expression" $ typeOfExpression ps e) es
           t <- listType m ets
           return $ A.Literal m t (A.ArrayLiteral m es)
    <|> maybeSliced table A.SubscriptedLiteral pTypeOfLiteral
    <?> "table'"

stringLiteral :: OccParser (A.LiteralRepr, A.Dimension)
stringLiteral
    =   do { m <- md; char '"'; cs <- manyTill character sQuote; return $ (A.StringLiteral m $ concat cs, A.Dimension $ makeConstant m $ length cs) }
    <?> "stringLiteral"

character :: OccParser String
character
    =   try (do { char '*' ;
                  do char '#'
                     a <- hexDigit
                     b <- hexDigit
                     return $ ['*', '#', a, b]
                  -- FIXME: Handle *\n, which is just a line continuation?
                  <|> do { c <- anyChar; return ['*', c] } })
    <|> do { c <- anyChar; return [c] }
    <?> "character"
--}}}
--{{{ expressions
expressionList :: OccParser A.ExpressionList
expressionList
    =   try (do { m <- md; n <- functionName; sLeftR; as <- sepBy expression sComma; sRightR; return $ A.FunctionCallList m n as })
    <|> do { m <- md; es <- sepBy1 expression sComma; return $ A.ExpressionList m es }
-- XXX: Value processes are not supported (because nobody uses them and they're hard to parse)
    <?> "expressionList"

expression :: OccParser A.Expression
expression
    =   do { m <- md; o <- monadicOperator; v <- operand; return $ A.Monadic m o v }
    <|> do { m <- md; sMOSTPOS; t <- dataType; return $ A.MostPos m t }
    <|> do { m <- md; sMOSTNEG; t <- dataType; return $ A.MostNeg m t }
    <|> sizeExpr
    <|> do { m <- md; sTRUE; return $ A.True m }
    <|> do { m <- md; sFALSE; return $ A.False m }
    <|> try (do { m <- md; l <- operand; o <- dyadicOperator; r <- operand; return $ A.Dyadic m o l r })
    <|> try conversion
    <|> operand
    <?> "expression"

sizeExpr :: OccParser A.Expression
sizeExpr
    =  do m <- md
          sSIZE
          (try (do { t <- dataType; return $ A.SizeType m t })
           <|> do { v <- operand; return $ A.SizeExpr m v })
    <?> "sizeExpr"

exprOfType :: A.Type -> OccParser A.Expression
exprOfType wantT
    =  do e <- expression
          t <- pTypeOfExpression e
          matchType wantT t
          return e

intExpr = exprOfType A.Int <?> "integer expression"
booleanExpr = exprOfType A.Bool <?> "boolean expression"

constExprOfType :: A.Type -> OccParser A.Expression
constExprOfType wantT
    =  do e <- exprOfType wantT
          ps <- getState
          if isConstExpression ps e
            then return e
            else fail "expected constant expression"

constIntExpr = constExprOfType A.Int <?> "constant integer expression"

monadicOperator :: OccParser A.MonadicOp
monadicOperator
    =   do { reservedOp "-" <|> sMINUS; return A.MonadicSubtr }
    <|> do { reservedOp "~" <|> sBITNOT; return A.MonadicBitNot }
    <|> do { sNOT; return A.MonadicNot }
    <?> "monadicOperator"

dyadicOperator :: OccParser A.DyadicOp
dyadicOperator
    =   do { reservedOp "+"; return A.Add }
    <|> do { reservedOp "-"; return A.Subtr }
    <|> do { reservedOp "*"; return A.Mul }
    <|> do { reservedOp "/"; return A.Div }
    <|> do { reservedOp "\\"; return A.Rem }
    <|> do { sREM; return A.Rem }
    <|> do { sPLUS; return A.Plus }
    <|> do { sMINUS; return A.Minus }
    <|> do { sTIMES; return A.Times }
    <|> do { reservedOp "/\\" <|> sBITAND; return A.BitAnd }
    <|> do { reservedOp "\\/" <|> sBITOR; return A.BitOr }
    <|> do { reservedOp "><"; return A.BitXor }
    <|> do { sAND; return A.And }
    <|> do { sOR; return A.Or }
    <|> do { reservedOp "="; return A.Eq }
    <|> do { reservedOp "<>"; return A.NotEq }
    <|> do { reservedOp "<"; return A.Less }
    <|> do { reservedOp ">"; return A.More }
    <|> do { reservedOp "<="; return A.LessEq }
    <|> do { reservedOp ">="; return A.MoreEq }
    <|> do { sAFTER; return A.After }
    <?> "dyadicOperator"

conversion :: OccParser A.Expression
conversion
    =   try (do m <- md
                t <- dataType
                (c, o) <- conversionMode
                return $ A.Conversion m c t o)
    <?> "conversion"

conversionMode :: OccParser (A.ConversionMode, A.Expression)
conversionMode
    =   do { sROUND; o <- operand; return (A.Round, o) }
    <|> do { sTRUNC; o <- operand; return (A.Trunc, o) }
    -- This uses operandNotTable to resolve the "x[y]" ambiguity.
    <|> do { o <- operandNotTable; return (A.DefaultConversion, o) }
    <?> "conversionMode"
--}}}
--{{{ operands
operand :: OccParser A.Expression
operand
    = maybeSubscripted "operand" operand' A.SubscriptedExpr pTypeOfExpression

operand' :: OccParser A.Expression
operand'
    =   try (do { m <- md; l <- table; return $ A.ExprLiteral m l })
    <|> operandNotTable'
    <?> "operand'"

operandNotTable :: OccParser A.Expression
operandNotTable
    = maybeSubscripted "operandNotTable" operandNotTable' A.SubscriptedExpr pTypeOfExpression

operandNotTable' :: OccParser A.Expression
operandNotTable'
    =   try (do { m <- md; v <- variable; return $ A.ExprVariable m v })
    <|> try (do { m <- md; l <- literal; return $ A.ExprLiteral m l })
    <|> try (do { sLeftR; e <- expression; sRightR; return e })
-- XXX value process
    <|> try (do { m <- md; n <- functionName; sLeftR; as <- sepBy expression sComma; sRightR; return $ A.FunctionCall m n as })
    <|> try (do { m <- md; sBYTESIN; sLeftR; o <- operand; sRightR; return $ A.BytesInExpr m o })
    <|> try (do { m <- md; sBYTESIN; sLeftR; t <- dataType; sRightR; return $ A.BytesInType m t })
    <|> try (do { m <- md; sOFFSETOF; sLeftR; t <- dataType; sComma; f <- fieldName; sRightR; return $ A.OffsetOf m t f })
    <?> "operandNotTable'"
--}}}
--{{{ variables, channels, timers, ports
variable :: OccParser A.Variable
variable
    = maybeSubscripted "variable" variable' A.SubscriptedVariable pTypeOfVariable

variable' :: OccParser A.Variable
variable'
    =   try (do { m <- md; n <- variableName; return $ A.Variable m n })
    <|> try (maybeSliced variable A.SubscriptedVariable pTypeOfVariable)
    <?> "variable'"

channel :: OccParser A.Variable
channel
    =   maybeSubscripted "channel" channel' A.SubscriptedVariable pTypeOfVariable
    <?> "channel"

channel' :: OccParser A.Variable
channel'
    =   try (do { m <- md; n <- channelName; return $ A.Variable m n })
    <|> try (maybeSliced channel A.SubscriptedVariable pTypeOfVariable)
    <?> "channel'"

timer :: OccParser A.Variable
timer
    =   maybeSubscripted "timer" timer' A.SubscriptedVariable pTypeOfVariable
    <?> "timer"

timer' :: OccParser A.Variable
timer'
    =   try (do { m <- md; n <- timerName; return $ A.Variable m n })
    <|> try (maybeSliced timer A.SubscriptedVariable pTypeOfVariable)
    <?> "timer'"

port :: OccParser A.Variable
port
    =   maybeSubscripted "port" port' A.SubscriptedVariable pTypeOfVariable
    <?> "port"

port' :: OccParser A.Variable
port'
    =   try (do { m <- md; n <- portName; return $ A.Variable m n })
    <|> try (maybeSliced port A.SubscriptedVariable pTypeOfVariable)
    <?> "port'"
--}}}
--{{{ protocols
protocol :: OccParser A.Type
protocol
    =   try (do { n <- protocolName ; return $ A.UserProtocol n })
    <|> simpleProtocol
    <?> "protocol"

simpleProtocol :: OccParser A.Type
simpleProtocol
    =   try (do { l <- dataType; sColons; sLeft; sRight; r <- dataType; return $ A.Counted l r })
    <|> dataType
    <|> do { sANY; return $ A.Any }
    <?> "simpleProtocol"

sequentialProtocol :: OccParser [A.Type]
sequentialProtocol
    =   do { l <- try $ sepBy1 simpleProtocol sSemi; return l }
    <?> "sequentialProtocol"

taggedProtocol :: OccParser (A.Name, [A.Type])
taggedProtocol
    =   try (do { t <- newTagName; eol; return (t, [])  })
    <|> try (do { t <- newTagName; sSemi; sp <- sequentialProtocol; eol; return (t, sp) })
    <?> "taggedProtocol"
--}}}
--{{{ replicators
replicator :: OccParser A.Replicator
replicator
    =  do m <- md
          n <- tryVX newVariableName sEq
          b <- intExpr
          sFOR
          c <- intExpr
          return $ A.For m n b c
    <?> "replicator"
--}}}
--{{{ specifications, declarations, allocations
allocation :: OccParser [A.Specification]
allocation
    =   do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [A.Specification m n (A.Place m e)] }
    <?> "allocation"

specification :: OccParser [A.Specification]
specification
    =   try (do { m <- md; (ns, d) <- declaration; return [A.Specification m n d | n <- ns] })
    <|> try (do { a <- abbreviation; return [a] })
    <|> do { d <- definition; return [d] }
    <?> "specification"

declaration :: OccParser ([A.Name], A.SpecType)
declaration
    =   do { m <- md; d <- dataType; ns <- sepBy1 newVariableName sComma; sColon; eol; return (ns, A.Declaration m d) }
    <|> do { m <- md; d <- channelType; ns <- sepBy1 newChannelName sComma; sColon; eol; return (ns, A.Declaration m d) }
    <|> do { m <- md; d <- timerType; ns <- sepBy1 newTimerName sComma; sColon; eol; return (ns, A.Declaration m d) }
    <|> do { m <- md; d <- portType; ns <- sepBy1 newPortName sComma; sColon; eol; return (ns, A.Declaration m d) }
    <?> "declaration"

abbreviation :: OccParser A.Specification
abbreviation
    =   do m <- md
           (do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification m n $ A.Is m A.Abbrev t v }
            <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s v }
            <|> do { sVAL ;
                      do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e }
                      <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev s e } }
            <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
            <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
            <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c })
            <|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
            <|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
            <|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c })
            <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return $ A.Specification m n $ A.IsChannelArray m t cs })
            <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification m n $ A.IsChannelArray m s cs }))
    <?> "abbreviation"

definition :: OccParser A.Specification
definition
    =   do {  m <- md; sDATA; sTYPE; n <- newDataTypeName ;
              do {sIS; t <- dataType; sColon; eol; return $ A.Specification m n (A.DataType m t) }
              <|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification m n rec } }
    <|> do {  m <- md; sPROTOCOL; n <- newProtocolName ;
              do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification m n $ A.Protocol m p }
              <|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return $ A.Specification m n $ A.ProtocolCase m ps } }
    <|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Proc m fs' p }
    <|> try (do { m <- md; rs <- sepBy1 dataType sComma; (n, fs) <- functionHeader ;
                  do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m rs fs' (A.ValOf m (A.Skip m) el) }
                  <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m rs fs' vp } })
    <|> try (do { m <- md; s <- specifier; n <- newVariableName ;
                  sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return $ A.Specification m n $ A.Retypes m A.Abbrev s v })
    <|> try (do {  m <- md; sVAL; s <- specifier; n <- newVariableName ;
                   sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return $ A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e })
    <?> "definition"

dataSpecifier :: OccParser A.Type
dataSpecifier
    =   try dataType
    <|> try (do { sLeft; sRight; s <- dataSpecifier; return $ makeArrayType A.UnknownDimension s })
    <?> "dataSpecifier"

specifier :: OccParser A.Type
specifier
    =   try dataType
    <|> try channelType
    <|> try timerType
    <|> try portType
    <|> try (do { sLeft; sRight; s <- specifier; return $ makeArrayType A.UnknownDimension s })
    <?> "specifier"

--{{{ PROCs and FUNCTIONs
formalList :: OccParser [A.Formal]
formalList
    =  do m <- md
          sLeftR
          fs <- sepBy formalArgSet sComma
          sRightR
          return $ concat fs
    <?> "formalList"

formalArgSet :: OccParser [A.Formal]
formalArgSet
    =   try (do (am, t) <- formalVariableType
                ns <- sepBy1NE newVariableName sComma
                return [A.Formal am t n | n <- ns])
    <|> do t <- specifier
           ns <- sepBy1NE newChannelName sComma
           return [A.Formal A.Abbrev t n | n <- ns]
    <?> "formalArgSet"

formalVariableType :: OccParser (A.AbbrevMode, A.Type)
    =   try (do { sVAL; s <- dataSpecifier; return (A.ValAbbrev, s) })
    <|> do { s <- dataSpecifier; return (A.Abbrev, s) }
    <?> "formalVariableType"

functionHeader :: OccParser (A.Name, [A.Formal])
functionHeader
    =   do { sFUNCTION; n <- newFunctionName; fs <- formalList; return $ (n, fs) }
    <?> "functionHeader"

valueProcess :: OccParser A.ValueProcess
valueProcess
    =   try (do { m <- md; sVALOF; eol; indent; p <- process; sRESULT; el <- expressionList; eol; outdent; return $ A.ValOf m p el })
    <|> handleSpecs specification valueProcess A.ValOfSpec
--}}}
--{{{ RECORDs
structuredType :: OccParser A.SpecType
structuredType
    =   do m <- md
           isPacked <- recordKeyword
           eol
           indent
           fs <- many1 structuredTypeField
           outdent
           return $ A.DataTypeRecord m isPacked (concat fs)
    <?> "structuredType"

recordKeyword :: OccParser Bool
recordKeyword
    =   do { sPACKED; sRECORD; return True }
    <|> do { sRECORD; return False }
    <?> "recordKeyword"

structuredTypeField :: OccParser [(A.Name, A.Type)]
structuredTypeField
    =   do { t <- dataType; fs <- many1 newFieldName; sColon; eol; return [(f, t) | f <- fs]  }
    <?> "structuredTypeField"
--}}}
--}}}
--{{{ processes
process :: OccParser A.Process
process
    =   assignment
    <|> caseInput
    <|> inputProcess
    <|> output
    <|> do { m <- md; sSKIP; eol; return $ A.Skip m }
    <|> do { m <- md; sSTOP; eol; return $ A.Stop m }
    <|> seqProcess
    <|> ifProcess
    <|> caseProcess
    <|> whileProcess
    <|> parallel
    <|> altProcess
    <|> procInstance
    <|> mainProcess
    <|> handleSpecs (allocation <|> specification) process A.ProcSpec
    <?> "process"

--{{{ assignment (:=)
assignment :: OccParser A.Process
assignment
    =   do { m <- md; vs <- tryVX variableList sAssign; es <- expressionList; eol; return $ A.Assign m vs es }
    <?> "assignment"

variableList :: OccParser [A.Variable]
variableList
    =   do { vs <- sepBy1 variable sComma; return $ vs }
    <?> "variableList"
--}}}
--{{{ input (?)
inputProcess :: OccParser A.Process
inputProcess
    =   do m <- md
           (c, i) <- input
           return $ A.Input m c i

input :: OccParser (A.Variable, A.InputMode)
input
    =   channelInput
    <|> timerInput
    <|> do { m <- md; p <- tryVX port sQuest; v <- variable; eol; return (p, A.InputSimple m [A.InVariable m v]) }
    <?> "input"

channelInput :: OccParser (A.Variable, A.InputMode)
    =   do  m <- md
            c <- tryVX channel sQuest
            (do { tl <- try (do { sCASE; taggedList }); eol; return (c, A.InputCase m (A.OnlyV m (tl (A.Skip m)))) }
             <|> do { sAFTER; e <- intExpr; eol; return (c, A.InputAfter m e) }
             <|> do { is <- sepBy1 inputItem sSemi; eol; return (c, A.InputSimple m is) })
    <?> "channelInput"

timerInput :: OccParser (A.Variable, A.InputMode)
    =   do  m <- md
            c <- tryVX timer sQuest
            (do { v <- variable; eol; return (c, A.InputSimple m [A.InVariable m v]) }
             <|> do { sAFTER; e <- intExpr; eol; return (c, A.InputAfter m e) })
    <?> "timerInput"

taggedList :: OccParser (A.Process -> A.Variant)
taggedList
    =   try (do { m <- md; t <- tagName; sSemi; is <- sepBy1 inputItem sSemi; return $ A.Variant m t is })
    <|> do { m <- md; t <- tagName; return $ A.Variant m t [] }
    <?> "taggedList"

inputItem :: OccParser A.InputItem
inputItem
    =   try (do { m <- md; v <- variable; sColons; w <- variable; return $ A.InCounted m v w })
    <|> do { m <- md; v <- variable; return $ A.InVariable m v }
    <?> "inputItem"
--}}}
--{{{ variant input (? CASE)
caseInput :: OccParser A.Process
caseInput
    =  do m <- md
          c <- tryVX channel (do {sQuest; sCASE; eol})
          indent
          vs <- many1 variant
          outdent
          return $ A.Input m c (A.InputCase m (A.Several m vs))
    <?> "caseInput"

variant :: OccParser A.Structured
variant
    =   try (do { m <- md; tl <- taggedList; eol; indent; p <- process; outdent; return $ A.OnlyV m (tl p) })
    <|> handleSpecs specification variant A.Spec
    <?> "variant"
--}}}
--{{{ output (!)
output :: OccParser A.Process
output
    =   channelOutput
    <|> do { m <- md; p <- tryVX port sBang; e <- expression; eol; return $ A.Output m p [A.OutExpression m e] }
    <?> "output"

channelOutput :: OccParser A.Process
channelOutput
    =   do  m <- md
            c <- tryVX channel sBang
            -- This is an ambiguity in the occam grammar; you can't tell in "a ! b"
            -- whether b is a variable or a tag, without knowing the type of a.
            st <- getState
            isCase <- case typeOfVariable st c of
                        Just t -> return $ isCaseProtocolType st t
                        Nothing -> fail $ "cannot figure out the type of " ++ show c
            if isCase
              then
                (try (do { t <- tagName; sSemi; os <- sepBy1 outputItem sSemi; eol; return $ A.OutputCase m c t os })
                 <|> do { t <- tagName; eol; return $ A.OutputCase m c t [] })
              else
                do { os <- sepBy1 outputItem sSemi; eol; return $ A.Output m c os }
    <?> "channelOutput"

outputItem :: OccParser A.OutputItem
outputItem
    =   try (do { m <- md; a <- intExpr; sColons; b <- expression; return $ A.OutCounted m a b })
    <|> do { m <- md; e <- expression; return $ A.OutExpression m e }
    <?> "outputItem"
--}}}
--{{{ SEQ
seqProcess :: OccParser A.Process
seqProcess
    =   do  m <- md
            sSEQ
            (do { eol; indent; ps <- many1 process; outdent; return $ A.Seq m ps }
             <|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.SeqRep m r' p })
    <?> "seqProcess"
--}}}
--{{{ IF
ifProcess :: OccParser A.Process
ifProcess
    =   do m <- md
           c <- conditional
           return $ A.If m c
    <?> "ifProcess"

conditional :: OccParser A.Structured
conditional
    =   do {  m <- md; sIF ;
              do { eol; indent; cs <- many1 ifChoice; outdent; return $ A.Several m cs }
              <|> do { r <- replicator; eol; indent; r' <- scopeInRep r; c <- ifChoice; scopeOutRep r'; outdent; return $ A.Rep m r' c } }
    <?> "conditional"

ifChoice :: OccParser A.Structured
ifChoice
    =   guardedChoice
    <|> conditional
    <|> handleSpecs specification ifChoice A.Spec
    <?> "choice"

guardedChoice :: OccParser A.Structured
guardedChoice
    =   do m <- md
           b <- booleanExpr
           eol
           indent
           p <- process
           outdent
           return $ A.OnlyC m (A.Choice m b p)
    <?> "guardedChoice"
--}}}
--{{{ CASE
caseProcess :: OccParser A.Process
caseProcess
    =   do m <- md
           sCASE
           s <- caseSelector
           eol
           indent
           os <- many1 caseOption
           outdent
           return $ A.Case m s (A.Several m os)
    <?> "caseProcess"

caseSelector :: OccParser A.Expression
caseSelector
-- FIXME Should constrain to things that can be CASEd over.
    =   expression
    <?> "caseSelector"

caseOption :: OccParser A.Structured
caseOption
    =   try (do { m <- md; ces <- sepBy caseExpression sComma; eol; indent; p <- process; outdent; return $ A.OnlyO m (A.Option m ces p) })
    <|> try (do { m <- md; sELSE; eol; indent; p <- process; outdent; return $ A.OnlyO m (A.Else m p) })
    <|> handleSpecs specification caseOption A.Spec
    <?> "option"

caseExpression :: OccParser A.Expression
caseExpression
    -- FIXME: Check the type is something constant that CASE can deal with
    =   expression
    <?> "caseExpression"
--}}}
--{{{ WHILE
whileProcess :: OccParser A.Process
whileProcess
    =   do m <- md
           sWHILE
           b <- booleanExpr
           eol
           indent
           p <- process
           outdent
           return $ A.While m b p
    <?> "whileProcess"
--}}}
--{{{ PAR
parallel :: OccParser A.Process
parallel
    =   do m <- md
           isPri <- parKeyword
           (do { eol; indent; ps <- many1 process; outdent; return $ A.Par m isPri ps }
            <|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.ParRep m isPri r' p })
    <|> placedpar
    <?> "parallel"

parKeyword :: OccParser A.ParMode
parKeyword
    =   do { sPAR; return A.PlainPar }
    <|> try (do { sPRI; sPAR; return A.PriPar })
    <?> "parKeyword"

-- XXX PROCESSOR as a process isn't really legal, surely?
placedpar :: OccParser A.Process
placedpar
    =   do m <- md
           sPLACED
           sPAR
           (do { eol; indent; ps <- many1 placedpar; outdent; return $ A.Par m A.PlacedPar ps  }
            <|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- placedpar; scopeOutRep r'; outdent; return $ A.ParRep m A.PlacedPar r' p })
    <|> do { m <- md; sPROCESSOR; e <- intExpr; eol; indent; p <- process; outdent; return $ A.Processor m e p }
    <?> "placedpar"
--}}}
--{{{ ALT
altProcess :: OccParser A.Process
altProcess
    =   do m <- md
           (isPri, a) <- alternation
           return $ A.Alt m isPri a
    <?> "altProcess"

alternation :: OccParser (Bool, A.Structured)
alternation
    =   do {  m <- md; isPri <- altKeyword ;
              do { eol; indent; as <- many1 alternative; outdent; return (isPri, A.Several m as) }
              <|> do { r <- replicator; eol; indent; r' <- scopeInRep r; a <- alternative; scopeOutRep r'; outdent; return (isPri, A.Rep m r' a) } }
    <?> "alternation"

altKeyword :: OccParser Bool
altKeyword
    =   do { sALT; return False }
    <|> try (do { sPRI; sALT; return True })
    <?> "altKeyword"

-- The reason the CASE guards end up here is because they have to be handled
-- specially: you can't tell until parsing the guts of the CASE what the processes
-- are.
alternative :: OccParser A.Structured
alternative
    =   guardedAlternative
    -- FIXME: Check we don't have PRI ALT inside ALT.
    <|> do { (isPri, a) <- alternation; return a }
    <|> try (do m <- md
                b <- booleanExpr
                sAmp
                c <- channel
                sQuest
                sCASE
                eol
                indent
                vs <- many1 variant
                outdent
                return $ A.OnlyA m (A.AlternativeCond m b c (A.InputCase m $ A.Several m vs) (A.Skip m)))
    <|> try (do m <- md
                c <- channel
                sQuest
                sCASE
                eol
                indent
                vs <- many1 variant
                outdent
                return $ A.OnlyA m (A.Alternative m c (A.InputCase m $ A.Several m vs) (A.Skip m)))
    <|> handleSpecs specification alternative A.Spec
    <?> "alternative"

guardedAlternative :: OccParser A.Structured
guardedAlternative
    =   do m <- md
           makeAlt <- guard
           indent
           p <- process
           outdent
           return $ A.OnlyA m (makeAlt p)
    <?> "guardedAlternative"

guard :: OccParser (A.Process -> A.Alternative)
guard
    =   try (do { m <- md; (c, im) <- input; return $ A.Alternative m c im })
    <|> try (do { m <- md; b <- booleanExpr; sAmp; (c, im) <- input; return $ A.AlternativeCond m b c im })
    <|> try (do { m <- md; b <- booleanExpr; sAmp; sSKIP; eol; return $ A.AlternativeSkip m b })
    <?> "guard"
--}}}
--{{{ PROC calls
procInstance :: OccParser A.Process
procInstance
    =  do m <- md
          n <- tryVX procName sLeftR
          st <- pSpecTypeOfName n
          let fs = case st of A.Proc _ fs _ -> fs
          as <- actuals fs
          sRightR
          eol
          return $ A.ProcCall m n as
    <?> "procInstance"

actuals :: [A.Formal] -> OccParser [A.Actual]
actuals fs = intersperseP (map actual fs) sComma

actual :: A.Formal -> OccParser A.Actual
actual (A.Formal am t n)
    =  do case am of
            A.ValAbbrev -> do { e <- expression; et <- pTypeOfExpression e; matchType t et; return $ A.ActualExpression t e } <?> "actual expression for " ++ an
            _ -> if isChannelType t
                   then do { c <- channel; ct <- pTypeOfVariable c; matchType t ct; return $ A.ActualVariable am t c } <?> "actual channel for " ++ an
                   else do { v <- variable; vt <- pTypeOfVariable v; matchType t vt; return $ A.ActualVariable am t v } <?> "actual variable for " ++ an
    where
      an = A.nameName n
--}}}
--{{{ main process
mainProcess :: OccParser A.Process
mainProcess
    =  do m <- md
          sMainMarker
          eol
          -- Find the last thing that was defined; it should be a PROC of the right type.
          -- FIXME We should check that it's using a valid TLP interface.
          updateState $ (\ps -> ps { psMainName = Just $ snd $ head $ psLocalNames ps })
          return $ A.Main m
--}}}
--}}}
--{{{ top-level forms
-- This is only really true once we've tacked a process onto the bottom; a
-- source file is really a series of specifications, but the later ones need to
-- have the earlier ones in scope, so we can't parse them separately.
sourceFile :: OccParser (A.Process, ParseState)
sourceFile
    =   do whiteSpace
           p <- process
           s <- getState
           return (p, s)
--}}}
--}}}

--{{{ preprocessor
-- XXX Doesn't handle preprocessor instructions.

preprocess :: String -> String
preprocess d = parseIndentation $ lines (d ++ "\n" ++ mainMarker)

readSource :: String -> IO String
readSource fn = do
  f <- IO.openFile fn IO.ReadMode
  d <- IO.hGetContents f
  let prep = preprocess d
  return prep
--}}}

--{{{ interface for other modules
testParse :: Show a => OccParser a -> String -> IO ()
testParse prod text
    = do let r = runParser prod emptyState "" text
         putStrLn $ "Result: " ++ show r

parseSource :: String -> String -> IO (A.Process, ParseState)
parseSource prep sourceFileName
  = case runParser sourceFile emptyState sourceFileName prep of
      Left err -> die $ "Parse error: " ++ show err
      Right result -> return result
--}}}