blob: 984098038c4505e1c7282de17806f46e4a03a01d (
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
78
79
80
|
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 a b -> a -> Maybe (b,a)
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
word :: String -> Parser String String
word w = Parser g where l = length w
g inp = if take l inp == w then Just (w,drop l inp)
else 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)
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
|
