{-# LANGUAGE LambdaCase #-}

module Parser 
    ( module Parser
    , module Control.Applicative
    ) where

import Control.Applicative
import Data.Char
import Debug.Trace

newtype Parser a = Parser { runParser :: String -> Maybe (a, String) }
instance Functor Parser where
    fmap f (Parser p) = Parser $ \input -> do
        (value, rest) <- p input
        return (f value, rest)

instance Applicative Parser where
    pure a = Parser $ \input -> Just (a, input)
    (Parser f) <*> (Parser g) = Parser $ \input -> do
        (fn, rest) <- f input
        (value, rest') <- g rest
        return (fn value, rest')

instance Monad Parser where
    return = pure
    (Parser a) >>= f = Parser $ \input -> do
        (value, rest) <- a input
        let Parser b = f value
         in b rest

instance Alternative Parser where
    empty = Parser $ const Nothing
    (Parser a) <|> (Parser b) = Parser $ \input -> a input <|> b input

instance MonadFail Parser where
    fail s = Parser $ const Nothing

charP :: Char -> Parser Char
charP c = Parser $ \case
    [] -> Nothing
    (x : xs)
        | x == c -> Just (c, xs)
        | otherwise -> Nothing

stringP :: String -> Parser String
stringP = sequence . map charP

predP :: (Char -> Bool) -> Parser Char
predP pred = Parser $ \case
    [] -> Nothing
    (x : xs)
        | pred x -> Just (x, xs)
        | otherwise -> Nothing

digitP :: Parser Char
digitP = predP isDigit

numberP :: Parser Int
numberP = read <$> some digitP

letterP :: Parser Char
letterP = predP (`notElem` [':','\\', 'λ', '.', ' ', '-', '>', '*', '(', ')', '=', '\n'])

wordP :: Parser String
wordP = some letterP

spaceP :: Parser ()
spaceP = () <$ predP isSpace

notFollowedBy :: Parser a -> Parser b -> Parser a
a `notFollowedBy` b = Parser $ \input -> do
    (value, rest) <- runParser a input
    case runParser b rest of
        Just _ -> Nothing
        Nothing -> Just (value, rest)

debug :: Show a => Parser a -> Parser a
debug p = Parser $ \input -> case runParser p input of
    ret@(Just (value, rest)) -> trace ("Input: " ++ input ++ "\nParsed: " ++ show value ++ "\nRest: " ++ rest ++ " (" ++ show (length rest) ++ ")") ret
    Nothing -> trace ("Input: " ++ input) Nothing