Handwritten packrat parser for trivial integer arithmetic expressions.

gistfile1.hs

{-
    Handwritten packrat parser for trivial integer arithmetic expressions. Guarantees O(n) time/space complexity.
    Rule: Exp <- IntVal / (Exp) / (+ Exp Exp) / (- Exp Exp) / (* Exp Exp)
    Examples: " 233 ", "( + 42 ((233) ) )", "( (* 42 (+ 1 233)) )".
    Properly handles whitespaces. "2 33" will not be recognized as 233.
-}

import Data.Char

data Node = Nil | Node {next::Node,char::Char,skipped::Node,result::Result}
data Result = Fail | Result {expr::Exp,remain::Node}
data Exp = Val String | Add Exp Exp | Sub Exp Exp | Mul Exp Exp

skip :: Node -> Node
skip Nil = Nil
skip node = skipped node

parse :: String -> Node
parse [] = Nil
parse (c:s) =
    let thisnode = Node {next=nextnode,char=c,skipped=skippednode,result=thisresult}
        nextnode = parse s
        skippednode
            | elem c " \t\n" =
                case nextnode of
                    Nil -> Nil
                    _ -> skipped nextnode
            | otherwise = thisnode
        thisresult
            | isDigit c =
                case nextnode of
                    Node {result=Result {expr=Val nexts}} -> Result {expr=Val (c:nexts),remain=remain (result nextnode)}
                    _ -> Result {expr=Val [c],remain=nextnode}
            | c=='(' =
                let expnode = skip nextnode in
                    case expnode of
                        Node {result=Result {}} ->
                            case skip (remain (result expnode)) of
                                lastnode@Node {char=')'} -> Result {expr=expr (result expnode),remain=next lastnode}
                                _ -> Fail
                        Node {char='+'} ->
                            case (skip (next expnode)) of
                                exp0node@Node {result=Result {}} ->
                                    case skip (remain (result exp0node)) of
                                        exp1node@Node {result=Result {}} ->
                                            case skip (remain (result exp1node)) of
                                                lastnode@Node {char=')'} -> Result {expr=Add (expr (result exp0node)) (expr (result exp1node)),remain=next lastnode}
                                                _ -> Fail
                                        _ -> Fail
                                _ -> Fail
                        Node {char='-'} ->
                            case (skip (next expnode)) of
                                exp0node@Node {result=Result {}} ->
                                    case skip (remain (result exp0node)) of
                                        exp1node@Node {result=Result {}} ->
                                            case skip (remain (result exp1node)) of
                                                lastnode@Node {char=')'} -> Result {expr=Sub (expr (result exp0node)) (expr (result exp1node)),remain=next lastnode}
                                                _ -> Fail
                                        _ -> Fail
                                _ -> Fail
                        Node {char='*'} ->
                            case (skip (next expnode)) of
                                exp0node@Node {result=Result {}} ->
                                    case skip (remain (result exp0node)) of
                                        exp1node@Node {result=Result {}} ->
                                            case skip (remain (result exp1node)) of
                                                lastnode@Node {char=')'} -> Result {expr=Mul (expr (result exp0node)) (expr (result exp1node)),remain=next lastnode}
                                                _ -> Fail
                                        _ -> Fail
                                _ -> Fail
                        _ -> Fail
            | otherwise = Fail
    in thisnode

evalExp :: Exp -> Integer
evalExp (Val s) = read s::Integer
evalExp (Add e0 e1) = (evalExp e0) + (evalExp e1)
evalExp (Sub e0 e1) = (evalExp e0) - (evalExp e1)
evalExp (Mul e0 e1) = (evalExp e0) * (evalExp e1)

evalString :: String -> Integer
evalString = evalExp . (expr . (result . (skip . parse)))