CarstenKoenig · March 13, 2018 10:09 · Mar 13, 2018
diff --git a/Parser.hs b/Parser.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Parser
+  ( Parser
+  , parse
+  , Parser.fail
+  , succeed
+  , choose
+  , char
+  , digit
+  , optional
+  , many
+  , many1
+  , choice
+  , chainl1
+  , chainl
+  , between
+  , whitespace
+  ) where
+
+import Control.Applicative (Alternative (..))
+import Data.Char (isDigit)
+import Data.Semigroup (Semigroup (..), (<>))
+
+newtype Parser a
+  = Parser
+  { runParser :: String -> Maybe (a, String)
+  }
+
+
+parse :: Parser a -> String -> Maybe a
+parse pa = fmap fst . runParser pa
+
+
+fail :: Parser a
+fail = Parser $ const Nothing
+
+
+succeed :: a -> Parser a
+succeed x = Parser $ \s -> Just (x, s)
+
+
+choose :: (Char -> Bool) -> Parser Char
+choose praed = Parser $ \case
+  (c:s) | praed c -> Just (c, s)
+  _               -> Nothing
+
+
+char :: Char -> Parser Char
+char c = choose (== c)
+
+
+digit :: Parser Char
+digit = choose isDigit
+
+
+instance Functor Parser where
+  fmap f pa = Parser $ fmap (\(a, r) -> (f a, r)) . runParser pa
+
+
+optional :: Parser a -> Parser (Maybe a)
+optional pa = Parser $ \s ->
+  case runParser pa s of
+    Nothing      -> Just (Nothing, s)
+    Just (a, s') -> Just (Just a, s')
+
+
+instance Applicative Parser where
+  pure = succeed
+  pf <*> pa = Parser $ \s -> do
+    (f, s') <- runParser pf s
+    (x, s'') <- runParser pa s'
+    return (f x, s'')
+
+
+instance Alternative Parser where
+  empty = Parser.fail
+  p1 <|> p2 = Parser $ \s ->
+    case runParser p1 s of
+      ok@(Just _) -> ok
+      Nothing     -> runParser p2 s
+
+
+many1 :: Parser a -> Parser [a]
+many1 = some
+
+
+choice :: [Parser a] -> Parser a
+choice = foldr (<|>) empty
+
+
+instance Semigroup a => Semigroup (Parser a) where
+  p1 <> p2 = (<>) <$> p1 <*> p2
+
+
+instance Monoid a => Monoid (Parser a) where
+  mempty = succeed mempty
+  p1 `mappend` p2 = mappend <$> p1 <*> p2
+
+
+instance Monad Parser where
+  return = pure
+  pa >>= fpb = Parser $ \s -> do
+    (a, s') <- runParser pa s
+    runParser (fpb a) s'
+
+
+chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
+chainl1 pa pop = pa >>= cont
+  where
+    cont a =
+      do
+        op <- pop
+        a' <- pa
+        cont (a `op` a')
+      <|> succeed a
+
+
+chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+chainl pa pop va = chainl1 pa pop <|> succeed va
+
+
+between :: Parser l -> Parser r -> Parser a -> Parser a
+between pl pr pa = pl *> pa <* pr
+
+
+whitespace :: Parser ()
+whitespace = return () <* many (choice [ char ' ', char '\n', char '\t', char '\r' ])
No results found