From f997b823dcf46346228566a9a6b5432d9ce39cdf Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Fri, 27 Jul 2007 15:11:52 +0000 Subject: [PATCH] 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 --- Makefile | 4 + Metadata.hs | 9 +- RainParse.hs | 225 +++++++++++++++++++++++++++++++++++++++++++++++ RainParseTest.hs | 180 +++++++++++++++++++++++++++++++++++++ 4 files changed, 417 insertions(+), 1 deletion(-) create mode 100644 RainParse.hs create mode 100644 RainParseTest.hs diff --git a/Makefile b/Makefile index 62673af..01a03f8 100644 --- a/Makefile +++ b/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 diff --git a/Metadata.hs b/Metadata.hs index 642e84b..4493b41 100644 --- a/Metadata.hs +++ b/Metadata.hs @@ -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)) diff --git a/RainParse.hs b/RainParse.hs new file mode 100644 index 0000000..8920807 --- /dev/null +++ b/RainParse.hs @@ -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.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" + diff --git a/RainParseTest.hs b/RainParseTest.hs new file mode 100644 index 0000000..cabfa9c --- /dev/null +++ b/RainParseTest.hs @@ -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 ()