1 {
2 {-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}
3 module Main where
4 
5 import Control.Monad (when)
6 import Data.Char
7 import System.Exit
8 }
9 
10 %name parseFoo
11 %tokentype { Token }
12 %error { handleError }
13 
14 %monad { ParseM } { (>>=) } { return }
15 
16 %token
17         'S'             { TokenSucc }
18         'Z'             { TokenZero }
19 
20 %%
21 
22 Exp         :       'Z'         { 0 }
23             |       'S' Exp     { $2 + 1 }
24 
25 {
26 
27 type ParseM a = Either ParseError a
28 data ParseError
29         = ParseError (Maybe Token)
30         | StringError String
31     deriving (Eq,Show)
32 instance Error ParseError where
33     strMsg = StringError
34 
35 data Token
36         = TokenSucc
37         | TokenZero
38     deriving (Eq,Show)
39 
40 handleError :: [Token] -> ParseM a
41 handleError [] = throwError $ ParseError Nothing
42 handleError ts = throwError $ ParseError $ Just $ head ts
43 
44 lexer :: String -> [Token]
45 lexer [] = []
46 lexer (c:cs)
47     | isSpace c = lexer cs
48     | c == 'S'  = TokenSucc:(lexer cs)
49     | c == 'Z'  = TokenZero:(lexer cs)
50     | otherwise = error "lexer error"
51 
52 main :: IO ()
53 main = do
54     let tokens = lexer "S S"
55     when (parseFoo tokens /= Left (ParseError Nothing)) $ do
56         print (parseFoo tokens)
57         exitWith (ExitFailure 1)
58 
59 ---
60 class Error a where
61     noMsg :: a
62     noMsg = strMsg ""
63     strMsg :: String -> a
64 class Monad m => MonadError e m | m -> e where
65     throwError :: e -> m a
66 instance MonadError e (Either e) where
67     throwError = Left
68 }
69