Parser Combinators in Haskell

ParserCombinator.hs

module ParserCombinator where

import Data.Char
import Control.Applicative

newtype Parser a = Parser { runParser :: String -> [(a, String)] }

instance Monad Parser where
  -- _>>=_ :: Parser a -> (a -> Parser b) -> Parser b
  p >>= f = Parser $ \s -> do
    (a, s') <- runParser p $ s
    (b, s'') <- runParser (f a) $ s'
    return (b, s'')

instance Applicative Parser where
  -- pure :: a -> Parser a
  pure a = Parser $ \s -> [(a, s)]

  -- _<*>_ :: Parser (a -> b) -> Parser a -> Parser b
  pab <*> pa = do
    ab <- pab
    a <- pa
    pure $ ab a
  
instance Functor Parser where
  -- fmap :: (a -> b) -> Parser a -> Parser b
  fmap f pa = do
    a <- pa
    pure $ f a

instance Alternative Parser where
  -- empty :: Parser a
  empty = Parser $ \s -> []

  -- _<|>_ :: Parser a -> Parser a -> Parser a
  pa1 <|> pa2 = Parser $ \s -> (runParser pa1 $ s) ++ (runParser pa2 $ s)

some' :: Parser a -> Parser [a]
some' p = do
  a <- p
  r <- some' p
  pure (a:r)

isChar :: (Char -> Bool) -> Parser Char
isChar f = Parser $ \s -> case s of
  []     -> []
  (x:xs) -> if f x then [(x, xs)] else []

isChar_ :: (Char -> Bool) -> Parser ()
isChar_ f = const () <$> isChar f 

char :: Char -> Parser Char
char = isChar . (==)

space :: Parser ()
space = isChar_ isSpace

letter :: Parser Char
letter = isChar isLetter

digit :: Parser Char
digit = isChar isDigit

data Term = Nat Integer
          | Plus Term Term
          | Time Term Term
  deriving (Show)

natParser :: Parser Term
natParser = Nat . read <$> some digit

parenParser :: Parser Term
parenParser = char '(' *> termParser <* char ')'

timeParser :: Parser Term
timeParser =  foldl Time <$> atomParser <*> many (char '*' *> atomParser)
  where
    atomParser :: Parser Term
    atomParser =  natParser
              <|> parenParser

plusParser :: Parser Term
plusParser = foldl Plus <$> atomParser <*> many (char '+' *> atomParser)
  where
    atomParser :: Parser Term
    atomParser =  timeParser
              <|> parenParser

termParser :: Parser Term
termParser = plusParser

parse :: Parser a -> String -> [a]
parse p s = do
  (a, s') <- runParser p $ s
  if s' == [] then pure a else empty

foo :: [Term]
foo = parse plusParser "1*2+2*4"