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