sheepy-clone: comparison tools/PascalParser.hs

equal deleted inserted replaced

-:a3e1eb794249
+:f1b4f37dba22
 deriving Show
 data TypesAndVars = TypesAndVars [TypeVarDeclaration]
 deriving Show
 data TypeVarDeclaration = TypeDeclaration TypeDecl
 | ConstDeclaration String
-| VarDeclaration String
+| VarDeclaration Bool String
 | FunctionDeclaration Identifier Identifier (Maybe Phrase)
 deriving Show
 data TypeDecl = SimpleType Identifier
 | RangeType Range
 | ArrayDecl Range TypeDecl
 data Uses = Uses [Identifier]
 deriving Show
 data Phrase = ProcCall Identifier [Expression]
 | IfThenElse Expression Phrase (Maybe Phrase)
 | WhileCycle Expression Phrase
-| RepeatCycle Expression Phrase
+| RepeatCycle Expression [Phrase]
-| ForCycle
+| ForCycle Identifier Expression Expression Phrase
+| WithBlock Expression Phrase
 | Phrases [Phrase]
 | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)
-| Assignment Identifier Expression
+| Assignment Reference Expression
 deriving Show
 data Expression = Expression String
 | FunCall Identifier [Expression]
 | PrefixOp String Expression
+| PostfixOp String Expression
 | BinOp String Expression Expression
-deriving Show
+| StringLiteral String
+| NumberLiteral String
+| Reference Reference
+deriving Show
+data Reference = ArrayElement Identifier Expression
+| SimpleReference Identifier
+| RecordField Reference Reference
+| Dereference Reference
+deriving Show
 pascalLanguageDef
 = emptyDef
 { commentStart   = "(*"
 , commentEnd     = "*)"
 , commentLine    = "//"
 , 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"
+, "procedure", "function", "with", "for", "to"
+, "downto", "div", "mod"
 ]
 , reservedOpNames= []
 , caseSensitive  = False
 }
-pas = makeTokenParser pascalLanguageDef
+pas = patch $ makeTokenParser pascalLanguageDef
+where
+patch tp = tp {stringLiteral = between (char '\'') (char '\'') (many $ noneOf "'")}
 comments = do
 spaces
 skipMany $ do
 comment
 char '{' >> manyTill anyChar (try $ char '}')
 , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
 , (try $ string "//") >> manyTill anyChar (try newline)
 ]
+iD = do
+i <- liftM Identifier (identifier pas)
+comments
+return i
 unit = do
-name <- liftM Identifier unitName
+string "unit" >> comments
+name <- iD
+semi pas
 comments
 int <- interface
 impl <- implementation
 comments
 return $ Unit name int impl Nothing Nothing
-where
-unitName = between (string "unit" >> comments) (semi pas) (identifier pas)
+reference = buildExpressionParser table term <?> "reference"
+where
+term = comments >> choice [
+parens pas reference
+, try $ iD >>= \i -> (brackets pas) expression >>= return . ArrayElement i
+, iD >>= return . SimpleReference
+] <?> "simple reference"
+table = [
+[Postfix (char '^' >> return Dereference)]
+, [Infix (char '.' >> return RecordField) AssocLeft]
+]
 varsDecl endsWithSemi = do
 vs <- many (try (aVarDecl >> semi pas) >> comments)
 when (not endsWithSemi) $ aVarDecl >> return ()
 comments
-return $ VarDeclaration $ show vs
+return $ VarDeclaration False $ show vs
 where
 aVarDecl = do
-ids <- (commaSep1 pas) $ ((identifier pas) <?> "variable declaration") >>= \i -> comments >> return (Identifier i)
+when (not endsWithSemi) $
+optional $ choice [
+try $ string "var"
+, try $ string "const"
+, try $ string "out"
+]
+comments
+ids <- (commaSep1 pas) $ (iD <?> "variable declaration")
 char ':'
 comments
 t <- typeDecl
 comments
 return (ids, t)
