module Language.Pascal.Parser (parseSource, pProgram) where
import Control.Applicative ((<$>))
import qualified Data.Map as M
import Text.Parsec
import qualified Text.Parsec.Token as P
import Text.Parsec.Language
import Text.Parsec.Expr
import Language.Pascal.Types
type Parser a = Parsec String () a
pascal = P.makeTokenParser $ javaStyle {
P.commentStart = "(*",
P.commentEnd = "*)",
P.reservedNames = ["program", "function", "begin", "end", "var", "true", "false",
"return", "if", "then", "else", "for", "to", "do", "of",
"exit", "procedure", "break", "continue", "array", "record",
"const", "type" ] }
symbol = P.symbol pascal
reserved = P.reserved pascal
reservedOp = P.reservedOp pascal
identifier = P.identifier pascal
stringLiteral = P.stringLiteral pascal
integer = P.integer pascal
semi = P.semi pascal
colon = P.colon pascal
comma = P.comma pascal
dot = P.dot pascal
parens = P.parens pascal
brackets = P.brackets pascal
withAnnotation :: Parser x -> Parser (Annotate x SrcPos)
withAnnotation p = do
pos <- getPosition
x <- p
return $ Annotate x $ SrcPos {
srcLine = sourceLine pos,
srcColumn = sourceColumn pos }
pProgram :: Parser (Program :~ SrcPos)
pProgram = withAnnotation $ do
reserved "program"
identifier
semi
consts <- option [] pConsts
types <- M.fromList <$> option [] pTypes
vars <- option [] pVars
fns <- many (try pFunction <|> pProcedure)
reserved "begin"
sts <- pStatement `sepEndBy1` semi
reserved "end"
dot
return $ Program consts types vars fns sts
readType str =
case str of
"integer" -> TInteger
"string" -> TString
"boolean" -> TBool
"void" -> TVoid
s -> TUser s
pVars :: Parser [Annotate Symbol SrcPos]
pVars = do
reserved "var"
lists <- pVarsList `sepEndBy1` semi
return $ concat lists
pTypes :: Parser [(Id, Type)]
pTypes = do
reserved "type"
many1 $ do
name <- identifier
reservedOp "="
tp <- pType
semi
return (name, content tp)
pConsts :: Parser [(Id, Expression :~ SrcPos)]
pConsts = do
reserved "const"
many1 $ do
name <- identifier
reservedOp "="
value <- pExpression
semi
return (name, value)
pVarsList :: Parser [Annotate Symbol SrcPos]
pVarsList = do
pos <- getPosition
names <- identifier `sepBy` comma
colon
tp <- pType
return $ map (ret tp pos) names
where
ret tp pos name = Annotate (name # content tp) $
SrcPos {
srcLine = sourceLine pos,
srcColumn = sourceColumn pos }
pType :: Parser (Annotate Type SrcPos)
pType = try arrayType <|> try recordType <|> simpleType
where
arrayType = withAnnotation $ do
reserved "array"
sz <- brackets integer
reserved "of"
tp <- pType
return (TArray sz $ content tp)
recordType = withAnnotation $ do
reserved "record"
fields <- field `sepEndBy1` semi
reserved "end"
return (TRecord fields)
field = do
name <- identifier
colon
tp <- pType
return (name, content tp)
simpleType = withAnnotation $ do
name <- identifier
return (readType name)
pNameType :: Parser (Annotate Symbol SrcPos)
pNameType = withAnnotation $ do
name <- identifier
colon
tp <- pType
return $ name # content tp
pFunction :: Parser (Function :~ SrcPos)
pFunction = withAnnotation $ do
reserved "function"
name <- identifier
args <- parens $ pNameType `sepBy` comma
colon
res <- identifier
semi
vars <- option [] pVars
reserved "begin"
body <- pStatement `sepEndBy1` semi
reserved "end"
semi
return $ Function name args (readType res) vars body
pProcedure :: Parser (Function :~ SrcPos)
pProcedure = withAnnotation $ do
reserved "procedure"
name <- identifier
args <- parens $ pNameType `sepBy` comma
semi
vars <- option [] pVars
reserved "begin"
body <- pStatement `sepEndBy1` semi
reserved "end"
semi
return $ Function name args TVoid vars body
pStatement :: Parser (Statement :~ SrcPos)
pStatement =
try pIfThenElse
<|> try pAssign
<|> try pProcedureCall
<|> try (withAnnotation (reserved "break" >> return Break))
<|> try (withAnnotation (reserved "continue" >> return Continue))
<|> try (withAnnotation (reserved "exit" >> return Exit))
<|> try pReturn
<|> pFor
pAssign :: Parser (Statement :~ SrcPos)
pAssign = withAnnotation $ do
lv <- pLValue
symbol ":="
expr <- pExpression
return $ Assign lv expr
pLValue :: Parser (LValue :~ SrcPos)
pLValue = try arrayItem <|> try recordField <|> variable
where
arrayItem = withAnnotation $ do
arr <- identifier
ix <- brackets pExpression
return (LArray arr ix)
variable = withAnnotation (LVariable <$> identifier)
recordField = withAnnotation $ do
base <- identifier
dot
field <- identifier
return (LField base field)
pProcedureCall = withAnnotation $ do
name <- identifier
args <- parens $ pExpression `sepBy` comma
return $ Procedure name args
pReturn :: Parser (Statement :~ SrcPos)
pReturn = withAnnotation $ do
reserved "return"
x <- pExpression
return $ Return x
pIfThenElse :: Parser (Statement :~ SrcPos)
pIfThenElse = withAnnotation $ do
reserved "if"
cond <- pExpression
reserved "then"
ok <- pBlock
el <- option [] $ try $ do
reserved "else"
pBlock
return $ IfThenElse cond ok el
pBlock = try (one <$> pStatement) <|> do
reserved "begin"
sts <- pStatement `sepEndBy1` semi
reserved "end"
return sts
where
one x = [x]
pFor = withAnnotation $ do
reserved "for"
var <- identifier
reserved ":="
start <- pExpression
reserved "to"
end <- pExpression
reserved "do"
sts <- pBlock
return $ For var start end sts
pExpression :: Parser (Expression :~ SrcPos)
pExpression = buildExpressionParser table term <?> "expression"
where
table = [
[binary "^" Pow AssocLeft],
[binary "*" Mul AssocLeft, binary "/" Div AssocLeft, binary "%" Mod AssocLeft ],
[binary "+" Add AssocLeft, binary "-" Sub AssocLeft ],
[binary "=" IsEQ AssocLeft, binary "!=" IsNE AssocLeft, binary ">" IsGT AssocLeft, binary "<" IsLT AssocLeft ]
]
binary name fun assoc = Infix (op name fun) assoc
op name fun = do
pos <- getPosition
reservedOp name
return $ \x y -> Annotate (Op fun x y) $ SrcPos {
srcLine = sourceLine pos,
srcColumn = sourceColumn pos }
term = parens pExpression
<|> try (withAnnotation $ Literal <$> pLiteral)
<|> try pCall
<|> try pArrayItem
<|> try pRecordField
<|> pVariable
pLiteral = try stringLit <|> try intLit <|> boolLit
where
stringLit = LString <$> stringLiteral
intLit = LInteger <$> integer
boolLit = try (reserved "true" >> return (LBool True)) <|> (reserved "false" >> return (LBool False))
pVariable :: Parser (Expression :~ SrcPos)
pVariable = withAnnotation $ Variable <$> identifier
pArrayItem :: Parser (Expression :~ SrcPos)
pArrayItem = withAnnotation $ do
arr <- identifier
ix <- brackets pExpression
return (ArrayItem arr ix)
pRecordField :: Parser (Expression :~ SrcPos)
pRecordField = withAnnotation $ do
base <- identifier
dot
field <- identifier
return (RecordField base field)
pCall :: Parser (Expression :~ SrcPos)
pCall = withAnnotation $ do
name <- identifier
args <- parens $ pExpression `sepBy` comma
return $ Call name args
parseSource :: FilePath -> IO (Program :~ SrcPos)
parseSource path = do
src <- readFile path
case parse pProgram path src of
Left err -> fail $ show err
Right x -> return x