Text/ParserCombinators/Parsec/examples/tiger/Tiger.hs

   1 -------------------------------------------------------------
   2 -- Parser for Tiger from Appel's book on compilers.
   3 -- Semantic checks have been omitted for now.
   4 -- Scope rules and such are as a consequence not implemented.
   5 -------------------------------------------------------------
   6
   7 module Tiger( prettyTigerFromFile ) where
   8
   9 import TigerAS
  10 import Text.ParserCombinators.Parsec
  11 import Text.ParserCombinators.Parsec.Expr
  12 import qualified Text.ParserCombinators.Parsec.Token as P
  13 import Text.ParserCombinators.Parsec.Language( javaStyle )
  14
  15
  16 prettyTigerFromFile fname
  17   = do{ input <- readFile fname
  18       ; putStr input
  19       ; case parse program fname input of
  20            Left err -> do{ putStr "parse error at "
  21                            ; print err
  22                            }
  23            Right x  -> print x
  24       }
  25
  26 {-
  27 main = do putStr "Parsec Tiger parser\n"
  28           putStr "Type filename (without suffix): "
  29           basename <- getLine
  30           tokens <- scanner False keywordstxt
  31                                   keywordsops
  32                                   specialchars
  33                                   opchars
  34                                   (basename ++ ".sl")
  35                                   Nothing
  36           let ((exprpp,proof), errors) = parse pRoot tokens
  37           putStr (if null errors then "" else "Errors:\n" ++ errors)
  38           putStr ("Result:\n" ++ (disp exprpp 140 ""))
  39           writeFile (basename ++ ".tex") (disp proof 500 "")
  40           putStr ("\nGenerated proof in file " ++ (basename ++ ".tex"))
  41 -}
  42
  43 -----------------------------------------------------------
  44 -- A program is simply an expression.
  45 -----------------------------------------------------------
  46 program
  47     = do{ whiteSpace
  48         ; e <- expr
  49         ; return e
  50         }
  51
  52 ----------------------------------------------------------------
  53 -- Declarations for types, identifiers and functions
  54 ----------------------------------------------------------------
  55 decs
  56     = many dec
  57
  58 dec
  59     = tydec
  60     <|>
  61       vardec
  62     <|>
  63       fundec
  64
  65 ----------------------------------------------------------------
  66 -- Type declarations
  67 -- int and string are predefined, but not reserved.
  68 ----------------------------------------------------------------
  69 tydec :: Parser Declaration
  70 tydec
  71     = do{ reserved "type"
  72             ; tid  <- identifier
  73             ; symbol "="
  74             ; t <- ty
  75             ; return (TypeDec tid t)
  76             }
  77
  78 ty
  79     = do{ fields <- braces tyfields
  80         ; return (Record fields)
  81         }
  82     <|>
  83       do{ reserved "array"
  84         ; reserved "of"
  85         ; tid <- identifier
  86         ; return (Array tid)
  87         }
  88     <|>
  89       do{ id <- identifier
  90         ; return (Var id)
  91         }
  92
  93 tyfields
  94     = commaSep field
  95
  96 noType = "*"
  97 voidType = "void"
  98
  99 field
 100     = do{ id <- identifier
 101         ; symbol ":"
 102         ; tid <- identifier
 103         ; return (TypedVar id tid)
 104         }
 105
 106 ----------------------------------------------------------------
 107 -- identifier declarations
 108 -- Lacks: 11, 12
 109 ----------------------------------------------------------------
 110 vardec
 111     = do{ reserved "var"
 112         ; id <- identifier
 113         ; t <- option noType (try (do{ symbol ":"
 114                                ; identifier
 115                                }))
 116         ; symbol ":="
 117         ; e <- expr
 118         ; return (VarDec id t e)
 119         }
 120
 121 ----------------------------------------------------------------
 122 -- Function declarations
 123 ----------------------------------------------------------------
 124 fundec
 125     = do{ reserved "function"
 126         ; name <- identifier
 127         ; parms <- parens tyfields
 128         ; rettype <- option voidType (do{ symbol ":"
 129                                         ; identifier
 130                                         })
 131         ; symbol "="
 132         ; body <- expr
 133         ; return (FunDec name parms rettype body)
 134         }
 135
 136 ----------------------------------------------------------------
 137 -- Lvalues
 138 -- This may not be what we want. I parse lvalues as
 139 -- a list of dot separated array indexings (where the indexing)
 140 -- may be absent. Possibly, we'd want the . and []
 141 ----------------------------------------------------------------
 142
 143 -- This combinator does ab* in a leftassociative way.
 144 -- Applicable when you have a cfg rule with left recursion
 145 -- which you might rewrite into EBNF X -> YZ*.
 146 lfact :: Parser a -> Parser (a -> a) -> Parser a
 147 lfact p q = do{ a <- p
 148               ; fs <- many q
 149               ; return (foldl  (\x f -> f x) a fs)
 150               }
 151 {-
 152 chainl op expr = lfact expr (do { o <- op
 153                                 ; e <- expr
 154                                 ; return (`o` e)
 155                                 })
 156   -}
 157 lvalue = lfact variable (recordref <|> subscripted)
 158
 159 recordref = do{ symbol "."
 160               ; id <- variable
 161               ; return (\x -> Dot x id)
 162               }
 163 subscripted = do{ indexexpr <- brackets expr
 164                 ; return (\x -> Sub x indexexpr)
 165                 }
 166
 167 {-  Alternatively (an lvalue is then a sequence of, possibly (mutli-)indexed, identifiers separated by dots)
 168 lvalue :: Parser Expr
 169 lvalue = do{ flds <- sepBy1 subscripted (symbol ".")
 170            ; return (if length flds < 2 then head flds else Dots flds)
 171            }
 172 subscripted :: Parser Expr
 173 subscripted = do{ id <- identifier
 174                 ; indexes <- many (brackets expr)
 175                 ; return (if null indexes then Ident id
 176                                           else Subscripted id indexes)
 177                 }
 178 -}
 179
 180 ----------------------------------------------------------------
 181 -- All types of expression(s)
 182 ----------------------------------------------------------------
 183
 184 exprs = many expr
 185
 186 expr :: Parser Expr
 187 expr = choice
 188        [ do{ reserved "break"
 189            ; return Break
 190            }
 191        , ifExpr
 192        , whileExpr
 193        , forExpr
 194        , letExpr
 195        , sequenceExpr
 196        , infixExpr
 197 --       , sequenceExpr   -- I am not sure about this one.
 198        ]
 199
 200 recordExpr :: Parser Expr
 201 recordExpr = do{ tid <- identifier
 202                ; symbol "{"
 203                ; fields <- commaSep1 fieldAssign
 204                ; symbol "}"
 205                ; return (RecordVal tid fields)
 206                }
 207
 208 fieldAssign :: Parser AssignField
 209 fieldAssign = do{ id <- identifier
 210                 ; symbol "="
 211                 ; e <- expr
 212                 ; return (AssignField id e)
 213                 }
 214
 215 arrayExpr :: Parser Expr
 216 arrayExpr = do{ tid <- identifier
 217               ; size <- brackets expr
 218               ; reserved "of"
 219               ; initvalue <- expr
 220               ; return (ArrayVal tid size initvalue)
 221               }
 222
 223 assignExpr :: Parser Expr
 224 assignExpr = do{ lv <- lvalue
 225                ; symbol ":="
 226                ; e <- expr
 227                ; return (Assign lv e)
 228                }
 229
 230 ifExpr :: Parser Expr
 231 ifExpr = do{ reserved "if"
 232              ; cond <- expr
 233              ; reserved "then"
 234              ; thenpart <- expr
 235              ; elsepart <- option Skip (do{ reserved "else"; expr})
 236              ; return (If cond thenpart elsepart)
 237              }
 238
 239 whileExpr :: Parser Expr
 240 whileExpr = do{ reserved "while"
 241               ; cond <- expr
 242               ; reserved "do"
 243               ; body <- expr
 244               ; return (While cond body)
 245               }
 246
 247 forExpr :: Parser Expr
 248 forExpr = do{ reserved "for"
 249             ; id <- identifier
 250             ; symbol ":="
 251             ; lowerbound <- expr
 252             ; reserved "to"
 253             ; upperbound <- expr
 254             ; reserved "do"
 255             ; body <- expr
 256             ; return (For id lowerbound upperbound body)
 257             }
 258
 259 letExpr :: Parser Expr
 260 letExpr = do{ reserved "let"
 261             ; ds <- decs
 262             ; reserved "in"
 263             ; es <- semiSep expr
 264             ; reserved "end"
 265             ; return (Let ds es)
 266             }
 267
 268 sequenceExpr :: Parser Expr
 269 sequenceExpr = do{ exps <- parens (semiSep1 expr)
 270                  ; return (if length exps < 2 then head exps else Seq exps)
 271                  }
 272
 273 infixExpr :: Parser Expr
 274 infixExpr = buildExpressionParser operators simpleExpr
 275
 276 operators =
 277     [ [ prefix "-"]
 278     , [ op "*"  AssocLeft, op "/"  AssocLeft ]
 279     , [ op "+"  AssocLeft, op "-"  AssocLeft ]
 280     , [ op "=" AssocNone, op "<>" AssocNone, op "<="  AssocNone
 281       , op "<" AssocNone, op ">="  AssocNone, op ">" AssocNone ]
 282     , [ op "&" AssocRight ] -- Right for shortcircuiting
 283     , [ op "|" AssocRight ] -- Right for shortcircuiting
 284     , [ op ":=" AssocRight ]
 285     ]
 286     where
 287       op name assoc   = Infix (do{ reservedOp name
 288                                   ; return (\x y -> Op name x y)
 289                                   }) assoc
 290       prefix name     = Prefix  (do{ reservedOp name
 291                                   ; return (\x -> UnOp name x)
 292                                   })
 293
 294 simpleExpr = choice [ do{ reserved "nil"
 295                         ; return Nil
 296                         }
 297                     , intLiteral
 298                     , strLiteral
 299                     , parens expr
 300                     , try funCallExpr
 301                     , try recordExpr
 302                     , try arrayExpr
 303                     , lvalue
 304                     ]
 305
 306 funCallExpr = do{ id <- identifier
 307                  ; parms <- parens (commaSep expr)
 308                  ; return (Apply id parms)
 309                  }
 310
 311 intLiteral = do{ i <- integer; return (IntLit i) }
 312 strLiteral = do{ s <- stringLiteral; return (StringLit s) }
 313 variable = do{ id <- identifier
 314              ; return (Ident id)
 315              }
 316
 317
 318 -----------------------------------------------------------
 319 -- The lexer
 320 -----------------------------------------------------------
 321 lexer     = P.makeTokenParser tigerDef
 322
 323 tigerDef  = javaStyle
 324           { -- Kept the Java single line comments, but officially the language has no comments
 325             P.reservedNames  = [ "array", "break", "do", "else", "end", "for", "function",
 326                                  "if", "in", "let",
 327                                  "nil", "of", "then", "to", "type", "var", "while" ]
 328           , P.reservedOpNames= [ "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"]
 329           , P.opLetter       = oneOf (concat (P.reservedOpNames tigerDef))
 330           , P.caseSensitive  = True
 331           }
 332
 333 parens          = P.parens lexer
 334 braces          = P.braces lexer
 335 semiSep         = P.semiSep lexer
 336 semiSep1        = P.semiSep1 lexer
 337 commaSep        = P.commaSep lexer
 338 commaSep1       = P.commaSep1 lexer
 339 brackets        = P.brackets lexer
 340 whiteSpace      = P.whiteSpace lexer
 341 symbol          = P.symbol lexer
 342 identifier      = P.identifier lexer
 343 reserved        = P.reserved lexer
 344 reservedOp      = P.reservedOp lexer
 345 integer         = P.integer lexer
 346 charLiteral     = P.charLiteral lexer
 347 stringLiteral   = P.stringLiteral lexer