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
72
73
74
75
76
77
78
79
80
81
82
83
84
|
{
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
-- For ancient GHC 7.0.4
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
import Data.Char
import Control.Monad (when)
import System.Exit
import System.Environment (getProgName)
import Data.List (isPrefixOf)
}
%name parseFoo
%tokentype { Token }
%errorhandlertype explist
%error { handleErrorExpList }
%monad { ParseM } { (>>=) } { return }
%token
'S' { TokenSucc }
'Z' { TokenZero }
'T' { TokenTest }
%%
Exp : 'Z' { 0 }
| 'T' 'Z' Exp { $3 + 1 }
| 'S' Exp { $2 + 1 }
{
type ParseM a = Either ParseError a
data ParseError
= ParseError (Maybe (Token, [String]))
| StringError String
deriving (Eq,Show)
instance Error ParseError where
strMsg = StringError
data Token
= TokenSucc
| TokenZero
| TokenTest
deriving (Eq,Show)
handleErrorExpList :: ([Token], [String]) -> ParseM a
handleErrorExpList ([], _) = throwError $ ParseError Nothing
handleErrorExpList (ts, explist) = throwError $ ParseError $ Just $ (head ts, explist)
lexer :: String -> [Token]
lexer [] = []
lexer (c:cs)
| isSpace c = lexer cs
| c == 'S' = TokenSucc:(lexer cs)
| c == 'Z' = TokenZero:(lexer cs)
| c == 'T' = TokenTest:(lexer cs)
| otherwise = error "lexer error"
main :: IO ()
main = do
test "Z Z" $ Left (ParseError (Just (TokenZero,[])))
test "T S" $ Left (ParseError (Just (TokenSucc,["'Z'"])))
where
test inp exp = do
putStrLn $ "testing " ++ inp
let tokens = lexer inp
when (parseFoo tokens /= exp) $ 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
}
|
