1 files changed, 80 insertions, 0 deletions
diff --git a/parser/main.hs b/parser/main.hs
new file mode 100644
index 0000000..9840980
--- /dev/null
+++ b/parser/main.hs
@@ -0,0 +1,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