Happy example: attempt to add error handling 3

gistfile1.hs

-- Calc.y
-- Based on http://www.haskell.org/happy/doc/html/sec-using.html

{
module Main (main) where

import Data.Char
}

%name calc
%tokentype { Token }
%error { parseError }

%token 
      let             { TokenLet }
      in              { TokenIn }
      int             { TokenInt $$ }
      var             { TokenVar $$ }
      '='             { TokenEq }
      '+'             { TokenPlus }
      '-'             { TokenMinus }
      '*'             { TokenTimes }
      '/'             { TokenDiv }
      '('             { TokenOB }
      ')'             { TokenCB }

%%

Exp :: { P Int }
      : let var '=' Exp in Exp  { $4 `thenP` \v p -> $6 (($2, v) : p) }
      | Exp1                    { $1 }

Exp1 :: { P Int }
      : Exp1 '+' Term           { $1 `thenP` \v1 -> $3 `thenP` \v2 -> returnP $ v1 + v2 }
      | Exp1 '-' Term           { $1 `thenP` \v1 -> $3 `thenP` \v2 -> returnP $ v1 - v2 }
      | Term                    { $1 }

Term :: { P Int }
      : Term '*' Factor         { $1 `thenP` \v1 -> $3 `thenP` \v2 -> returnP $ v1 * v2 }
      | Term '/' Factor         { $1 `thenP` \v1 -> $3 `thenP` \v2 -> returnP $ v1 `div` v2 }
      | Factor                  { $1 }

Factor :: { P Int }
      : int                     { returnP $1 }
      | var                     { \p -> case lookup $1 p of
                                            Nothing -> failE "no var"
                                            Just i  -> returnE i }
      | '(' Exp ')'             { $2 }

{
type P a = [(String, Int)] -> E a

thenP :: P a -> (a -> P b) -> P b
m `thenP` k = \r ->
    m r `thenE` flip k r

returnP :: a -> P a
returnP = const . returnE

failP :: String -> P a
failP = const . failE

data E a = Ok a | Failed String

thenE :: E a -> (a -> E b) -> E b
m `thenE` k = 
    case m of 
      Ok a -> k a
      Failed e -> Failed e

returnE :: a -> E a
returnE a = Ok a

failE :: String -> E a
failE err = Failed err

parseError :: [Token] -> P a
-- OOPS: Happy expects that parseError has type [Token] -> a
parseError _ = failP "Parse error"

data Token
      = TokenLet
      | TokenIn
      | TokenInt Int
      | TokenVar String
      | TokenEq
      | TokenPlus
      | TokenMinus
      | TokenTimes
      | TokenDiv
      | TokenOB
      | TokenCB
  deriving Show

lexer :: String -> [Token]
lexer [] = []
lexer (c:cs) 
      | isSpace c = lexer cs
      | isAlpha c = lexVar (c:cs)
      | isDigit c = lexNum (c:cs)
lexer ('=':cs) = TokenEq : lexer cs
lexer ('+':cs) = TokenPlus : lexer cs
lexer ('-':cs) = TokenMinus : lexer cs
lexer ('*':cs) = TokenTimes : lexer cs
lexer ('/':cs) = TokenDiv : lexer cs
lexer ('(':cs) = TokenOB : lexer cs
lexer (')':cs) = TokenCB : lexer cs

lexNum cs = TokenInt (read num) : lexer rest
      where (num,rest) = span isDigit cs

lexVar cs =
   case span isAlpha cs of
      ("let", rest) -> TokenLet : lexer rest
      ("in", rest)  -> TokenIn : lexer rest
      (var, rest)   -> TokenVar var : lexer rest

main :: IO ()
main = do
    cs <- getContents
    case calc (lexer cs) [] of
      Ok res -> print res
      Failed err -> putStrLn err
}