parser for binop expressions

myparser2.hs

import Data.Char
import Data.Functor
import Data.List
------------------------------------------------------------
import Control.Monad
import Control.Applicative
import Data.List

newtype Parser a = Parser { parse :: String -> [(a, String)]} 

instance Functor Parser where
  fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s])

bind :: Parser a -> (a -> Parser b) -> Parser b
bind (Parser pa) pb = Parser (\s-> concat [parse (pb a) s' | (a, s') <- pa s])

unit :: a -> Parser a
unit a = Parser (\s->[(a,s)])

instance Monad Parser where
  return = unit
  (>>=)  = bind

parserApply ::  Parser (a -> b) -> Parser a -> Parser b
parserApply (Parser pf) (Parser pa) = Parser g
  where g s = [(f a, s'') | (f, s') <- pf s, (a, s'') <- pa s']

instance Applicative Parser where
  pure = return
  (<*>) = parserApply

combine :: Parser a -> Parser a -> Parser a
combine (Parser p) (Parser q) = Parser (\s -> p s ++ q s)

failure :: Parser a
failure = Parser (\cs -> [])

instance MonadPlus Parser where
  mzero = failure
  mplus = combine

option :: Parser a -> Parser a -> Parser a
option  (Parser p) (Parser q) = Parser $ \s ->
  case p s of [] -> q s ; x -> x 


instance Alternative Parser where
  empty = failure
  (<|>) = option

------------------------------------------------------------

oneChar :: Parser Char
oneChar = Parser f
  where f "" = []
        f (c:s) = [(c, s)]

satis :: (a->Bool) -> Parser a -> Parser a
satis test pa = do
  a <- pa
  if test a then return a else failure


assert :: Bool -> Parser Bool
assert True = unit True
assert False = failure

matchingChars = some . flip satis oneChar
digits = matchingChars isDigit
alpha  = matchingChars isAlpha

string :: String -> Parser String
string "" = return ""
string (c:s) = do
  a <- satis (==c) oneChar
  t <- string s
  return (a:t)

op = string "+" <|> string "-" <|> string "*" <|> string "/" <|> string "^"

space =  (many $ string " ") <&> concat

data Expr = Num Integer | Var String | Add Expr Expr | Sub Expr Expr |
            Mul Expr Expr | Div Expr Expr | Pow Expr Expr
          deriving (Show, Eq)

var = alpha <&> Var
num = digits <&> read <&> Num
parens e = do { string "("; x <- e; string ")"; return x }
             
atom = var <|> num <|> parens expr

expr = do {space; a <- atom; binExpr 1 a}

level "+" = 1
level "-" = 1
level "*" = 2
level "/" = 2
level "^" = 3

node "+" = Add
node "-" = Sub
node "*" = Mul
node "/" = Div
node "^" = Pow

lassoc "^" = 0
lassoc _   = 1

binEx :: Integer -> Parser Expr
binEx lev = do {space; a <- atom; e <- binExpr lev a; space; return e }

binExpr :: Integer -> Expr -> Parser Expr
binExpr minLevel a = do
  space;
  o <- op
  assert (level o >= minLevel)
  space;
  b <- binEx (level o + lassoc o)
  binExpr minLevel (node o a b)
 <|>
  return a


main = do
  print $ parse expr  "1 *  x + (a+e) ^4 ^5 * 6  "