1 module Parser (parse) where
    2 
    3 import 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 op2 :: Parser Op2
  106 op2 = key "&"  *.. succeed And    |||
  107       key "|"  *.. succeed Or     |||
  108       key "+"  *.. succeed Add    |||
  109       key "-"  *.. succeed Sub    |||
  110       key "*"  *.. succeed Mul    |||
  111       key "/"  *.. succeed Div    |||
  112       key "\\" *.. succeed Mod    |||
  113       key "<"  *.. succeed Less   |||
  114       key "<=" *.. succeed LessEq |||
  115       key "="  *.. succeed Eq
  116 
  117 name :: Parser Name
  118 name = some (satisfy isLower) ..* white
  119 
  120 value :: Parser Value
  121 value = key "T" *.. succeed (Bol True)  |||
  122         key "F" *.. succeed (Bol False) |||
  123         some(satisfy isDigit) ..* white `using` Num . read
  124 
  125 white :: Parser String
  126 white = many (satisfy isSpace)
  127 
  128 parse :: String -> Command
  129 parse s = the (command s)
  130