star.hs

{-# LANGUAGE DeriveFunctor, LambdaCase #-}

import Control.Applicative hiding (many)
import Control.Monad

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

instance Applicative Parser where
    pure x = Parser (\s -> [(x,s)])
    fs <*> xs = fs >>= (\f -> xs >>= (\x -> pure (f x)))
    
instance Monad Parser where
    xs >>= f = Parser (\s -> [ (y,s'') | (x,s') <- runParser xs s, (y,s'') <- runParser (f x) s' ])
    
instance Alternative Parser where
    empty = Parser (\_ -> [])
    xs <|> ys = Parser (\s -> runParser xs s ++ runParser ys s)
    
instance MonadPlus Parser where
    
starM :: MonadPlus f => (a -> f a) -> a -> f a
starM f x = pure x <|> plusM f x

plusM :: MonadPlus f => (a -> f a) -> a -> f a
plusM f x = f x >>= starM f

starA :: Alternative f => f (a -> a) -> a -> f a
starA fs x = pure x <|> plusA fs x

plusA :: Alternative f => f (a -> a) -> a -> f a
plusA fs x = fs <*> starA fs x

manyM :: Parser a -> Parser [a]
manyM p = starM ((<$> p) . flip (:)) []

manyA :: Parser a -> Parser [a]
manyA p = starA ((:) <$> p) []

char :: Char -> Parser Char
char c = Parser (\case
    (x:xs) | x == c -> [(x, xs)]
    _ -> [])