1 module Parser (parse) where 2 3 import Data.Char(isLower, isDigit, isSpace) 4 import Syntax 5 import Value 6 7 -------------------------- 8 -- Part 1: generic parsing 9 10 type Parser a = String -> [(a,String)] 11 12 succeed :: a -> Parser a 13 succeed v inp = [(v,inp)] 14 15 satisfy :: (Char -> Bool) -> Parser Char 16 satisfy p [] = [] 17 satisfy p (x:xs) = if p x then [(x,xs)] else [] 18 19 lit :: Char -> Parser Char 20 lit x = satisfy (==x) 21 22 infixl 9 ..., *.., ..* 23 infix 8 `using` 24 infixr 7 ||| 25 26 (|||) :: Parser a -> Parser a -> Parser a 27 (|||) p1 p2 inp = p1 inp ++ p2 inp 28 29 (...) :: Parser a -> Parser b -> Parser (a,b) 30 (...) p1 p2 inp = concatMap f1 (p1 inp) 31 where 32 f1 (v1,inp1) = map f2 (p2 inp1) 33 where 34 f2 (v2,inp2) = ((v1,v2),inp2) 35 36 (..*) :: Parser a -> Parser b -> Parser a 37 p1 ..* p2 = (p1 ... p2) `using` fst 38 39 (*..) :: Parser a -> Parser b -> Parser b 40 p1 *.. p2 = (p1 ... p2) `using` snd 41 42 infix `opt` 43 44 opt :: Parser a -> a -> Parser a 45 opt p v inp = [head ((p ||| succeed v) inp)] 46 47 using :: Parser a -> (a->b) -> Parser b 48 using p f inp = map (\(v,out) -> (f v,out)) (p inp) 49 50 many, some :: Parser a -> Parser [a] 51 many p = ((p ... many p) `using` cons) `opt` [] 52 some p = (p ... many p) `using` cons 53 54 cons :: (a,[a]) -> [a] 55 cons (x,xs) = x:xs 56 57 the :: [(a,String)] -> a 58 the ((x,""):_) = x 59 the (_:rest) = the rest 60 the _ = error "Parser.hs: the: Parse error" 61 ------------------------- 62 -- Part 2: parser for Imp 63 64 command ::Parser Command 65 command = nonSeqCommand ... 66 many (lit ';' *.. white *.. nonSeqCommand) 67 `using` foldr1 (:->) . cons 68 69 nonSeqCommand :: Parser Command 70 nonSeqCommand = 71 key "skip" `using` const Skip ||| 72 key "print" *.. expr `using` Print ||| 73 key "if" *.. expr ..* 74 key "then" ... command ..* 75 key "else" ... command ..* 76 key "fi" `using` uncurry (uncurry If) ||| 77 key "while" *.. expr ..* 78 key "do" ... command ..* 79 key "od" `using` uncurry While ||| 80 name ..* key ":=" ... expr `using` uncurry (:=) 81 82 key :: String -> Parser () 83 key k = foldr1 (*..) (map lit k) *.. white *.. succeed () 84 85 expr :: Parser Expr 86 expr = nonBinExpr ... 87 many (op2 ... nonBinExpr) 88 `using` uncurry duoChain 89 90 duoChain :: Expr -> [(Op2,Expr)] -> Expr 91 duoChain e [] = e 92 duoChain e ((o,e'):oes) = Duo o e (duoChain e' oes) 93 94 nonBinExpr :: Parser Expr 95 nonBinExpr = 96 name `using` Var ||| 97 value `using` Val ||| 98 op1 ... expr `using` uncurry Uno ||| 99 key "(" *.. expr ..* key ")" 100 101 op1 :: Parser Op1 102 op1 = key "!" *.. succeed Not ||| 103 key "-" *.. succeed Minus 104 105 -- Too simplistic - does not handle precedence levels 106 op2 :: Parser Op2 107 op2 = key "&" *.. succeed And ||| 108 key "|" *.. succeed Or ||| 109 key "+" *.. succeed Add ||| 110 key "-" *.. succeed Sub ||| 111 key "*" *.. succeed Mul ||| 112 key "/" *.. succeed Div ||| 113 key "%" *.. succeed Mod ||| 114 key "<" *.. succeed Less ||| 115 key "<=" *.. succeed LessEq ||| 116 key "=" *.. succeed Eq 117 118 name :: Parser Name 119 name = some (satisfy isLower) ..* white 120 121 value :: Parser Value 122 value = key "T" *.. succeed (Bol True) ||| 123 key "F" *.. succeed (Bol False) ||| 124 key "Wrong" *.. succeed (Wrong) ||| 125 some(satisfy isDigit) ..* white `using` Num . read 126 127 white :: Parser String 128 white = many (satisfy isSpace) 129 130 parse :: String -> Command 131 parse s = the (command s) 132