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
85
86
87
88
89
90
91
92
93
94
95
96
97
|
-- Testing %monad without %lexer, using the IO monad.
{
module Main where
import System.IO
import Data.Char
}
%name calc
%tokentype { Token }
%token num { TokenNum $$ }
'+' { TokenPlus }
'-' { TokenMinus }
'*' { TokenTimes }
'/' { TokenDiv }
'^' { TokenExp }
'\n' { TokenEOL }
'(' { TokenOB }
')' { TokenCB }
%left '-' '+'
%left '*'
%nonassoc '/'
%left NEG -- negation--unary minus
%right '^' -- exponentiation
%monad { (MonadIO m) } { m } { (>>=) } { return }
%%
input : {- empty string -} { () }
| input line { $1 }
line : '\n' { () }
| exp '\n' {% hPutStr stdout (show $1) }
exp : num { $1 }
| exp '+' exp { $1 + $3 }
| exp '-' exp { $1 - $3 }
| exp '*' exp { $1 * $3 }
| exp '/' exp { $1 / $3 }
| '-' exp %prec NEG { -$2 }
-- | exp '^' exp { $1 ^ $3 }
| '(' exp ')' { $2 }
{
main = do
calc (lexer "1 + 2 * 3 / 4\n")
{-
-- check that non-associative operators can't be used together
r <- try (calc (lexer "1 / 2 / 3"))
case r of
Left e -> return ()
Right _ -> ioError (userError "fail!")
-}
data Token
= TokenExp
| TokenEOL
| TokenNum Double
| TokenPlus
| TokenMinus
| TokenTimes
| TokenDiv
| TokenOB
| TokenCB
-- and a simple lexer that returns this datastructure.
lexer :: String -> [Token]
lexer [] = []
lexer ('\n':cs) = TokenEOL : lexer cs
lexer (c:cs)
| isSpace c = lexer cs
| isDigit c = lexNum (c:cs)
lexer ('+':cs) = TokenPlus : lexer cs
lexer ('-':cs) = TokenMinus : lexer cs
lexer ('*':cs) = TokenTimes : lexer cs
lexer ('/':cs) = TokenDiv : lexer cs
lexer ('^':cs) = TokenExp : lexer cs
lexer ('(':cs) = TokenOB : lexer cs
lexer (')':cs) = TokenCB : lexer cs
lexNum cs = TokenNum (read num) : lexer rest
where (num,rest) = span isNum cs
isNum c = isDigit c || c == '.'
happyError tokens = liftIO (ioError (userError "parse error"))
-- vendored in parts of mtl
class Monad m => MonadIO m where liftIO :: IO a -> m a
instance MonadIO IO where liftIO = id
}
|
