geekrelief (owner)

Revisions

gist: 89786 Download_button fork
public
Public Clone URL: git://gist.github.com/89786.git
parsec3-tut.hs
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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
-- Parsec 3 tutorial code --
 
-- module Main where -- this isn't necessary
 
import Text.Parsec
import Text.Parsec.String (Parser) -- type Parser = Parsec String ()
import Text.Parsec.Expr
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellStyle)
import Data.Char
-- import Control.Monad.Identity -- for the Identity monad
 
simple :: Parser Char
simple = letter
 
run :: Show a => Parser a -> String -> IO ()
run p input =
    case (parse p "" input) of
        Left err -> do putStr "parse error at "
                       print err
        Right x -> print x
 
openClose :: Parser Char
openClose = do char '('
               char ')'
 
{- -- parens is defined in Text.Parsec.Token
parens :: Parser ()
parens = do char '('
parens
char ')'
parens
<|> return ()
-}
 
testOr :: Parser String
testOr = string "(a)"
     <|> string "(b)"
 
testOr1 :: Parser Char
testOr1 = do char '('
             char 'a' <|> char 'b'
             char ')'
 
testOr2 :: Parser String
testOr2 = try (string "(a)")
      <|> string "(b)"
 
testOr3 :: Parser String
testOr3 = do try (string "(a")
             char ')'
             return "(a)"
      <|> string "(b)"
 
nesting :: Parser Int
nesting = do char '('
             n <- nesting
             char ')'
             m <- nesting
             return (max (n+1) m)
         <|> return 0
 
{-
word :: Parser String
word = do{ c <- letter
; do{ cs <- word
; return (c:cs)
}
<|> return [c]
}
-}
 
{-
word :: Parser String
word = do c <- letter
do cs <- word
return (c:cs)
<|> return [c] -- <|> indentation is confusing here, but it works
-}
 
--word :: Parser String
--word = many1 letter
 
{-
sentence :: Parser [String]
sentence = do words <- sepBy1 word separator
oneOf ".?!"
return words
 
separator :: Parser ()
separator = skipMany1 (space <|> char ',')
-}
 
 
word :: Parser String
word = many1 letter <?> "word"
 
separator :: Parser ()
separator = skipMany1 (space <|> char ',' <?> "")
 
sentence :: Parser [String]
sentence = do words <- sepBy1 word separator
              oneOf ".?!" <?> "end of sentence"
              return words
 
{-
expr :: Parser Integer
expr = buildExpressionParser table factor <?> "expression"
 
table = [[op "*" (*) AssocLeft, op "/" div AssocLeft]
,[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
]
where op s f assoc
= Infix (do{ string s; return f}) assoc
 
factor = do char '('
x <- expr
char ')'
return x
<|> number
<?> "simple expression"
-}
 
number :: Parser Integer
number = do ds <- many1 digit
            return (read ds)
        <?> "number"
{-
lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellStyle
{ P.reservedOpNames = ["*", "/", "+", "-"]}
)
-}
 
whiteSpace = P.whiteSpace lexer
lexeme = P.lexeme lexer
symbol = P.symbol lexer
natural = P.natural lexer
parens = P.parens lexer
semi = P.semi lexer
identifier = P.identifier lexer
reserved = P.reserved lexer
reservedOp = P.reservedOp lexer
 
--expr :: Parser Integer
expr = buildExpressionParser table factor <?> "expression"
 
-- for evaluating expressions
--table :: Integral a => OperatorTable String () Identity a
table = [[op "*" (*) AssocLeft, op "/" div AssocLeft]
        ,[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
        ]
      where op s f assoc
               = Infix (do{ reservedOp s; return f} <?> "operator") assoc
 
factor = parens expr
         <|> natural
         <?> "simple expression"
 
 
{- -- for recognizing expressions and outputting text
-- this section is not in the tutorial
strIn op = (\x y -> x ++ " " ++ op ++ " " ++ y)
mulStr = strIn "*"
divStr = strIn "/"
addStr = strIn "+"
subStr = strIn "-"
 
table = [[op "*" mulStr AssocLeft, op "/" divStr AssocLeft]
,[op "+" addStr AssocLeft, op "-" subStr AssocLeft]
]
where op s f assoc
= Infix (do{ reservedOp s; return f} <?> "operator") assoc
 
factor = parens expr
<|> lexeme (many1 digit) -- natural
<?> "simple expression"
-}
 
runLex :: Show a => Parser a -> String -> IO ()
runLex p input
    = run (do whiteSpace
               x <-p
               eof
               return x
          ) input
 
price :: Parser Int -- price in cents
price = lexeme (do ds1 <- many1 digit
                   char '.'
                   ds2 <- count 2 digit
                   return (convert 0 (ds1 ++ ds2))
               )
        <?> "price"
        where
            convert n [] = n
            convert n (d:ds) = convert (10*n + digitToInt d) ds
 
{-
receipt :: Parser Bool
receipt = do ps <- many produkt
p <- total
return (sum ps == p)
 
produkt = do symbol "return"
p <- price
semi
return (-p)
<|> do identifier
p <- price
semi
return p
<?> "product"
-}
 
{-
total = do p <- price
symbol "total"
return p
 
produkt = do try (symbol "return")
p <- price
semi
return (-p)
<|> do identifier
p <- price
semi
return p
<?> "product"
-}
 
lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellStyle
                               { P.reservedNames = ["return", "total"]
                               , P.reservedOpNames = ["*","/","+","-"]
                               }
                          )
 
receipt :: Parser Bool
receipt = do ps <- many produkt
             p <- total
             return (sum ps == p)
 
produkt = do reserved "return"
             p <- price
             semi
             return (-p)
      <|> do identifier
             p <- price
             semi
             return p
      <?> "produkt"
 
total = do p<- price
           reserved "total"
           return p