Text/ParserCombinators/Parsec/examples/while/While.hs

   1 -------------------------------------------------------------
   2 -- Parser for WHILE from Nielson, Nielson and Hankin
   3 -- and various other sources.
   4 -------------------------------------------------------------
   5
   6 module While( prettyWhileFromFile ) where
   7
   8 import WhileAS
   9 import Text.ParserCombinators.Parsec
  10 import Text.ParserCombinators.Parsec.Expr
  11 import qualified Text.ParserCombinators.Parsec.Token as P
  12 import Text.ParserCombinators.Parsec.Language( javaStyle )
  13
  14
  15 prettyWhileFromFile fname
  16   = do{ input <- readFile fname
  17       ; putStr input
  18       ; case parse program fname input of
  19            Left err -> do{ putStr "parse error at "
  20                            ; print err
  21                            }
  22            Right x  -> print x
  23       }
  24
  25 --renum :: Prog -> Prog
  26 --renum p = rn (1,p)
  27 --rn :: (Int, Stat) -> (Int, Stat)
  28 --rn (x,s) = case s of
  29 --            Assign vi ae _  -> (x+1,Assign vi ae x)
  30 --            Skip _          -> (x+1, Skip x)
  31 --            Seq [Stat]      ->
  32 --            If be _ s1 s2   -> do{ (newx, newthen) <- rn (x+1,s1)
  33 --                                 ; (newerx, newelse) <- rn (newx,s2)
  34 --                                 ; return (newerx, If be x newthen newelse)
  35 --                                 }
  36 --            While be _ s    -> do{ (newx, news) <- rn (x+1,s)
  37 --                                 ; return (newx, While be x+1 news)
  38 --                                 }
  39
  40 -----------------------------------------------------------
  41 -- A program is simply an expression.
  42 -----------------------------------------------------------
  43 program
  44     = do{ stats <- semiSep1 stat
  45         ; return (if length stats < 2 then head stats else Seq stats)
  46         }
  47
  48 stat :: Parser Stat
  49 stat = choice
  50        [ do { reserved "skip";
  51               return (Skip 0)
  52             }
  53        , ifStat
  54        , whileStat
  55        , sequenceStat
  56        , try assignStat
  57        ]
  58
  59
  60 assignStat :: Parser Stat
  61 assignStat = do{ id <- identifier
  62                ; symbol ":="
  63                ; s <- aritExpr
  64                ; return (Assign id s 0)
  65                }
  66
  67 ifStat :: Parser Stat
  68 ifStat = do{ reserved "if"
  69              ; cond <- boolExpr
  70              ; reserved "then"
  71              ; thenpart <- stat
  72              ; reserved "else"
  73              ; elsepart <- stat
  74              ; return (If cond 0 thenpart elsepart)
  75              }
  76
  77 whileStat :: Parser Stat
  78 whileStat = do{ reserved "while"
  79               ; cond <- boolExpr
  80               ; reserved "do"
  81               ; body <- stat
  82               ; return (While cond 0 body)
  83               }
  84
  85 sequenceStat :: Parser Stat
  86 sequenceStat = do{ stats <- parens (semiSep1 stat)
  87                  ; return (if length stats < 2 then head stats else Seq stats)
  88                  }
  89
  90 boolExpr:: Parser BExp
  91 boolExpr = buildExpressionParser boolOperators relExpr
  92
  93 relExpr :: Parser BExp
  94 relExpr = do{ arg1 <- aritExpr
  95             ; op <- choice [string "=", try (string "<>"), try (string "<="), string "<", try (string ">="), string ">"]
  96             ; arg2 <- aritExpr
  97             ; return (RelOp op arg1 arg2)
  98             }
  99
 100 aritExpr :: Parser AExp
 101 aritExpr = buildExpressionParser aritOperators simpleArit
 102
 103 -- Everything mapping bools to bools
 104 boolOperators =
 105     [ [ prefix "not"]
 106     , [ opbb "and" AssocRight ] -- right for shortcircuit
 107     , [ opbb "or" AssocRight ] -- right for shortcircuit
 108     ]
 109     where
 110       opbb name assoc   = Infix (do{ reservedOp name
 111                                    ; return (\x y -> BOp name x y)
 112                                    }) assoc
 113       prefix name       = Prefix  (do{ reservedOp name
 114                                   ; return (\x -> BUnOp name x)
 115                                   })
 116
 117 -- Everything mapping pairs of ints to ints
 118 aritOperators =
 119     [ [ op "*"  AssocLeft, op "/"  AssocLeft ]
 120     , [ op "+"  AssocLeft, op "-"  AssocLeft ]
 121     , [ op "&" AssocRight ] -- bitwise and delivering an int
 122     , [ op "|" AssocRight ] -- bitwise or delivering an int
 123     ]
 124     where
 125       op name assoc   = Infix (do{ reservedOp name
 126                                   ; return (\x y -> AOp name x y)
 127                                   }) assoc
 128
 129
 130 simpleArit = choice [ intLiteral
 131                     , parens aritExpr
 132                     , variable
 133                     ]
 134
 135 simpleBool = choice [ boolLiteral
 136                     , parens boolExpr
 137                     ]
 138
 139 boolLiteral = do{ reserved "false"
 140                ; return (BoolLit True)
 141                }
 142              <|>
 143              do{ reserved "true"
 144                ; return (BoolLit False)
 145                }
 146
 147 intLiteral = do{ i <- integer; return (IntLit i) }
 148 variable = do{ id <- identifier
 149              ; return (Var id)
 150              }
 151
 152
 153 -----------------------------------------------------------
 154 -- The lexer
 155 -----------------------------------------------------------
 156 lexer     = P.makeTokenParser whileDef
 157
 158 whileDef  = javaStyle
 159           { -- Kept the Java single line comments, but officially the language has no comments
 160             P.reservedNames  = [ "true", "false", "do", "else", "not",
 161                                "if", "then", "while", "skip"
 162                                -- , "begin", "proc", "is", "end", "val", "res", "malloc"
 163                               ]
 164           , P.reservedOpNames= [ "and", "or", "not", "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"]
 165           , P.opLetter       = oneOf (concat (P.reservedOpNames whileDef))
 166           , P.caseSensitive  = False
 167           }
 168
 169 parens          = P.parens lexer
 170 braces          = P.braces lexer
 171 semiSep1        = P.semiSep1 lexer
 172 whiteSpace      = P.whiteSpace lexer
 173 symbol          = P.symbol lexer
 174 identifier      = P.identifier lexer
 175 reserved        = P.reserved lexer
 176 reservedOp      = P.reservedOp lexer
 177 integer         = P.integer lexer
 178 charLiteral     = P.charLiteral lexer
 179 stringLiteral   = P.stringLiteral lexer