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