baby ParserComp Lib

Parser.hs

{-# 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' ])