First stuff for fco2 -- copied from fco
This commit is contained in:
Adam Sampson
parent
6dbb86f610
commit
c8c7935905
199
fco2/AST.hs
Normal file
199
fco2/AST.hs
Normal file
|
|
@ -0,0 +1,199 @@
|
|||
-- Data types for occam abstract syntax
|
||||
-- This is intended to be imported qualified:
|
||||
-- import qualified AST as O
|
||||
|
||||
module AST where
|
||||
|
||||
import Data.Generics
|
||||
import Metadata
|
||||
|
||||
data Name = Name Meta String
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Tag = Tag Meta String
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Type =
|
||||
Bool
|
||||
| Byte
|
||||
| Int | Int16 | Int32 | Int64
|
||||
| Real32 | Real64
|
||||
| Array Expression Type
|
||||
| ArrayUnsized Type
|
||||
| UserType Name
|
||||
| Chan Type
|
||||
| Counted Type Type
|
||||
| Any
|
||||
| Timer
|
||||
| Port Type
|
||||
| Val Type
|
||||
| Infer -- for where the type is not given but can be worked out (e.g. "x IS y:")
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ConversionMode =
|
||||
DefaultConversion
|
||||
| Round
|
||||
| Trunc
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Subscript =
|
||||
Subscript Meta Expression
|
||||
| SubscriptTag Meta Tag
|
||||
| SubFromFor Meta Expression Expression
|
||||
| SubFrom Meta Expression
|
||||
| SubFor Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data LiteralRepr =
|
||||
RealLiteral Meta String
|
||||
| IntLiteral Meta String
|
||||
| HexLiteral Meta String
|
||||
| ByteLiteral Meta String
|
||||
| StringLiteral Meta String
|
||||
| ArrayLiteral Meta [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Literal =
|
||||
Literal Meta Type LiteralRepr
|
||||
| SubscriptedLiteral Meta Subscript Literal
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Variable =
|
||||
Variable Meta Name
|
||||
| SubscriptedVariable Meta Subscript Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Expression =
|
||||
Monadic Meta MonadicOp Expression
|
||||
| Dyadic Meta DyadicOp Expression Expression
|
||||
| MostPos Meta Type
|
||||
| MostNeg Meta Type
|
||||
| Size Meta Type
|
||||
| Conversion Meta ConversionMode Type Expression
|
||||
| ExprVariable Meta Variable
|
||||
| ExprLiteral Meta Literal
|
||||
| True Meta
|
||||
| False Meta
|
||||
| FunctionCall Meta Name [Expression]
|
||||
| BytesInType Meta Type
|
||||
| OffsetOf Meta Type Tag
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ExpressionList =
|
||||
FunctionCallList Meta Name [Expression]
|
||||
| ExpressionList Meta [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data MonadicOp =
|
||||
MonadicBytesIn
|
||||
| MonadicSubtr
|
||||
| MonadicBitNot
|
||||
| MonadicNot
|
||||
| MonadicSize
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data DyadicOp =
|
||||
Add | Subtr | Mul | Div | Rem
|
||||
| Plus | Minus | Times
|
||||
| BitAnd | BitOr | BitXor
|
||||
| And | Or
|
||||
| Eq | NotEq | Less | More | LessEq | MoreEq
|
||||
| After
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data InputItem =
|
||||
InCounted Meta Variable Variable
|
||||
| InVariable Meta Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data OutputItem =
|
||||
OutCounted Meta Expression Expression
|
||||
| OutExpression Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Replicator = For Meta Name Expression Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Choice = Choice Meta Expression Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Alternative =
|
||||
Alternative Meta Variable InputMode Process
|
||||
| AlternativeCond Meta Expression Variable InputMode Process
|
||||
| AlternativeSkip Meta Expression Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Option =
|
||||
Option Meta [Expression] Process
|
||||
| Else Meta Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Variant = Variant Meta Tag [InputItem] Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- This represents something that can contain local replicators and specifications.
|
||||
-- (This ought to be a parametric type, "Structured Variant" etc., but doing so
|
||||
-- makes using generic functions across it hard.)
|
||||
data Structured =
|
||||
Rep Meta Replicator Structured
|
||||
| Spec Meta Specification Structured
|
||||
| OnlyV Meta Variant
|
||||
| OnlyC Meta Choice
|
||||
| OnlyO Meta Option
|
||||
| OnlyP Meta Process
|
||||
| OnlyA Meta Alternative
|
||||
| Several Meta [Structured]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data InputMode =
|
||||
InputSimple Meta [InputItem]
|
||||
| InputCase Meta Structured
|
||||
| InputAfter Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
type Formals = [(Type, Name)]
|
||||
type Specification = (Name, SpecType)
|
||||
data SpecType =
|
||||
Place Meta Expression
|
||||
| Declaration Meta Type
|
||||
| Is Meta Type Variable
|
||||
| ValIs Meta Type Expression
|
||||
| DataTypeIs Meta Type
|
||||
| DataTypeRecord Meta Bool [(Type, Tag)]
|
||||
| ProtocolIs Meta [Type]
|
||||
| ProtocolCase Meta [(Tag, [Type])]
|
||||
| Proc Meta Formals Process
|
||||
| Function Meta [Type] Formals ValueProcess
|
||||
| Retypes Meta Type Variable
|
||||
| Reshapes Meta Type Variable
|
||||
| ValRetypes Meta Type Variable
|
||||
| ValReshapes Meta Type Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ValueProcess =
|
||||
ValOfSpec Meta Specification ValueProcess
|
||||
| ValOf Meta Process ExpressionList
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Process =
|
||||
ProcSpec Meta Specification Process
|
||||
| Assign Meta [Variable] ExpressionList
|
||||
| Input Meta Variable InputMode
|
||||
| Output Meta Variable [OutputItem]
|
||||
| OutputCase Meta Variable Tag [OutputItem]
|
||||
| Skip Meta
|
||||
| Stop Meta
|
||||
| Main Meta
|
||||
| Seq Meta [Process]
|
||||
| SeqRep Meta Replicator Process
|
||||
| If Meta Structured
|
||||
| Case Meta Expression Structured
|
||||
| While Meta Expression Process
|
||||
| Par Meta Bool [Process]
|
||||
| ParRep Meta Bool Replicator Process
|
||||
| PlacedPar Meta Structured
|
||||
| Processor Meta Expression Process
|
||||
| Alt Meta Bool Structured
|
||||
| ProcCall Meta Name [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
87
fco2/Main.hs
Normal file
87
fco2/Main.hs
Normal file
|
|
@ -0,0 +1,87 @@
|
|||
-- Driver for FCO
|
||||
|
||||
module Main where
|
||||
|
||||
import List
|
||||
import System
|
||||
import System.Console.GetOpt
|
||||
import System.IO
|
||||
|
||||
import PrettyShow
|
||||
import Parse
|
||||
import SExpression
|
||||
import Pass
|
||||
import PTPasses
|
||||
import PTToAST
|
||||
import ASTPasses
|
||||
import COutput
|
||||
|
||||
data Flag = ParseOnly | SOccamOnly | Verbose
|
||||
deriving (Eq, Show)
|
||||
|
||||
options :: [OptDescr Flag]
|
||||
options =
|
||||
[ Option [] ["parse-tree"] (NoArg ParseOnly) "parse input files and output S-expression parse tree"
|
||||
, Option [] ["soccam"] (NoArg SOccamOnly) "parse input files and output soccam"
|
||||
, Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
|
||||
]
|
||||
|
||||
getOpts :: [String] -> IO ([Flag], [String])
|
||||
getOpts argv =
|
||||
case getOpt RequireOrder options argv of
|
||||
(o,n,[] ) -> return (o,n)
|
||||
(_,_,errs) -> error (concat errs ++ usageInfo header options)
|
||||
where header = "Usage: fco [OPTION...] SOURCEFILE"
|
||||
|
||||
numberedListing :: String -> String
|
||||
numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
argv <- getArgs
|
||||
(opts, args) <- getOpts argv
|
||||
|
||||
let fn = case args of
|
||||
[fn] -> fn
|
||||
_ -> error "Must specify a single input file"
|
||||
|
||||
let progress = if Verbose `elem` opts then hPutStrLn stderr else (\s -> return ())
|
||||
|
||||
progress $ "Options: " ++ (show opts)
|
||||
progress $ "Compiling " ++ fn
|
||||
progress ""
|
||||
|
||||
progress "{{{ Preprocessor"
|
||||
preprocessed <- readSource fn
|
||||
progress $ numberedListing preprocessed
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ Parser"
|
||||
let pt = parseSource preprocessed fn
|
||||
progress $ pshow pt
|
||||
progress "}}}"
|
||||
|
||||
if ParseOnly `elem` opts then do
|
||||
putStrLn $ show (nodeToSExp pt)
|
||||
else if SOccamOnly `elem` opts then do
|
||||
putStrLn $ show (nodeToSOccam pt)
|
||||
else do
|
||||
progress "{{{ PT passes"
|
||||
pt' <- runPasses ptPasses progress pt
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ PT to AST"
|
||||
let ast = ptToAST pt'
|
||||
progress $ pshow ast
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ AST passes"
|
||||
ast' <- runPasses astPasses progress ast
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ C output"
|
||||
putStr $ writeC ast'
|
||||
progress "}}}"
|
||||
|
||||
progress "Done"
|
||||
|
||||
38
fco2/Makefile
Normal file
38
fco2/Makefile
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
targets = fco
|
||||
|
||||
all: $(targets)
|
||||
|
||||
sources = \
|
||||
AST.hs \
|
||||
ASTPasses.hs \
|
||||
COutput.hs \
|
||||
Main.hs \
|
||||
Metadata.hs \
|
||||
Parse.hs \
|
||||
Pass.hs \
|
||||
PrettyShow.hs \
|
||||
PT.hs \
|
||||
PTPasses.hs \
|
||||
SExpression.hs \
|
||||
PTToAST.hs
|
||||
|
||||
$(targets): $(sources)
|
||||
ghc -fglasgow-exts -o fco --make Main
|
||||
|
||||
tests = $(wildcard testcases/*.occ)
|
||||
|
||||
test: $(targets) $(tests)
|
||||
@set -e; for x in $(tests); do \
|
||||
echo -n "$$x: " ; \
|
||||
if ! ./fco --parse-tree $$x >$$x.log 2>&1 ; then \
|
||||
echo "parse failed" ; \
|
||||
elif ! ./fco -v $$x >$$x.log 2>&1 ; then \
|
||||
echo "full failed" ; \
|
||||
else \
|
||||
echo "ok" ; \
|
||||
fi ; \
|
||||
done
|
||||
|
||||
clean:
|
||||
rm -f $(targets) *.o *.hi
|
||||
|
||||
30
fco2/Metadata.hs
Normal file
30
fco2/Metadata.hs
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
-- Metadata types
|
||||
|
||||
module Metadata where
|
||||
|
||||
import Data.Generics
|
||||
import Data.List
|
||||
|
||||
type Meta = [Metadatum]
|
||||
|
||||
data Metadatum =
|
||||
SourcePos String Int Int
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
findSourcePos :: Meta -> Maybe Metadatum
|
||||
findSourcePos ms = find (\x -> case x of SourcePos _ _ _ -> True
|
||||
otherwise -> False) ms
|
||||
|
||||
formatSourcePos :: Meta -> String
|
||||
formatSourcePos m = case findSourcePos m of
|
||||
Just (SourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">"
|
||||
Nothing -> "<?>"
|
||||
|
||||
die :: Monad m => String -> m a
|
||||
die s = error $ "error: " ++ s
|
||||
|
||||
dieP :: Monad m => Meta -> String -> m a
|
||||
dieP m s = case findSourcePos m of
|
||||
Just (SourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s
|
||||
Nothing -> die $ "unknown position: " ++ s
|
||||
|
||||
803
fco2/Parse.hs
Normal file
803
fco2/Parse.hs
Normal file
|
|
@ -0,0 +1,803 @@
|
|||
-- Parse occam code
|
||||
|
||||
module Parse (readSource, parseSource) where
|
||||
|
||||
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 qualified PT as N
|
||||
import Metadata
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
md :: Parser Meta
|
||||
md = do
|
||||
pos <- getPosition
|
||||
return $ [SourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos)]
|
||||
|
||||
nd :: Meta -> N.NodeType -> N.Node
|
||||
nd = N.Node
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
mainMarker = "##MAGIC-FCO-MAIN-PROCESS##"
|
||||
|
||||
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",
|
||||
mainMarker
|
||||
]
|
||||
, P.caseSensitive = True
|
||||
}
|
||||
|
||||
lexer :: P.TokenParser ()
|
||||
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
|
||||
|
||||
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 "="
|
||||
|
||||
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"
|
||||
sMainMarker = reserved mainMarker
|
||||
|
||||
-- XXX could handle VALOF by translating each step to one { and matching multiple ones?
|
||||
indent = symbol "{"
|
||||
outdent = symbol "}"
|
||||
eol = symbol "@"
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- These productions are based on the syntax in the occam2.1 manual.
|
||||
|
||||
-- The way productions should work is that each production should only consume input if it's sure that it's unambiguous.
|
||||
|
||||
abbreviation
|
||||
= try (do { m <- md ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.Is n v })
|
||||
<|> try (do { m <- md ; s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.IsType s n v })
|
||||
<|> do { m <- md ; sVAL ;
|
||||
try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIs n e })
|
||||
<|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIsType s n e } }
|
||||
<?> "abbreviation"
|
||||
|
||||
actual
|
||||
= expression
|
||||
<|> variable
|
||||
<|> channel
|
||||
<?> "actual"
|
||||
|
||||
allocation
|
||||
= do { m <- md ; sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ nd m $ N.Place n e }
|
||||
<?> "allocation"
|
||||
|
||||
alternation
|
||||
= do { m <- md ; sALT ;
|
||||
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.Alt as }
|
||||
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.AltRep r a } }
|
||||
<|> do { m <- md ; sPRI ; sALT ;
|
||||
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.PriAlt as }
|
||||
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.PriAltRep r a } }
|
||||
<?> "alternation"
|
||||
|
||||
-- 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
|
||||
= guardedAlternative
|
||||
<|> alternation
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.CondGuard b (nd m $ N.In c (nd m $ N.InCase vs)) })
|
||||
<|> try (do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) })
|
||||
<|> do { m <- md ; s <- specification ; a <- alternative ; return $ nd m $ N.Decl s a }
|
||||
<?> "alternative"
|
||||
|
||||
assignment
|
||||
= do { m <- md ; vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ nd m $ N.Assign vs es }
|
||||
<?> "assignment"
|
||||
|
||||
base
|
||||
= expression
|
||||
<?> "base"
|
||||
|
||||
boolean
|
||||
= expression
|
||||
<?> "boolean"
|
||||
|
||||
byte
|
||||
= lexeme (do { m <- md ; char '\'' ; s <- character ; char '\'' ; return $ nd m $ N.LitByte s })
|
||||
<?> "byte"
|
||||
|
||||
caseExpression
|
||||
= expression
|
||||
<?> "caseExpression"
|
||||
|
||||
caseInput
|
||||
= do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) }
|
||||
<?> "caseInput"
|
||||
|
||||
-- This is also used for timers and ports, since the syntax is identical (and
|
||||
-- the parser really can't tell at this stage which is which).
|
||||
channel
|
||||
= do { m <- md ; v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "channel"
|
||||
|
||||
channel'
|
||||
= try name
|
||||
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||
<?> "channel'"
|
||||
|
||||
-- FIXME should probably make CHAN INT work, since that'd be trivial...
|
||||
channelType
|
||||
= do { m <- md ; sCHAN ; sOF ; p <- protocol ; return $ nd m $ N.ChanOf p }
|
||||
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- channelType ; return $ nd m $ N.Array s t })
|
||||
<?> "channelType"
|
||||
|
||||
-- FIXME this isn't at all the right way to return the character!
|
||||
character
|
||||
= try (do { char '*' ;
|
||||
do { char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] }
|
||||
<|> do { c <- anyChar ; return $ ['*', c] } })
|
||||
<|> do { c <- anyChar ; return $ [c] }
|
||||
<?> "character"
|
||||
|
||||
occamChoice
|
||||
= guardedChoice
|
||||
<|> conditional
|
||||
<|> do { m <- md ; s <- try specification ; c <- occamChoice ; return $ nd m $ N.Decl s c }
|
||||
<?> "choice"
|
||||
|
||||
conditional
|
||||
= do { m <- md ; sIF ;
|
||||
do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ nd m $ N.If cs }
|
||||
<|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ nd m $ N.IfRep r c } }
|
||||
<?> "conditional"
|
||||
|
||||
-- This uses operandNotTable to resolve the "x[y]" ambiguity.
|
||||
conversion
|
||||
= try (do { m <- md ; t <- dataType; do { sROUND ; o <- operand ; return $ nd m $ N.Round t o } <|> do { sTRUNC ; o <- operand ; return $ nd m $ N.Trunc t o } <|> do { o <- operandNotTable ; return $ nd m $ N.Conv t o } })
|
||||
<?> "conversion"
|
||||
|
||||
occamCount
|
||||
= expression
|
||||
<?> "count"
|
||||
|
||||
dataType
|
||||
= do { m <- md ; sBOOL ; return $ nd m $ N.Bool }
|
||||
<|> do { m <- md ; sBYTE ; return $ nd m $ N.Byte }
|
||||
<|> do { m <- md ; sINT ; return $ nd m $ N.Int }
|
||||
<|> do { m <- md ; sINT16 ; return $ nd m $ N.Int16 }
|
||||
<|> do { m <- md ; sINT32 ; return $ nd m $ N.Int32 }
|
||||
<|> do { m <- md ; sINT64 ; return $ nd m $ N.Int64 }
|
||||
<|> do { m <- md ; sREAL32 ; return $ nd m $ N.Real32 }
|
||||
<|> do { m <- md ; sREAL64 ; return $ nd m $ N.Real64 }
|
||||
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- dataType ; return $ nd m $ N.Array s t })
|
||||
<|> name
|
||||
<?> "data type"
|
||||
|
||||
declType
|
||||
= dataType
|
||||
<|> channelType
|
||||
<|> timerType
|
||||
<|> portType
|
||||
|
||||
-- FIXME this originally had four lines like this, one for each of the above;
|
||||
-- it might be nicer to generate a different nd m $ N.Node for each type of declaration
|
||||
declaration
|
||||
= do { m <- md ; d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ nd m $ N.Vars d ns }
|
||||
<?> "declaration"
|
||||
|
||||
definition
|
||||
= do { m <- md ; sDATA ; sTYPE ; n <- name ;
|
||||
do {sIS ; t <- dataType ; sColon ; eol ; return $ nd m $ N.DataType n t }
|
||||
<|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ nd m $ N.DataType n t } }
|
||||
<|> do { m <- md ; sPROTOCOL ; n <- name ;
|
||||
do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ nd m $ N.Protocol n p }
|
||||
<|> do { eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ nd m $ N.TaggedProtocol n ps } }
|
||||
<|> do { m <- md ; sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ nd m $ N.Proc n fs p }
|
||||
<|> try (do { m <- md ; rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ;
|
||||
do { sIS ; el <- expressionList ; sColon ; eol ; return $ nd m $ N.FuncIs n rs fs el }
|
||||
<|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ nd m $ N.Func n rs fs vp } })
|
||||
<|> try (do { m <- md ; s <- specifier ; n <- name ;
|
||||
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Retypes s n v }
|
||||
<|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Reshapes s n v } })
|
||||
<|> do { m <- md ; sVAL ; s <- specifier ; n <- name ;
|
||||
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValRetypes s n v }
|
||||
<|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValReshapes s n v } }
|
||||
<?> "definition"
|
||||
|
||||
digits
|
||||
= many1 digit
|
||||
<?> "digits"
|
||||
|
||||
dyadicOperator
|
||||
= do { m <- md ; reservedOp "+" ; return $ nd m $ N.Add }
|
||||
<|> do { m <- md ; reservedOp "-" ; return $ nd m $ N.Subtr }
|
||||
<|> do { m <- md ; reservedOp "*" ; return $ nd m $ N.Mul }
|
||||
<|> do { m <- md ; reservedOp "/" ; return $ nd m $ N.Div }
|
||||
<|> do { m <- md ; reservedOp "\\" ; return $ nd m $ N.Rem }
|
||||
<|> do { m <- md ; sREM ; return $ nd m $ N.Rem }
|
||||
<|> do { m <- md ; sPLUS ; return $ nd m $ N.Plus }
|
||||
<|> do { m <- md ; sMINUS ; return $ nd m $ N.Minus }
|
||||
<|> do { m <- md ; sTIMES ; return $ nd m $ N.Times }
|
||||
<|> do { m <- md ; reservedOp "/\\" ; return $ nd m $ N.BitAnd }
|
||||
<|> do { m <- md ; reservedOp "\\/" ; return $ nd m $ N.BitOr }
|
||||
<|> do { m <- md ; reservedOp "><" ; return $ nd m $ N.BitXor }
|
||||
<|> do { m <- md ; sBITAND ; return $ nd m $ N.BitAnd }
|
||||
<|> do { m <- md ; sBITOR ; return $ nd m $ N.BitOr }
|
||||
<|> do { m <- md ; sAND ; return $ nd m $ N.And }
|
||||
<|> do { m <- md ; sOR ; return $ nd m $ N.Or }
|
||||
<|> do { m <- md ; reservedOp "=" ; return $ nd m $ N.Eq }
|
||||
<|> do { m <- md ; reservedOp "<>" ; return $ nd m $ N.NEq }
|
||||
<|> do { m <- md ; reservedOp "<" ; return $ nd m $ N.Less }
|
||||
<|> do { m <- md ; reservedOp ">" ; return $ nd m $ N.More }
|
||||
<|> do { m <- md ; reservedOp "<=" ; return $ nd m $ N.LessEq }
|
||||
<|> do { m <- md ; reservedOp ">=" ; return $ nd m $ N.MoreEq }
|
||||
<|> do { m <- md ; sAFTER ; return $ nd m $ N.After }
|
||||
<?> "dyadicOperator"
|
||||
|
||||
occamExponent
|
||||
= try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d })
|
||||
<?> "exponent"
|
||||
|
||||
expression
|
||||
= try (do { m <- md ; o <- monadicOperator ; v <- operand ; return $ nd m $ N.MonadicOp o v })
|
||||
<|> do { m <- md ; a <- sMOSTPOS ; t <- dataType ; return $ nd m $ N.MostPos t }
|
||||
<|> do { m <- md ; a <- sMOSTNEG ; t <- dataType ; return $ nd m $ N.MostNeg t }
|
||||
<|> do { m <- md ; a <- sSIZE ; t <- dataType ; return $ nd m $ N.Size t }
|
||||
<|> try (do { m <- md ; a <- operand ; o <- dyadicOperator ; b <- operand ; return $ nd m $ N.DyadicOp o a b })
|
||||
<|> try conversion
|
||||
<|> operand
|
||||
<?> "expression"
|
||||
|
||||
expressionList
|
||||
= try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||
<|> do { m <- md ; es <- sepBy1 expression sComma ; return $ nd m $ N.ExpList es }
|
||||
-- XXX value process
|
||||
<?> "expressionList"
|
||||
|
||||
fieldName
|
||||
= name
|
||||
<?> "fieldName"
|
||||
|
||||
-- This is rather different from the grammar, since I had some difficulty
|
||||
-- getting Parsec to parse it as a list of lists of arguments.
|
||||
formalList
|
||||
= do { m <- md ; sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes m fs }
|
||||
<?> "formalList"
|
||||
where
|
||||
formalArg :: Parser (Maybe N.Node, N.Node)
|
||||
formalArg = try (do { m <- md ; sVAL ; s <- specifier ; n <- name ; return $ (Just (nd m $ N.Val s), n) })
|
||||
<|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) })
|
||||
<|> try (do { n <- name ; return $ (Nothing, n) })
|
||||
|
||||
markTypes :: Meta -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||
markTypes _ [] = []
|
||||
markTypes _ ((Nothing, _):_) = error "Formal list must start with a type"
|
||||
markTypes m ((Just ft, fn):is) = markRest m ft [fn] is
|
||||
|
||||
markRest :: Meta -> N.Node -> [N.Node] -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||
markRest m lt ns [] = [nd m $ N.Formals lt ns]
|
||||
markRest m lt ns ((Nothing, n):is) = markRest m lt (ns ++ [n]) is
|
||||
markRest m lt ns ((Just t, n):is) = (markRest m lt ns []) ++ (markRest m t [n] is)
|
||||
|
||||
functionHeader
|
||||
= do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) }
|
||||
<?> "functionHeader"
|
||||
|
||||
guard
|
||||
= try input
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; i <- input ; return $ nd m $ N.CondGuard b i })
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; sSKIP ; eol ; return $ nd m $ N.CondGuard b (nd m $ N.Skip) })
|
||||
<?> "guard"
|
||||
|
||||
guardedAlternative
|
||||
= do { m <- md ; g <- guard ; indent ; p <- process ; outdent ; return $ nd m $ N.Guard g p }
|
||||
<?> "guardedAlternative"
|
||||
|
||||
guardedChoice
|
||||
= do { m <- md ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Choice b p }
|
||||
<?> "guardedChoice"
|
||||
|
||||
hexDigits
|
||||
= do { m <- md ; d <- many1 hexDigit ; return $ nd m $ N.LitHex d }
|
||||
<?> "hexDigits"
|
||||
|
||||
input
|
||||
= do m <- md
|
||||
c <- channel
|
||||
sQuest
|
||||
(do { sCASE ; tl <- taggedList ; eol ; return $ nd m $ N.In c (nd m $ N.InTag tl) }
|
||||
<|> do { sAFTER ; e <- expression ; eol ; return $ nd m $ N.In c (nd m $ N.InAfter e) }
|
||||
<|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ nd m $ N.In c (nd m $ N.InSimple is) })
|
||||
<?> "input"
|
||||
|
||||
inputItem
|
||||
= try (do { m <- md ; v <- variable ; sColons ; w <- variable ; return $ nd m $ N.Counted v w })
|
||||
<|> variable
|
||||
<?> "inputItem"
|
||||
|
||||
integer
|
||||
= try (do { m <- md ; d <- lexeme digits ; return $ nd m $ N.LitInt d })
|
||||
<|> do { char '#' ; d <- lexeme hexDigits ; return $ d }
|
||||
<?> "integer"
|
||||
|
||||
literal
|
||||
= try real
|
||||
<|> try integer
|
||||
<|> try byte
|
||||
<|> try (do { m <- md ; v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; sTRUE ; return $ nd m $ N.True })
|
||||
<|> do { m <- md ; sFALSE ; return $ nd m $ N.False }
|
||||
<?> "literal"
|
||||
|
||||
loop
|
||||
= do { m <- md ; sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.While b p }
|
||||
|
||||
monadicOperator
|
||||
= do { m <- md ; reservedOp "-" ; return $ nd m $ N.MonSub }
|
||||
<|> do { m <- md ; sMINUS ; return $ nd m $ N.MonSub }
|
||||
<|> do { m <- md ; reservedOp "~" ; return $ nd m $ N.MonBitNot }
|
||||
<|> do { m <- md ; sBITNOT ; return $ nd m $ N.MonBitNot }
|
||||
<|> do { m <- md ; sNOT ; return $ nd m $ N.MonNot }
|
||||
<|> do { m <- md ; sSIZE ; return $ nd m $ N.MonSize }
|
||||
<?> "monadicOperator"
|
||||
|
||||
name
|
||||
= do { m <- md ; s <- identifier ; return $ nd m $ N.Name s }
|
||||
<?> "name"
|
||||
|
||||
occamString
|
||||
= lexeme (do { m <- md ; char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ nd m $ N.LitString s })
|
||||
<?> "string"
|
||||
|
||||
operandNotTable
|
||||
= do { m <- md ; v <- operandNotTable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "operandNotTable"
|
||||
|
||||
operandNotTable'
|
||||
= try variable
|
||||
<|> try literal
|
||||
<|> try (do { sLeftR ; e <- expression ; sRightR ; return e })
|
||||
-- XXX value process
|
||||
<|> try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||
<|> try (do { m <- md ; sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ nd m $ N.OffsetOf n f })
|
||||
<?> "operandNotTable'"
|
||||
|
||||
operand
|
||||
= do { m <- md ; v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "operand"
|
||||
|
||||
operand'
|
||||
= try table
|
||||
<|> operandNotTable'
|
||||
<?> "operand'"
|
||||
|
||||
occamOption
|
||||
= try (do { m <- md ; ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.CaseExps ces p })
|
||||
<|> try (do { m <- md ; sELSE ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Else p })
|
||||
<|> do { m <- md ; s <- specification ; o <- occamOption ; return $ nd m $ N.Decl s o }
|
||||
<?> "option"
|
||||
|
||||
-- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag...
|
||||
-- ... so this now wants "c ! CASE x" if it's a tag, to match input.
|
||||
-- We can fix this with a pass later...
|
||||
output
|
||||
= do m <- md
|
||||
c <- channel
|
||||
sBang
|
||||
(do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.OutCase c t os }
|
||||
<|> do { sCASE ; t <- tag ; eol ; return $ nd m $ N.OutCase c t [] }
|
||||
<|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.Out c os })
|
||||
<?> "output"
|
||||
|
||||
outputItem
|
||||
= try (do { m <- md ; a <- expression ; sColons ; b <- expression ; return $ nd m $ N.Counted a b })
|
||||
<|> expression
|
||||
<?> "outputItem"
|
||||
|
||||
parallel
|
||||
= do { m <- md ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Par ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.ParRep r p } }
|
||||
<|> do { m <- md ; sPRI ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.PriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.PriParRep r p } }
|
||||
<|> placedpar
|
||||
<?> "parallel"
|
||||
|
||||
-- XXX PROCESSOR as a process isn't really legal, surely?
|
||||
placedpar
|
||||
= do { m <- md ; sPLACED ; sPAR ; do { eol ; indent ; ps <- many1 placedpar ; outdent ; return $ nd m $ N.PlacedPar ps } <|> do { r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ nd m $ N.PlacedParRep r p } }
|
||||
<|> do { m <- md ; sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Processor e p }
|
||||
<?> "placedpar"
|
||||
|
||||
portType
|
||||
= do { m <- md ; sPORT ; sOF ; p <- protocol ; return $ nd m $ N.PortOf p }
|
||||
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ nd m $ N.Array s t }
|
||||
<?> "portType"
|
||||
|
||||
procInstance
|
||||
= do { m <- md ; n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ nd m $ N.ProcCall n as }
|
||||
<?> "procInstance"
|
||||
|
||||
process
|
||||
= try assignment
|
||||
<|> try input
|
||||
<|> try output
|
||||
<|> do { m <- md ; sSKIP ; eol ; return $ nd m $ N.Skip }
|
||||
<|> do { m <- md ; sSTOP ; eol ; return $ nd m $ N.Stop }
|
||||
<|> occamSequence
|
||||
<|> conditional
|
||||
<|> selection
|
||||
<|> loop
|
||||
<|> try parallel
|
||||
<|> alternation
|
||||
<|> try caseInput
|
||||
<|> try procInstance
|
||||
<|> do { m <- md ; sMainMarker ; eol ; return $ nd m $ N.MainProcess }
|
||||
<|> do { m <- md ; a <- allocation ; p <- process ; return $ nd m $ N.Decl a p }
|
||||
<|> do { m <- md ; s <- specification ; p <- process ; return $ nd m $ N.Decl s p }
|
||||
<?> "process"
|
||||
|
||||
protocol
|
||||
= try name
|
||||
<|> simpleProtocol
|
||||
<?> "protocol"
|
||||
|
||||
real
|
||||
= try (do { m <- md ; l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ nd m $ N.LitReal (l ++ "." ++ r ++ "e" ++ e) })
|
||||
<|> do { m <- md ; l <- digits ; char '.' ; r <- lexeme digits ; return $ nd m $ N.LitReal (l ++ "." ++ r) }
|
||||
<?> "real"
|
||||
|
||||
replicator
|
||||
= do { m <- md ; n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ nd m $ N.For n b c }
|
||||
<?> "replicator"
|
||||
|
||||
selection
|
||||
= do { m <- md ; sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ nd m $ N.Case s os }
|
||||
<?> "selection"
|
||||
|
||||
selector
|
||||
= expression
|
||||
<?> "selector"
|
||||
|
||||
occamSequence
|
||||
= do m <- md
|
||||
sSEQ
|
||||
(do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Seq ps }
|
||||
<|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.SeqRep r p })
|
||||
<?> "sequence"
|
||||
|
||||
sequentialProtocol
|
||||
= do { l <- try $ sepBy1 simpleProtocol sSemi ; return $ l }
|
||||
<?> "sequentialProtocol"
|
||||
|
||||
simpleProtocol
|
||||
= try (do { m <- md ; l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ nd m $ N.Counted l r })
|
||||
<|> dataType
|
||||
<|> do { m <- md ; sANY ; return $ nd m $ N.Any }
|
||||
<?> "simpleProtocol"
|
||||
|
||||
specification
|
||||
= try declaration
|
||||
<|> try abbreviation
|
||||
<|> definition
|
||||
<?> "specification"
|
||||
|
||||
specifier
|
||||
= try dataType
|
||||
<|> try channelType
|
||||
<|> try timerType
|
||||
<|> try portType
|
||||
<|> try (do { m <- md ; sLeft ; sRight ; s <- specifier ; return $ nd m $ N.ArrayUnsized s })
|
||||
<|> do { m <- md ; sLeft ; e <- expression ; sRight ; s <- specifier ; return $ nd m $ N.Array e s }
|
||||
<?> "specifier"
|
||||
|
||||
structuredType
|
||||
= try (do { m <- md ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.Record fs })
|
||||
<|> do { m <- md ; sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.PackedRecord fs }
|
||||
<?> "structuredType"
|
||||
|
||||
-- FIXME this should use the same type-folding code as proc/func definitions
|
||||
structuredTypeField
|
||||
= do { m <- md ; t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ nd m $ N.Fields t fs }
|
||||
<?> "structuredTypeField"
|
||||
|
||||
-- i.e. array literal
|
||||
table
|
||||
= do { m <- md ; v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "table"
|
||||
|
||||
table'
|
||||
= try occamString
|
||||
<|> try (do { m <- md ; s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ nd m $ N.TypedLit n s })
|
||||
<|> do { sLeft ;
|
||||
try (do { m <- md ; es <- sepBy1 expression sComma ; sRight ; return $ nd m $ N.LitArray es })
|
||||
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; n <- table ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n } }
|
||||
<?> "table'"
|
||||
|
||||
tag
|
||||
= name
|
||||
<?> "tag"
|
||||
|
||||
taggedList
|
||||
= try (do { m <- md ; t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ nd m $ N.Tag t is })
|
||||
<|> do { m <- md ; t <- tag ; return $ nd m $ N.Tag t [] }
|
||||
<?> "taggedList"
|
||||
|
||||
taggedProtocol
|
||||
= try (do { m <- md ; t <- tag ; eol ; return $ nd m $ N.Tag t [] })
|
||||
<|> try (do { m <- md ; t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ nd m $ N.Tag t sp })
|
||||
|
||||
timerType
|
||||
= do { m <- md ; sTIMER ; return $ nd m $ N.Timer }
|
||||
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ nd m $ N.Array s t }
|
||||
<?> "timerType"
|
||||
|
||||
valueProcess
|
||||
= try (do { m <- md ; sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ nd m $ N.ValOf p el })
|
||||
<|> do { m <- md ; s <- specification ; v <- valueProcess ; return $ nd m $ N.Decl s v }
|
||||
|
||||
variable
|
||||
= do { m <- md ; v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "variable"
|
||||
|
||||
variable'
|
||||
= try name
|
||||
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||
<?> "variable'"
|
||||
|
||||
variableList
|
||||
= do { vs <- sepBy1 variable sComma ; return $ vs }
|
||||
<?> "variableList"
|
||||
|
||||
variant
|
||||
= try (do { m <- md ; t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Variant t p })
|
||||
<|> do { m <- md ; s <- specification ; v <- variant ; return $ nd m $ N.Decl s v }
|
||||
<?> "variant"
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- 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 = do { whiteSpace ; process }
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- XXX this doesn't handle multi-line strings
|
||||
-- XXX or VALOF processes
|
||||
|
||||
countIndent :: String -> Int
|
||||
countIndent (' ':' ':cs) = 1 + (countIndent cs)
|
||||
countIndent (' ':cs) = error "Bad indentation"
|
||||
countIndent _ = 0
|
||||
|
||||
stripIndent :: String -> String
|
||||
stripIndent (' ':cs) = stripIndent cs
|
||||
stripIndent cs = cs
|
||||
|
||||
stripComment :: String -> String
|
||||
stripComment [] = []
|
||||
stripComment ('-':'-':s) = []
|
||||
stripComment ('"':s) = '"' : stripCommentInString s
|
||||
stripComment (c:s) = c : stripComment s
|
||||
|
||||
stripCommentInString :: String -> String
|
||||
stripCommentInString [] = error "In string at end of line"
|
||||
stripCommentInString ('"':s) = '"' : stripComment s
|
||||
stripCommentInString (c:s) = c : stripCommentInString s
|
||||
|
||||
flatten :: [String] -> String
|
||||
flatten ls = concat $ intersperse "\n" $ flatten' ls 0
|
||||
where
|
||||
rep n i = take n (repeat i)
|
||||
flatten' [] level = [rep level '}']
|
||||
flatten' (s:ss) level
|
||||
| stripped == "" = "" : flatten' ss level
|
||||
| newLevel > level = (rep (newLevel - level) '{' ++ stripped) : rest
|
||||
| newLevel < level = (rep (level - newLevel) '}' ++ stripped) : rest
|
||||
| otherwise = stripped : rest
|
||||
where newLevel = countIndent s
|
||||
stripped' = stripComment s
|
||||
stripped = if stripIndent stripped' == "" then "" else (stripped' ++ "@")
|
||||
rest = flatten' ss newLevel
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- XXX Doesn't handle preprocessor instructions.
|
||||
|
||||
preprocess :: String -> String
|
||||
preprocess d = flatten $ 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
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
parseSource :: String -> String -> N.Node
|
||||
parseSource prep sourceFileName
|
||||
= case (parse sourceFile sourceFileName prep) of
|
||||
Left err -> error ("Parsing error: " ++ (show err))
|
||||
Right defs -> defs
|
||||
|
||||
49
fco2/PrettyShow.hs
Normal file
49
fco2/PrettyShow.hs
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
-- A generic show implementation that pretty-prints expressions
|
||||
-- This ought to use a class (like show does), so that it can be extended
|
||||
-- properly without me needing to have FCO-specific cases in here -- see the
|
||||
-- appropriate SYB paper.
|
||||
|
||||
module PrettyShow (pshow) where
|
||||
|
||||
import Data.Generics
|
||||
import Text.PrettyPrint.HughesPJ
|
||||
import Metadata
|
||||
|
||||
-- This is ugly -- but it looks like you can't easily define a generic function
|
||||
-- even for a single tuple type, since it has to parameterise over multiple Data
|
||||
-- types...
|
||||
isTupleCtr :: String -> Bool
|
||||
isTupleCtr ('(':cs) = checkRest cs
|
||||
where
|
||||
checkRest ",)" = True
|
||||
checkRest (',':cs) = checkRest cs
|
||||
checkRest _ = False
|
||||
isTupleCtr _ = False
|
||||
|
||||
doGeneral :: Data a => a -> Doc
|
||||
doGeneral t =
|
||||
if isTupleCtr cn then
|
||||
parens $ sep $ punctuate (text ",") l
|
||||
else case l of
|
||||
[] -> con
|
||||
otherwise -> parens $ sep (con : l)
|
||||
where
|
||||
cn = showConstr (toConstr t)
|
||||
con = text $ cn
|
||||
l = gmapQ doAny t
|
||||
|
||||
doList :: Data a => [a] -> Doc
|
||||
doList t = brackets $ sep $ punctuate (text ",") (map doAny t)
|
||||
|
||||
doString :: String -> Doc
|
||||
doString s = text $ show s
|
||||
|
||||
doMeta :: Meta -> Doc
|
||||
doMeta m = text $ formatSourcePos m
|
||||
|
||||
doAny :: Data a => a -> Doc
|
||||
doAny = doGeneral `ext1Q` doList `extQ` doString `extQ` doMeta
|
||||
|
||||
pshow :: Data a => a -> String
|
||||
pshow x = render $ doAny x
|
||||
|
||||
Loading…
Reference in New Issue
Block a user