+constsDecl = do
+vs <- many (try (aConstDecl >> semi pas) >> comments)
+comments
+return $ VarDeclaration True $ show vs
+where
+aConstDecl = do
+comments
+ids <- iD <?> "const declaration"
+optional $ do
+char ':'
+comments
+t <- typeDecl
+return ()
+char '='
+comments
+e <- expression
+comments
+return (ids, e)
 typeDecl = choice [
 arrayDecl
 , rangeDecl >>= return . RangeType
 , identifier pas >>= return . SimpleType . Identifier
 string "of"
 comments
 t <- typeDecl
 return $ ArrayDecl r t
 rangeDecl = choice [
-identifier pas >>= return . Range . Identifier
+iD >>= return . Range
 ] <?> "range declaration"
 typeVarDeclaration isImpl = choice [
 varSection,
+constSection,
 funcDecl,
 procDecl
 ]
 where
 varSection = do
 try $ string "var"
 comments
 v <- varsDecl True
 comments
 return v
+constSection = do
+try $ string "const"
+comments
+c <- constsDecl
+comments
+return c
 procDecl = do
 string "procedure"
 comments
-i <- liftM Identifier $ identifier pas
+i <- iD
 optional $ do
 char '('
 varsDecl False
 char ')'
+comments
+char ';'
+b <- if isImpl then
+do
+comments
+optional $ typeVarDeclaration isImpl
+comments
+liftM Just functionBody
+else
+return Nothing
+comments
+return $ FunctionDeclaration i (Identifier "") b
+funcDecl = do
+string "function"
+comments
+i <- iD
+optional $ do
+char '('
+varsDecl False
+char ')'
+comments
+char ':'
+ret <- iD
 comments
 char ';'
 b <- if isImpl then
 do
 comments
 typeVarDeclaration isImpl
 comments
 liftM Just functionBody
 else
 return Nothing
-comments
+return $ FunctionDeclaration i ret Nothing
-return $ FunctionDeclaration i (Identifier "") b
-funcDecl = do
-string "function"
-comments
-optional $ do
-char '('
-varsDecl False
-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
+string "program"
+comments
+name <- iD
+(char ';')
 comments
 impl <- implementation
 comments
 return $ Program name impl
-where
-programName = between (string "program") (char ';') (identifier pas)
 interface = do
 string "interface"
 comments
 u <- uses
 expression = buildExpressionParser table term <?> "expression"
 where
 term = comments >> choice [
 parens pas $ expression
-, natural pas >>= return . Expression . show
+, integer pas >>= return . NumberLiteral . show
-, funCall
+, stringLiteral pas >>= return . StringLiteral
+, try $ funCall
+, reference >>= return . Reference
 ] <?> "simple expression"
 table = [
-[Infix (string "^." >> return (BinOp "^.")) AssocLeft]
+[Prefix (string "not" >> return (PrefixOp "not"))]
-, [Prefix (string "not" >> return (PrefixOp "not"))]
 , [  Infix (char '*' >> return (BinOp "*")) AssocLeft
 , Infix (char '/' >> return (BinOp "/")) AssocLeft
-]
+, Infix (try (string "div") >> return (BinOp "div")) AssocLeft
+, Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
+]
 , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
 , Infix (char '-' >> return (BinOp "-")) AssocLeft
-]
+, Prefix (char '-' >> return (PrefixOp "-"))
-, [  Infix (try (string "<>" )>> return (BinOp "<>")) AssocNone
+]
+, [  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 "and" >> return (BinOp "and")) AssocLeft
-, Infix (try $ string "or" >> return (BinOp "or")) AssocNone
+, Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
-, Infix (try $ string "xor" >> return (BinOp "xor")) AssocNone
+, Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 ]
 ]
 phrasesBlock = do
 try $ string "begin"
 comments
 phrase = do
 o <- choice [
 phrasesBlock
 , ifBlock
 , whileCycle
+, repeatCycle
 , switchCase
-, try $ identifier pas >>= \i -> string ":=" >> expression >>= return . Assignment (Identifier i)
+, withBlock
+, forCycle
+, (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r
 , procCall
 ]
 optional $ char ';'
 comments
 return o
 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
+withBlock = do
+try $ string "with"
+comments
+e <- expression
+comments
+string "do"
+comments
+o <- phrase
+return $ WithBlock e o
+repeatCycle = do
+try $ string "repeat"
+comments
+o <- many phrase
+string "until"
+comments
+e <- expression
+comments
+return $ RepeatCycle e o
+forCycle = do
+try $ string "for"
+comments
+i <- iD
+comments
+string ":="
+comments
+e1 <- expression
+comments
+choice [string "to", string "downto"]
+comments
+e2 <- expression
+comments
+string "do"
+comments
+p <- phrase
+comments
+return $ ForCycle i e1 e2 p
 switchCase = do
 try $ string "case"
 comments
 e <- expression
 comments
 comments
 o <- phrase
 comments
 return o
 string "end"
-optional $ char ';'
 return $ SwitchCase e cs o2
 where
 aCase = do
 e <- expression
 comments
 p <- phrase
 comments
 return (e, p)
 procCall = do
-i <- liftM Identifier $ identifier pas
+i <- iD
 p <- option [] $ (parens pas) parameters
 return $ ProcCall i p
 funCall = do
-i <- liftM Identifier $ identifier pas
+i <- iD
-p <- option [] $ (parens pas) parameters
+p <- (parens pas) $ option [] parameters
 return $ FunCall i p
-parameters = expression `sepBy` (char ',' >> comments)
+parameters = (commaSep pas) expression <?> "parameters"
 functionBody = do
 p <- phrasesBlock
 char ';'
 comments
 uses = liftM Uses (option [] u)
 where
 u = do
 string "uses"
 comments
-u <- (identifier pas >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments)
+u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
 char ';'
 comments
 return u

changeset 6275	f1b4f37dba22
parent 6272	a93cb9ca9fda
child 6277	627b5752733a