diff -r 57523ab57218 -r 0a99f73dd8dd tools/PascalParser.hs --- a/tools/PascalParser.hs Thu Nov 03 05:15:39 2011 +0100 +++ b/tools/PascalParser.hs Thu Nov 03 17:15:54 2011 +0400 @@ -1,98 +1,357 @@ module PascalParser where import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Token +import Text.ParserCombinators.Parsec.Language import Control.Monad +import Data.Char data PascalUnit = - Program Identificator Implementation FunctionBody - | Unit Identificator Interface Implementation (Maybe Initialize) (Maybe Finalize) + Program Identifier Implementation + | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) deriving Show data Interface = Interface Uses TypesAndVars deriving Show -data Implementation = Implementation Uses TypesAndVars Functions +data Implementation = Implementation Uses TypesAndVars deriving Show -data Functions = Functions [Function] +data Identifier = Identifier String + deriving Show +data TypesAndVars = TypesAndVars [TypeVarDeclaration] deriving Show -data Function = Function String +data TypeVarDeclaration = TypeDeclaration TypeDecl + | ConstDeclaration String + | VarDeclaration String + | FunctionDeclaration Identifier Identifier (Maybe Phrase) deriving Show -data Identificator = Identificator String +data TypeDecl = SimpleType Identifier + | RangeType Range + | ArrayDecl Range TypeDecl + deriving Show +data Range = Range Identifier + deriving Show +data Initialize = Initialize String deriving Show -data FunctionBody = FunctionBody String +data Finalize = Finalize String deriving Show -data TypesAndVars = TypesAndVars String +data Uses = Uses [Identifier] deriving Show -data Initialize = Initialize Functions +data Phrase = ProcCall Identifier [Expression] + | IfThenElse Expression Phrase (Maybe Phrase) + | WhileCycle Expression Phrase + | RepeatCycle Expression Phrase + | ForCycle + | Phrases [Phrase] + | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase) + | Assignment Identifier Expression deriving Show -data Finalize = Finalize Functions +data Expression = Expression String + | FunCall Identifier [Expression] + | PrefixOp String Expression + | BinOp String Expression Expression deriving Show -data Uses = Uses [Identificator] - deriving Show + -parsePascalUnit :: String -> Either ParseError PascalUnit -parsePascalUnit = parse pascalUnit "unit" - where - comments = skipMany (comment >> spaces) - identificator = do - spaces - l <- letter <|> oneOf "_" - ls <- many (alphaNum <|> oneOf "_") - spaces - return $ Identificator (l:ls) - - pascalUnit = do - spaces - comments - u <- choice [program, unit] - comments - spaces - return u - - comment = choice [ - char '{' >> manyTill anyChar (try $ char '}') - , string "(*" >> manyTill anyChar (try $ string "*)") - , string "//" >> manyTill anyChar (try newline) +pascalLanguageDef + = emptyDef + { commentStart = "(*" + , commentEnd = "*)" + , commentLine = "//" + , nestedComments = False + , identStart = letter <|> oneOf "_" + , identLetter = alphaNum <|> oneOf "_." + , reservedNames = [ + "begin", "end", "program", "unit", "interface" + , "implementation", "and", "or", "xor", "shl" + , "shr", "while", "do", "repeat", "until", "case", "of" + , "type", "var", "const", "out", "array" + , "procedure", "function" ] - - unit = do - name <- unitName + , reservedOpNames= [] + , caseSensitive = False + } + +pas = makeTokenParser pascalLanguageDef + +comments = do + spaces + skipMany $ do + comment spaces + +validIdChar = alphaNum <|> oneOf "_" + +pascalUnit = do + comments + u <- choice [program, unit] + comments + return u + +comment = choice [ + char '{' >> manyTill anyChar (try $ char '}') + , (try $ string "(*") >> manyTill anyChar (try $ string "*)") + , (try $ string "//") >> manyTill anyChar (try newline) + ] + +unit = do + name <- liftM Identifier unitName + comments + int <- interface + impl <- implementation + comments + return $ Unit name int impl Nothing Nothing + where + unitName = between (string "unit" >> comments) (char ';') (identifier pas) + +varsDecl = do + v <- aVarDecl `sepBy1` (char ';' >> comments) + char ';' + comments + return $ VarDeclaration $ show v + where + aVarDecl = do + ids <- (try (identifier pas) >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments) + char ':' comments - int <- string "interface" >> interface - manyTill anyChar (try $ string "implementation") - spaces + t <- typeDecl + comments + return (ids, t) + +typeDecl = choice [ + arrayDecl + , rangeDecl >>= return . RangeType + , identifier pas >>= return . SimpleType . Identifier + ] "type declaration" + where + arrayDecl = do + try $ string "array" + comments + char '[' + r <- rangeDecl + char ']' + comments + string "of" comments - impl <- implementation - return $ Unit name int impl Nothing Nothing - where - unitName = between (string "unit") (char ';') identificator + t <- typeDecl + return $ ArrayDecl r t + +rangeDecl = choice [ + identifier pas >>= return . Range . Identifier + ] "range declaration" - interface = do - spaces +typeVarDeclaration isImpl = choice [ + varSection, + funcDecl, + procDecl + ] + where + varSection = do + try $ string "var" + comments + v <- varsDecl + return v + + procDecl = do + string "procedure" + comments + i <- liftM Identifier $ identifier pas + optional $ do + char '(' + varsDecl + char ')' + comments + char ';' + b <- if isImpl then + do + comments + typeVarDeclaration isImpl + comments + liftM Just functionBody + else + return Nothing + comments + return $ FunctionDeclaration i (Identifier "") b + + funcDecl = do + string "function" comments - u <- uses - return $ Interface u (TypesAndVars "") + char '(' + b <- manyTill anyChar (try $ char ')') + char ')' + comments + char ':' + ret <- identifier pas + comments + char ';' + b <- if isImpl then + do + comments + typeVarDeclaration isImpl + comments + liftM Just functionBody + else + return Nothing + return $ FunctionDeclaration (Identifier "function") (Identifier ret) Nothing + +program = do + name <- liftM Identifier programName + comments + impl <- implementation + comments + return $ Program name impl + where + programName = between (string "program") (char ';') (identifier pas) + +interface = do + string "interface" + comments + u <- uses + comments + tv <- many (typeVarDeclaration False) + comments + return $ Interface u (TypesAndVars tv) - program = do - name <- programName - spaces - comments - impl <- implementation - return $ Program name impl (FunctionBody "") - where - programName = between (string "program") (char ';') identificator +implementation = do + string "implementation" + comments + u <- uses + comments + tv <- many (typeVarDeclaration True) + string "end." + comments + return $ Implementation u (TypesAndVars tv) + +expression = buildExpressionParser table term "expression" + where + term = comments >> choice [ + parens pas $ expression + , natural pas >>= return . Expression . show + , funCall + ] "simple expression" + + table = [ + [Infix (string "^." >> return (BinOp "^.")) AssocLeft] + , [Prefix (string "not" >> return (PrefixOp "not"))] + , [ Infix (char '*' >> return (BinOp "*")) AssocLeft + , Infix (char '/' >> return (BinOp "/")) AssocLeft + ] + , [ Infix (char '+' >> return (BinOp "+")) AssocLeft + , Infix (char '-' >> return (BinOp "-")) AssocLeft + ] + , [ Infix (try (string "<>" )>> return (BinOp "<>")) AssocNone + , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone + , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone + , Infix (char '<' >> return (BinOp "<")) AssocNone + , Infix (char '>' >> return (BinOp ">")) AssocNone + , Infix (char '=' >> return (BinOp "=")) AssocNone + ] + , [ Infix (try $ string "and" >> return (BinOp "and")) AssocNone + , Infix (try $ string "or" >> return (BinOp "or")) AssocNone + , Infix (try $ string "xor" >> return (BinOp "xor")) AssocNone + ] + ] + +phrasesBlock = do + try $ string "begin" + comments + p <- manyTill phrase (try $ string "end") + comments + return $ Phrases p + +phrase = do + o <- choice [ + phrasesBlock + , ifBlock + , whileCycle + , switchCase + , try $ identifier pas >>= \i -> string ":=" >> expression >>= return . Assignment (Identifier i) + , procCall + ] + optional $ char ';' + comments + return o - implementation = do - u <- uses - manyTill anyChar (try $ string "end.") - return $ Implementation u (TypesAndVars "") (Functions []) +ifBlock = do + try $ string "if" + comments + e <- expression + comments + string "then" + comments + o1 <- phrase + comments + o2 <- optionMaybe $ do + try $ string "else" + comments + o <- phrase + comments + return o + optional $ char ';' + return $ IfThenElse e o1 o2 + +whileCycle = do + try $ string "while" + comments + e <- expression + comments + string "do" + comments + o <- phrase + optional $ char ';' + return $ WhileCycle e o - uses = liftM Uses (option [] u) - where - u = do - string "uses" - spaces - u <- (identificator >>= \i -> spaces >> return i) `sepBy1` (char ',' >> spaces) - char ';' - spaces - return u +switchCase = do + try $ string "case" + comments + e <- expression + comments + string "of" + comments + cs <- many1 aCase + o2 <- optionMaybe $ do + try $ string "else" + comments + o <- phrase + comments + return o + string "end" + optional $ char ';' + return $ SwitchCase e cs o2 + where + aCase = do + e <- expression + comments + char ':' + comments + p <- phrase + comments + return (e, p) + +procCall = do + i <- liftM Identifier $ identifier pas + p <- option [] $ (parens pas) parameters + return $ ProcCall i p + +funCall = do + i <- liftM Identifier $ identifier pas + p <- option [] $ (parens pas) parameters + return $ FunCall i p + +parameters = expression `sepBy` (char ',' >> comments) + +functionBody = do + p <- phrasesBlock + char ';' + comments + return p + +uses = liftM Uses (option [] u) + where + u = do + string "uses" + comments + u <- (identifier pas >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments) + char ';' + comments + return u