module ParseLib (Parser(), succeed, failure, eof, item, parse, sat, 
                 digit, lower, upper, letter, alphanum, char, string,
                 var, nat, space, token, identifier, natural, try,
                 symbol, paren, greedy, greedy1, first,
                 module Control.Applicative) where
    
import Data.Char
import Data.Functor
import Control.Applicative

-- The type of parsers
newtype Parser a = P (String -> [(a, String)])

-- Primitive parser combinators

-- A parser that always succeeds (lifts a value into the parser world)
succeed :: a -> Parser a
succeed v = P $ \inp -> [(v, inp)]

-- A parser that always fails
failure :: Parser a
failure = P $ \inp -> []

-- Recognize the end of input
eof :: Parser ()
eof = P $ \inp -> case inp of
                        [] -> [((), [])]
                        _  -> []

-- Take the first parse out of many
first :: Parser a -> Parser a
first p = P $ \inp -> case parse p inp of
                        [] -> []
                        xs -> [head xs]

-- A parser that always returns the first element of the string
item :: Parser Char
item = P $ \inp -> case inp of
                [] -> []
                (x:xs) -> [(x,xs)]

-- Apply the parser to a string                
parse :: Parser a -> String -> [(a, String)]
parse (P p) inp = p inp

-- Mapping over parsers
instance Functor Parser where
    fmap f p = P $ \inp -> map (\(a,out) -> (f a, out)) $ parse p inp 

-- Sequencing parsers
instance Applicative Parser where
    pure = succeed
    f <*> g = P $ \inp -> concat [ parse (v <$> g) out | (v, out) <- parse f inp ] 

-- Alternative parsers
instance Alternative Parser where
    empty = failure
    f <|> g = P $ \inp -> parse f inp ++ parse g inp

-- Parse a character satisfying a certain predicate
sat :: (Char -> Bool) -> Parser Char
sat p = P $ \inp -> case inp of
                        [] -> []
                        (x:xs) -> if p x then [(x, xs)] else []

-- Derived parsers

-- Parse a single digit character '0' .. '9'
digit :: Parser Char
digit = sat isDigit

-- Parse a lowercase character 'a' .. 'z'
lower :: Parser Char
lower = sat isLower

-- Parse an uppercase character 'A' .. 'Z'
upper :: Parser Char
upper = sat isUpper

-- Parse a letter 'a' .. 'z' and 'A' .. 'Z'
letter :: Parser Char
letter = sat isAlpha

-- Parse either a letter or a digit
alphanum :: Parser Char
alphanum = sat isAlphaNum

-- Parse a specific character
char :: Char -> Parser Char
char c = sat (==c)

-- Parse a specific string
string :: String -> Parser String
string [] = succeed []
string (x:xs) = (:) <$> char x <*> string xs

-- Parse an identifier (starting with lowercase followed by alphanumerical values)
var :: Parser String
var = (:) <$> lower <*> many alphanum

-- Parse a natural number
nat :: Parser Int
nat = read <$> some digit

-- Parse white space
space :: Parser ()
space = () <$ greedy (sat isSpace)

-- Run a specific parser ignoring surrounding whitespace
token :: Parser a -> Parser a
token p = id <$ space <*> p <* space

-- Parse an identifier ignoring surrounding whitespace
identifier :: Parser String
identifier = token var

-- Parse a natural number ignoring surrounding whitespace
natural :: Parser Int
natural = token nat

-- Try to run a parser
try :: Parser a -> Parser (Maybe a)
try p = Just <$> p <|> succeed Nothing

-- Parse a specific string ignoring white space
symbol :: String -> Parser String
symbol xs = token (string xs)

-- Parse something that is surrounded by parentheses
paren :: Parser a -> Parser a
paren p = symbol "(" *> p <* symbol ")"

-- Like many but with a take all or nothing semantics
greedy :: Parser a -> Parser [a]
greedy = first . many

greedy1 :: Parser a -> Parser [a]
greedy1 = first . some