Text/ParserCombinators/Parsec/examples/Mondrian/MonParser.hs

   1 -----------------------------------------------------------
   2 -- Daan Leijen (c) 1999-2000, daan@cs.uu.nl
   3 -----------------------------------------------------------
   4 module MonParser ( parseMondrian
   5                  , parseMondrianFromFile
   6                  , prettyFile
   7
   8                  , ParseError
   9                  ) where
  10
  11 import Char
  12 import Monad
  13 import Mondrian
  14 import Utils        (groupLambdas)
  15
  16 -- Parsec
  17 import Text.ParserCombinators.Parsec
  18 import Text.ParserCombinators.Parsec.Expr
  19 import qualified Text.ParserCombinators.Parsec.Token as P
  20 import Text.ParserCombinators.Parsec.Language (mondrianDef)
  21
  22 --testing
  23 import qualified SimpleMondrianPrinter as Pretty
  24
  25
  26
  27
  28 -----------------------------------------------------------
  29 --
  30 -----------------------------------------------------------
  31 parseMondrianFromFile :: String -> IO (Either ParseError CompilationUnit)
  32 parseMondrianFromFile fname =
  33     parseFromFile compilationUnit fname
  34
  35 parseMondrian sourceName source =
  36     parse compilationUnit sourceName source
  37
  38
  39
  40 -- testing
  41 prettyFile fname
  42     = do{ result <- parseMondrianFromFile fname
  43         ; case result of
  44             Left err    -> putStr ("parse error at: " ++ show err)
  45             Right x     -> print (Pretty.compilationUnit x)
  46         }
  47
  48
  49 -----------------------------------------------------------
  50 -- GRAMMAR ELEMENTS
  51 -----------------------------------------------------------
  52 compilationUnit :: Parser CompilationUnit
  53 compilationUnit =
  54     do{ whiteSpace
  55       ; reserved "package"
  56       ; name  <- option [""] packageName
  57       ; decls <- option []   declarations
  58       ; eof
  59       ; return $ Package name decls
  60       }
  61
  62 -----------------------------------------------------------
  63 -- Declarations
  64 -----------------------------------------------------------
  65 declarations =
  66     braces (semiSep1 declaration)
  67
  68 declaration =
  69         importDeclaration
  70     <|> classDeclaration
  71     <|> variableSignatureDeclaration
  72     <?> "declaration"
  73
  74 variableSignatureDeclaration =
  75     do{ name <- variableName
  76       ; variableDeclaration name <|> signatureDeclaration name
  77       }
  78
  79 variableDeclaration name =
  80     do{ symbol "="
  81       ; expr <- expression
  82       ; return $ VarDecl name expr
  83       }
  84     <?> "variable declaration"
  85
  86 importDeclaration =
  87     do{ reserved "import"
  88       ; name <- packageName
  89       ; star <- option [] (do{ symbol "."
  90                              ; symbol "*"
  91                              ; return ["*"]
  92                              })
  93       ; return $ ImportDecl (name ++ star)
  94       }
  95
  96 classDeclaration =
  97     do{ reserved "class"
  98       ; name    <- className
  99       ; extends <- option [] (do{ reserved "extends"
 100                                 ; n <- className
 101                                 ; return [n]
 102                                 })
 103       ; decls   <- option [] declarations
 104       ; return $ ClassDecl name extends decls
 105       }
 106
 107 signatureDeclaration name =
 108     do{ symbol "::"
 109       ; texpr  <- typeExpression
 110       ; return $ SigDecl name texpr
 111       }
 112     <?> "type declaration"
 113
 114
 115 -----------------------------------------------------------
 116 -- Expressions
 117 -----------------------------------------------------------
 118 expression :: Parser Expr
 119 expression =
 120         lambdaExpression
 121     <|> letExpression
 122     <|> newExpression
 123     <|> infixExpression
 124     <?> "expression"
 125
 126 lambdaExpression =
 127     do{ symbol "\\"
 128       ; name <- variableName
 129       ; symbol "->"
 130       ; expr <- expression
 131       ; return $ groupLambdas (Lambda [name] expr)
 132       }
 133
 134 letExpression =
 135     do{ reserved "let"
 136       ; decls <- declarations
 137       ; reserved "in"
 138       ; expr <- expression
 139       ; return $ Let decls expr
 140       }
 141
 142 newExpression =
 143     do{ reserved "new"
 144       ; name  <- className
 145       ; decls <- option [] declarations
 146       ; return $ New name decls
 147       }
 148
 149
 150 -----------------------------------------------------------
 151 -- Infix expression
 152 -----------------------------------------------------------
 153 infixExpression =
 154     buildExpressionParser operators applyExpression
 155
 156 operators =
 157     [ [ prefix "-", prefix "+" ]
 158     , [ op "^"  AssocRight ]
 159     , [ op "*"  AssocLeft, op "/"  AssocLeft ]
 160     , [ op "+"  AssocLeft, op "-"  AssocLeft ]
 161     , [ op "==" AssocNone, op "/=" AssocNone, op "<"  AssocNone
 162       , op "<=" AssocNone, op ">"  AssocNone, op ">=" AssocNone ]
 163     , [ op "&&" AssocNone ]
 164     , [ op "||" AssocNone ]
 165     ]
 166     where
 167       op name assoc   = Infix (do{ var <- try (symbol name)
 168                                   ; return (\x y -> App (App (Var [var]) x) y)
 169                                   }) assoc
 170       prefix name     = Prefix  (do{ var <- try (symbol name)
 171                                   ; return (\x -> App (Var [var,"unary"]) x)
 172                                   })
 173
 174
 175
 176 applyExpression =
 177     do{ exprs <- many1 simpleExpression
 178       ; return (foldl1 App exprs)
 179       }
 180
 181 {-
 182 infixExpression =
 183     do{ (e,es) <- chain simpleExpression operator "infix expression"
 184       ; return $ if null es then e else (unChain (Chain e es))
 185       }
 186 -}
 187
 188 simpleExpression :: Parser Expr
 189 simpleExpression =
 190         literal
 191     <|> parens expression
 192     <|> caseExpression
 193     <|> variable
 194     <?> "simple expression"
 195
 196
 197 -----------------------------------------------------------
 198 -- Case expression
 199 -----------------------------------------------------------
 200 caseExpression =
 201     do{ reserved "case"
 202       ; expr <- variable
 203       ; reserved "of"
 204       ; alts <- alternatives
 205       ; return $ Case expr alts
 206       }
 207
 208 alternatives =
 209     braces (semiSep1 arm)
 210
 211 arm =
 212     do{ pat <- pattern
 213       ; symbol "->"
 214       ; expr <- expression
 215       ; return (pat,expr)
 216       }
 217
 218 pattern =
 219         do{ reserved "default"
 220           ; return Default
 221           }
 222     <|> do{ name  <- patternName
 223           ; decls <- option [] declarations
 224           ; return $ Pattern name decls
 225           }
 226     <?> "pattern"
 227
 228
 229 -----------------------------------------------------------
 230 -- Type expression
 231 -----------------------------------------------------------
 232
 233 {-
 234 typeExpression =
 235     do{ (e,es) <- chain simpleType typeOperator "type expression"
 236       ; return $ if null es then e else Chain e es
 237       }
 238     <?> "type expression"
 239 -}
 240
 241 typeExpression :: Parser Expr
 242 typeExpression =
 243     do{ exprs <- sepBy1 simpleType (symbol "->")
 244       ; return (foldl1 (\x y -> App (App (Var ["->"]) x) y) exprs)
 245       }
 246
 247 simpleType :: Parser Expr
 248 simpleType =
 249         parens typeExpression
 250     <|> variable
 251     <?> "simple type"
 252
 253
 254
 255 -----------------------------------------------------------
 256 -- LEXICAL ELEMENTS
 257 -----------------------------------------------------------
 258
 259
 260 -----------------------------------------------------------
 261 -- Identifiers & Reserved words
 262 -----------------------------------------------------------
 263 variable =
 264     do{ name <- variableName
 265       ; return $ Var name
 266       }
 267
 268 patternName   = qualifiedName <?> "pattern variable"
 269 variableName  = qualifiedName <?> "identifier"
 270 className     = qualifiedName <?> "class name"
 271 packageName   = qualifiedName <?> "package name"
 272
 273 qualifiedName =
 274     identifier `sepBy1` (symbol "." <?> "")
 275
 276
 277 -----------------------------------------------------------
 278 -- Literals
 279 -----------------------------------------------------------
 280 literal =
 281     do{ v <- intLiteral <|> chrLiteral <|> strLiteral
 282       ; return $ Lit v
 283       }
 284     <?> "literal"
 285
 286 intLiteral  = do{ n <- natural; return (IntLit n) }
 287 chrLiteral  = do{ c <- charLiteral; return (CharLit c) }
 288 strLiteral  = do{ s <- stringLiteral; return (StringLit s) }
 289
 290
 291
 292 -----------------------------------------------------------
 293 -- Tokens
 294 -- Use qualified import to have token parsers on toplevel
 295 -----------------------------------------------------------
 296 mondrian        = P.makeTokenParser mondrianDef
 297
 298 parens          = P.parens mondrian
 299 braces          = P.braces mondrian
 300 semiSep1        = P.semiSep1 mondrian
 301 whiteSpace      = P.whiteSpace mondrian
 302 symbol          = P.symbol mondrian
 303 identifier      = P.identifier mondrian
 304 reserved        = P.reserved mondrian
 305 natural         = P.natural mondrian
 306 charLiteral     = P.charLiteral mondrian
 307 stringLiteral   = P.stringLiteral mondrian