Rain: Parser and Parser-Test framework
Initial commit of the beginnings of a Rain parser (still using the original occam AST) and its test framework, using HUnit
This commit is contained in:
Neil Brown
parent
fa9c108e50
commit
f997b823dc
4
Makefile
4
Makefile
|
|
@ -58,6 +58,10 @@ haddock:
|
|||
@mkdir -p doc
|
||||
haddock -o doc --html $(sources)
|
||||
|
||||
raintest: $(sources) RainParse.hs RainParseTest.hs Makefile
|
||||
ghc -fglasgow-exts -fallow-undecidable-instances -fwarn-unused-binds $(profile_opts) -o raintest -main-is RainParseTest --make RainParseTest
|
||||
|
||||
|
||||
clean:
|
||||
rm -f $(targets) *.o *.hi
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ data Meta = Meta {
|
|||
metaLine :: Int,
|
||||
metaColumn :: Int
|
||||
}
|
||||
deriving (Eq, Typeable, Data)
|
||||
deriving (Typeable, Data)
|
||||
|
||||
emptyMeta :: Meta
|
||||
emptyMeta = Meta {
|
||||
|
|
@ -24,3 +24,10 @@ instance Show Meta where
|
|||
case metaFile m of
|
||||
Just s -> basenamePath s ++ ":" ++ show (metaLine m) ++ ":" ++ show (metaColumn m)
|
||||
Nothing -> "no source position"
|
||||
|
||||
--emptyMeta is equal to any meta tag:
|
||||
instance Eq Meta where
|
||||
(==) a b =
|
||||
if ((metaFile a == Nothing) && (metaLine a == 0) && (metaColumn a == 0)) then True else
|
||||
if ((metaFile b == Nothing) && (metaLine b == 0) && (metaColumn b == 0)) then True else
|
||||
((metaFile a == metaFile b) && (metaLine a == metaLine b) && (metaColumn a == metaColumn b))
|
||||
|
|
|
|||
225
RainParse.hs
Normal file
225
RainParse.hs
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
module RainParse where
|
||||
|
||||
import qualified Text.ParserCombinators.Parsec.Token as P
|
||||
import Parse (tryXV)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--Chuck a whole load from Parse:
|
||||
import Control.Monad (liftM, when)
|
||||
import Control.Monad.Error (runErrorT)
|
||||
import Control.Monad.State (MonadState, StateT, execStateT, liftIO, modify, get, put)
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Debug.Trace
|
||||
import qualified IO
|
||||
import Numeric (readHex)
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Text.ParserCombinators.Parsec.Language (emptyDef)
|
||||
import Text.Regex
|
||||
|
||||
import qualified AST as A
|
||||
import CompState
|
||||
import Errors
|
||||
import EvalConstants
|
||||
import EvalLiterals
|
||||
import Indentation
|
||||
import Intrinsics
|
||||
import Metadata
|
||||
import Pass
|
||||
import Types
|
||||
import Utils
|
||||
|
||||
|
||||
|
||||
--Dummy:
|
||||
type RainState = Int
|
||||
|
||||
type RainParser = GenParser Char RainState
|
||||
|
||||
|
||||
emptyState:: RainState
|
||||
emptyState = 0
|
||||
|
||||
{-
|
||||
instance MonadState st (GenParser tok st) where
|
||||
get = getState
|
||||
put = setState
|
||||
|
||||
instance Die (GenParser tok st) where
|
||||
die = fail
|
||||
-}
|
||||
|
||||
rainStyle
|
||||
= emptyDef
|
||||
{ P.commentLine = "#"
|
||||
, P.nestedComments = False
|
||||
, P.identStart = letter <|> char '_'
|
||||
, P.identLetter = alphaNum <|> char '_'
|
||||
, P.opStart = oneOf ":+-*/>=<!"
|
||||
, P.opLetter = oneOf "+-="
|
||||
, P.reservedOpNames= [
|
||||
"+",
|
||||
"-",
|
||||
"*",
|
||||
"/",
|
||||
"==",
|
||||
"<",
|
||||
">",
|
||||
">=",
|
||||
"<=",
|
||||
"!=",
|
||||
"-",
|
||||
":"
|
||||
]
|
||||
, P.reservedNames = [
|
||||
"par",
|
||||
"seq",
|
||||
"alt",
|
||||
"seqeach",
|
||||
"pareach",
|
||||
"channel",
|
||||
"one2one",
|
||||
"int",
|
||||
"if",
|
||||
"while",
|
||||
"process",
|
||||
"bool"
|
||||
{-
|
||||
"tuple",
|
||||
"sleep",
|
||||
"for",
|
||||
"until",
|
||||
"poison",
|
||||
"return",
|
||||
"function",
|
||||
"typedef",
|
||||
"sint8","sint16","sint32","sint64"
|
||||
"uint8","uint16","uint32","uint64"
|
||||
"shared",
|
||||
"template",
|
||||
"constant",
|
||||
"namespace"
|
||||
-}
|
||||
]
|
||||
, P.caseSensitive = True
|
||||
}
|
||||
|
||||
lexer :: P.TokenParser RainState
|
||||
lexer = P.makeTokenParser rainStyle
|
||||
|
||||
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
|
||||
sLeftQ = try $ symbol "["
|
||||
sRightQ = try $ symbol "]"
|
||||
sLeftR = try $ symbol "("
|
||||
sRightR = try $ symbol ")"
|
||||
sLeftC = try $ symbol "{"
|
||||
sRightC = try $ symbol "}"
|
||||
sEquality = try $ symbol "=="
|
||||
sSemiColon = try $ symbol ";"
|
||||
--}}}
|
||||
|
||||
--{{{ Keywords
|
||||
|
||||
sPar = reserved "par"
|
||||
sSeq = reserved "seq"
|
||||
sAlt = reserved "alt"
|
||||
sSeqeach = reserved "seqeach"
|
||||
sPareach = reserved "pareach"
|
||||
sChannel = reserved "channel"
|
||||
sOne2One = reserved "one2one"
|
||||
sBool = reserved "bool"
|
||||
sInt = reserved "int"
|
||||
sIf = reserved "if"
|
||||
sElse = reserved "else"
|
||||
sWhile = reserved "while"
|
||||
sProcess = reserved "process"
|
||||
--}}}
|
||||
|
||||
--{{{Ideas nicked from GenerateC:
|
||||
md :: RainParser Meta
|
||||
md
|
||||
= do pos <- getPosition
|
||||
return Meta {
|
||||
metaFile = Just $ sourceName pos,
|
||||
metaLine = sourceLine pos,
|
||||
metaColumn = sourceColumn pos
|
||||
}
|
||||
|
||||
name :: A.NameType -> RainParser A.Name
|
||||
name nt
|
||||
= do m <- md
|
||||
s <- identifier
|
||||
return $ A.Name m nt s
|
||||
<?> show nt
|
||||
|
||||
--}}}
|
||||
|
||||
dataType :: RainParser A.Type
|
||||
dataType
|
||||
= do {sBool ; return A.Bool}
|
||||
<|> do {sInt ; return A.Int64}
|
||||
<|> do {sChannel ; inner <- dataType ; return $ A.Chan inner}
|
||||
<?> "data type"
|
||||
|
||||
variableId :: RainParser A.Variable
|
||||
variableId = do {m <- md ; v <- (name A.VariableName) ; return $ A.Variable m v}
|
||||
<?> "variable name"
|
||||
|
||||
|
||||
expression :: RainParser A.Expression
|
||||
expression
|
||||
= do {m <- md ; lhs <- subExpression ;
|
||||
do {sEquality ; rhs <- expression ; return $ A.Dyadic m A.Eq lhs rhs}
|
||||
<|> do {return lhs}
|
||||
}
|
||||
<?> "expression"
|
||||
|
||||
subExpression :: RainParser A.Expression
|
||||
subExpression
|
||||
= do {m <- md ; id <- variableId ; return $ A.ExprVariable m id}
|
||||
<?> "[sub-]expression"
|
||||
|
||||
block :: RainParser A.Structured
|
||||
block = do {m <- md ; sLeftC ; procs <- (many statement) ; sts <- sequence (map wrapProc procs) ; sRightC ; return $ A.Several m sts}
|
||||
where
|
||||
wrapProc :: A.Process -> RainParser A.Structured
|
||||
wrapProc x = return (A.OnlyP emptyMeta x)
|
||||
|
||||
optionalSeq :: RainParser ()
|
||||
optionalSeq = option () sSeq
|
||||
|
||||
--assignOp :: RainParser (Maybe DyadicOp)
|
||||
--TODO consume an optional operator, then an equals sign (so we can handle = += /= etc) This should not handle !=, nor crazy things like ===, <== (nor <=)
|
||||
|
||||
lvalue :: RainParser A.Variable
|
||||
--For now, only handle plain variables:
|
||||
lvalue = variableId
|
||||
|
||||
statement :: RainParser A.Process
|
||||
statement
|
||||
= do { m <- md ; sWhile ; sLeftR ; exp <- expression ; sRightR ; st <- statement ; return $ A.While m exp st}
|
||||
<|> do { m <- md ; sIf ; sLeftR ; exp <- expression ; sRightR ; st <- statement ;
|
||||
option (A.If m $ A.Several m [A.OnlyC m (A.Choice m exp st), A.OnlyC m (A.Choice m (A.True m) (A.Skip m))])
|
||||
(do {sElse ; elSt <- statement ; return (A.If m $ A.Several m [A.OnlyC m (A.Choice m exp st), A.OnlyC m (A.Choice m (A.True m) elSt)])})
|
||||
}
|
||||
<|> do { m <- md ; optionalSeq ; b <- block ; return $ A.Seq m b}
|
||||
<|> do { m <- md ; sPar ; b <- block ; return $ A.Par m A.PlainPar b}
|
||||
--TODO
|
||||
-- <|> do { m <- md ; lv <- lvalue ; op <- assignOp ; exp <- expression ; sSemiColon ; return {-TODO-} }
|
||||
<|> do { m <- md ; sSemiColon ; return $ A.Skip m}
|
||||
<?> "statement"
|
||||
|
||||
180
RainParseTest.hs
Normal file
180
RainParseTest.hs
Normal file
|
|
@ -0,0 +1,180 @@
|
|||
module RainParseTest () where
|
||||
|
||||
import qualified RainParse as RP
|
||||
import qualified AST as A
|
||||
import Text.ParserCombinators.Parsec (runParser,eof)
|
||||
import Test.HUnit
|
||||
import Metadata (Meta,emptyMeta)
|
||||
import Prelude hiding (fail)
|
||||
|
||||
data ParseTest a = Show a => ExpPass (String, RP.RainParser a , (a -> Assertion)) | ExpFail (String, RP.RainParser a)
|
||||
|
||||
pass :: Show a => (String, RP.RainParser a , (a -> Assertion)) -> ParseTest a
|
||||
pass x = ExpPass x
|
||||
|
||||
fail :: Show a => (String, RP.RainParser a) -> ParseTest a
|
||||
fail x = ExpFail x
|
||||
|
||||
--TODO must make sure that the whole input is consumed? (is this needed?)
|
||||
|
||||
--Runs a parse test, given a tuple of: (source text, parser function, assert)
|
||||
testParsePass :: Show a => (String, RP.RainParser a , (a -> Assertion)) -> Assertion
|
||||
testParsePass (text,prod,test)
|
||||
= case (runParser parser RP.emptyState "" text) of
|
||||
Left error -> assertString (show error)
|
||||
Right result -> ((return result) >>= test)
|
||||
where parser = do { p <- prod ; eof ; return p}
|
||||
|
||||
testParseFail :: Show a => (String, RP.RainParser a) -> Assertion
|
||||
testParseFail (text,prod)
|
||||
= case (runParser parser RP.emptyState "" text) of
|
||||
Left error -> return ()
|
||||
Right result -> assertFailure ("Test was expected to fail:\n***BEGIN CODE***\n" ++ text ++ "\n*** END CODE ***\n")
|
||||
where parser = do { p <- prod ; eof ; return p}
|
||||
|
||||
m :: Meta
|
||||
m = emptyMeta
|
||||
|
||||
--Helper function for creating an A.Name object:
|
||||
simpleName :: String -> A.Name
|
||||
simpleName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.VariableName }
|
||||
|
||||
--Helper function for creating a simple variable name as an expression:
|
||||
exprVariable :: String -> A.Expression
|
||||
exprVariable e = A.ExprVariable emptyMeta $ A.Variable emptyMeta $ simpleName e
|
||||
|
||||
testExp0 = pass ("b",RP.expression,
|
||||
assertEqual "Variable Expression Test" (exprVariable "b") )
|
||||
|
||||
testExp1 = pass ("b == c",RP.expression,
|
||||
assertEqual "Operator Expression Test" $ A.Dyadic emptyMeta A.Eq (exprVariable "b") (exprVariable "c") )
|
||||
|
||||
--Helper function for ifs:
|
||||
makeIf :: [(A.Expression,A.Process)] -> A.Process
|
||||
makeIf list = A.If m $ A.Several m (map makeChoice list)
|
||||
where
|
||||
makeChoice :: (A.Expression,A.Process) -> A.Structured
|
||||
makeChoice (exp,proc) = A.OnlyC m $ A.Choice m exp proc
|
||||
|
||||
makeSimpleAssign :: String -> String -> A.Process
|
||||
makeSimpleAssign dest src = A.Assign m [A.Variable m $ simpleName dest] (A.ExpressionList m [exprVariable src])
|
||||
|
||||
testIf :: [ParseTest A.Process]
|
||||
testIf =
|
||||
[
|
||||
pass ("if (a) ;",RP.statement,
|
||||
assertEqual "If Test 0" $ makeIf [(exprVariable "a",A.Skip m),(A.True m,A.Skip m)])
|
||||
,pass ("if (a) ; else ;",RP.statement,
|
||||
assertEqual "If Test 1" $ makeIf [(exprVariable "a",A.Skip m),(A.True m,A.Skip m)])
|
||||
,pass ("if (a) ; else a = b;",RP.statement,
|
||||
assertEqual "If Test 2" $ makeIf [(exprVariable "a",A.Skip m),(A.True m,makeSimpleAssign "a" "b")])
|
||||
,pass ("if (a) ; else if (b) ; ",RP.statement,
|
||||
assertEqual "If Test 3" $ makeIf [(exprVariable "a",A.Skip m),(A.True m,makeIf [(exprVariable "b",A.Skip m),(A.True m,A.Skip m)])])
|
||||
,pass ("if (a) ; else if (b) ; else ; ",RP.statement,
|
||||
assertEqual "If Test 4" $ makeIf [(exprVariable "a",A.Skip m),(A.True m,makeIf [(exprVariable "b",A.Skip m),(A.True m,A.Skip m)])])
|
||||
,pass ("if (a) c = d; else if (b) e = f; else g = h;",RP.statement,
|
||||
assertEqual "If Test 5" $ makeIf [(exprVariable "a",makeSimpleAssign "c" "d"),(A.True m,makeIf [(exprVariable "b",makeSimpleAssign "e" "f"),(A.True m,makeSimpleAssign "g" "h")])])
|
||||
--TODO add fail tests, maybe {} brackets
|
||||
]
|
||||
|
||||
testAssign :: [ParseTest A.Process]
|
||||
testAssign =
|
||||
[
|
||||
pass ("a = b;",RP.statement,
|
||||
assertEqual "Assign Test 0" $ makeSimpleAssign "a" "b")
|
||||
,fail ("a != b;",RP.statement)
|
||||
]
|
||||
|
||||
testWhile :: [ParseTest A.Process]
|
||||
testWhile =
|
||||
[
|
||||
pass ("while (a) ;",RP.statement,
|
||||
assertEqual "While Test" $ A.While emptyMeta (exprVariable "a") (A.Skip emptyMeta) )
|
||||
,fail ("while (a)",RP.statement)
|
||||
,fail ("while () ;",RP.statement)
|
||||
,fail ("while () {}",RP.statement)
|
||||
,fail ("while ;",RP.statement)
|
||||
,fail ("while {}",RP.statement)
|
||||
,fail ("while ",RP.statement)
|
||||
]
|
||||
|
||||
testSeq :: [ParseTest A.Process]
|
||||
testSeq =
|
||||
[
|
||||
pass ("seq { }",RP.statement,
|
||||
assertEqual "Empty Seq Test" $ A.Seq m $ A.Several m [] )
|
||||
,pass ("seq { ; ; }",RP.statement,
|
||||
assertEqual "Seq Skip Test" $ A.Seq m $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m (A.Skip m))] )
|
||||
|
||||
,pass ("{ }",RP.statement,
|
||||
assertEqual "Empty Unlabelled-Seq Test" $ A.Seq m $ A.Several m [] )
|
||||
|
||||
,pass ("{ ; ; }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Skip Test" $ A.Seq m $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m (A.Skip m))] )
|
||||
|
||||
,pass ("{ { } }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 0" $ A.Seq m $ A.Several m [A.OnlyP m $ A.Seq m (A.Several m [])] )
|
||||
,pass ("seq { { } }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 1" $ A.Seq m $ A.Several m [A.OnlyP m $ A.Seq m (A.Several m [])] )
|
||||
,pass ("{ seq { } }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 2" $ A.Seq m $ A.Several m [A.OnlyP m $ A.Seq m (A.Several m [])] )
|
||||
|
||||
,pass ("{ ; {} }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 3" $ A.Seq m $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m $ A.Seq m (A.Several m []))] )
|
||||
|
||||
,pass ("seq { ; {} }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 4" $ A.Seq m $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m $ A.Seq m (A.Several m []))] )
|
||||
|
||||
,pass ("{ ; seq {} }",RP.statement,
|
||||
assertEqual "Unlabelled-Seq Nest Test 5" $ A.Seq m $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m $ A.Seq m (A.Several m []))] )
|
||||
|
||||
,fail ("seq",RP.statement)
|
||||
,fail ("seq ;",RP.statement)
|
||||
,fail ("seq {",RP.statement)
|
||||
,fail ("seq }",RP.statement)
|
||||
,fail ("{",RP.statement)
|
||||
,fail ("}",RP.statement)
|
||||
,fail ("seq seq {}",RP.statement)
|
||||
,fail ("seq seq",RP.statement)
|
||||
,fail ("seq {}}",RP.statement)
|
||||
,fail ("seq {{}",RP.statement)
|
||||
--should fail, because it is two statements, not one:
|
||||
,fail ("seq {};",RP.statement)
|
||||
,fail ("{};",RP.statement)
|
||||
|
||||
]
|
||||
|
||||
testPar :: [ParseTest A.Process]
|
||||
testPar =
|
||||
[
|
||||
pass ("par { }",RP.statement,
|
||||
assertEqual "Empty Par Test" $ A.Par m A.PlainPar $ A.Several m [] )
|
||||
|
||||
,pass ("par { ; ; }",RP.statement,
|
||||
assertEqual "Par Skip Test" $ A.Par m A.PlainPar $ A.Several m [(A.OnlyP m (A.Skip m)),(A.OnlyP m (A.Skip m))] )
|
||||
]
|
||||
|
||||
--Returns the list of tests:
|
||||
testList :: [Test]
|
||||
testList =
|
||||
[
|
||||
parseTest testExp0,parseTest testExp1,
|
||||
parseTests testWhile,
|
||||
parseTests testSeq,
|
||||
parseTests testPar,
|
||||
parseTests testIf,
|
||||
parseTests testAssign
|
||||
]
|
||||
|
||||
where
|
||||
parseTest :: Show a => ParseTest a -> Test
|
||||
parseTest (ExpPass test) = TestCase (testParsePass test)
|
||||
parseTest (ExpFail test) = TestCase (testParseFail test)
|
||||
parseTests :: Show a => [ParseTest a] -> Test
|
||||
parseTests tests = TestList (map parseTest tests)
|
||||
|
||||
|
||||
--Main function; runs the tests
|
||||
main :: IO ()
|
||||
main = do runTestTT $ TestList testList
|
||||
return ()
|
||||
Loading…
Reference in New Issue
Block a user