blob: 843f9a5e442892e17bac8858f1c022f48da31c43 (
plain)
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
|
import Control.Applicative
import Data.Char
data Parser a b = Parser (a->Maybe (b,a))
instance Functor (Parser a) where
fmap f p = Parser g
where g inp = case parse p inp of Just (x,y) -> Just (f x,y)
_ -> Nothing
instance Applicative (Parser a) where
pure v = Parser (\inp -> Just (v,inp))
pg <*> px = Parser g
where g inp = case parse pg inp of Just (f,b) -> parse (fmap f px) b
_ -> Nothing
instance Alternative (Parser a) where
empty = Parser (\_ -> Nothing)
p1 <|> p2 = Parser g
where g inp = case parse p1 inp of Nothing -> parse p2 inp
x -> x
instance Monad (Parser a) where
return = pure
p >>= f = Parser g
where g inp = case parse p inp of Just (a,b) -> parse (f a) b
_ -> Nothing
parse (Parser f) inp = f inp
satisfy :: (Char -> Bool) -> Parser String Char
satisfy f = Parser g where g (x:xs) | f x = Just (x,xs)
g _ = Nothing
space :: Parser String Char
space = satisfy (==' ')
char :: Char -> Parser String Char
char c = satisfy (==c)
notChar :: Char -> Parser String Char
notChar c = satisfy (/=c)
num :: Parser String Int
num = read <$> some (satisfy isDigit)
word :: String -> Parser String String
word (c:cs) = (:) <$> char c <*> word cs
word _ = pure ""
parseOp op sig = (pure (op) <* many space <*> num <* many space <* char sig <* many space <*> num )
parseOps = (parseOp (+) '+' <|> parseOp (-) '-' <|> parseOp (*) '*' <|> parseOp (div) '/')
parsePar = concat <$> some parseP where parseP = word "()" <|> (char '(' *> parsePar <* char ')')
parseAB = (\a x b -> a:x++"b") <$> char 'a' <*> parseAB <*> char 'b' <|> word "ab"
parseABC = length <$> (many $ char 'a') >>= \la ->
length <$> (many $ char 'b') >>= \lb ->
length <$> (many $ char 'c') >>= \lc ->
if la==lb&&lb==lc then pure ("ABC ok") else empty
main = do
print $ parse parseOps "1+1" -- 2
print $ parse parseOps " 12 + 22" -- 34
print $ parse parseOps "5*5" -- 25
print $ parse parseOps " 6 - 1 " -- 5
print $ parse parsePar "((())(()()))" -- ok
print $ parse parsePar "((())(()(()())()" -- bad
print $ parse parseAB "aaaaabbbbb" -- ok
print $ parse parseAB "aaaaabbb" -- bad
print $ parse parseAB "aaaaabbbbbbbb" -- bad (trailing b's)
print $ parse parseABC "aaaabbbbcccc" -- ok
print $ parse parseABC "aaaabbbbbcccc" -- bad
|
