{-# LANGUAGE DeriveFunctor #-}

module Parser where

import Data.Char(isSpace)
import Control.Monad

-- | type for parser for values of type `a'
newtype Parser a
  = Parser (String -> [(a, String)])
  deriving (Functor)

-- | monad instance for parser
instance Monad Parser where
   return a =
     Parser (\cs -> [(a, cs)])
   p >>= k  =
     Parser (\cs -> concat [runParser (k a) cs'
                           | (a,cs')<-runParser p cs])

-----------------------------------------------------------
-- Since GHC > 7.8 every instance of Monad must also be
-- an instance of Functor and Applicative
{-
instance Functor Parser where
  -- fmap :: (a -> b) -> Parser a -> Parser b
  fmap f p = Parser (\cs -> [(f a,cs') | (a,cs') <- runParser p cs])
-}

instance Applicative Parser where
  -- pure :: a -> Parser a
  pure = return
  -- <*> :: Parser (a -> b) -> Parser a -> Parser b
  pfun <*> parg = do
    f <- pfun
    a <- parg
    return (f a)
    
  
-----------------------------------------------------------

-- | empty parser; always fails
empty :: Parser a
empty = Parser (\cs -> [])

(+++) :: Parser a -> Parser a -> Parser a
p +++ q
     = Parser (\cs -> runParser p cs ++ runParser q cs)


-- run a parser on a input string
runParser :: Parser a -> String -> [(a, String)]
runParser (Parser f) = f

-- parse a single next character
next :: Parser Char
next = Parser (\cs -> case cs of
                       [] -> []
                       (c:cs') -> [(c, cs')])

-- parse the end of input
eof :: Parser ()
eof = Parser (\cs -> case cs of
                 "" -> [((), "")]
                 _ -> [])


-- deterministic choice
(<|>) :: Parser a -> Parser a -> Parser a
p <|> q = Parser (\cs -> take 1 (runParser (p +++ q) cs))

-- parse a character satisfying a predicate
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do c <- next
               if p c then return c
                 else empty 

-- parse specific character and string
char :: Char -> Parser Char
char c = satisfy (==c)

string :: String -> Parser String
string ""     = return ""
string (c:cs) = do char c; string cs; return (c:cs) 

-- repeat a parser zero or more times
many :: Parser a -> Parser [a]
many p = many1 p <|> return []

-- repeat a parser one or more times
many1 :: Parser a -> Parser [a]
many1 p = do a<-p; as<-many p; return (a:as) 

-- parse a string of spaces, tabs or newlines
spaces :: Parser String
spaces = many (satisfy isSpace)

-- parse  using a parser `p`
-- ignoring any leading spaces
token :: Parser a -> Parser a
token p = spaces >> p

-- parse a string, throwing away trailing spaces
symb :: String -> Parser String
symb s = token (string s)

-- repeated applications of `p'
-- separated by applications of `sep'

sepBy :: Parser a -> Parser b -> Parser [a]
p `sepBy` sep = (p `sepBy1` sep) <|> return []


-- p `sepBy1` sep =
--  p >> many (sep >> p)
--  do p; sep; p; sep; ... ; p
--     ^       ^       ^      ^  
sepBy1 :: Parser a -> Parser b -> Parser [a]
p `sepBy1` sep = do {a <- p;
                     as <- many (do {sep; p});
                     return (a:as)}



------------------------------------------------------------
-- factoring out repetitions
------------------------------------------------------------

-- | chain applications of a parser 
-- using a left-associative operator
chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op a = (p `chainl1` op) <|> return a

chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 p op = do a <- p; cont a
   where cont a = do f <- op
                     b <- p
                     cont (f a b)
                  <|> return a