module Parser where

import Data.Char
import Data.List
import Control.Applicative
import Control.Monad

----------------------------------------------------------------------

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

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap f pa = pure f <*> pa

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

  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
  (<*>) = ap

instance Monad Parser where
  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  pa >>= f = Parser $ \s0 ->
    [ (b, s2) | (a, s1) <- runParser pa s0
              , (b, s2) <- runParser (f a) s1 ]

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

  (<|>) :: Parser a -> Parser a -> Parser a
  (Parser f) <|> (Parser g) = Parser $ \s -> f s ++ g s

----------------------------------------------------------------------

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = Parser $ \s -> case s of
  []     -> []
  (a:as) -> [ (a,as) | p a ]

char c = satisfy (c==)
alpha  = satisfy isAlpha
digit  = satisfy isDigit
space  = satisfy isSpace

string :: String -> Parser String
string str = Parser $ \s ->
  [ (pre, suf) | let (pre, suf) = splitAt (length str) s, str == pre ]

token :: String -> a -> Parser a
token str a =
  const a <$> string str

true, false, bool :: Parser Bool

true  = token "True" True
false = token "False" False
bool  = true <|> false

----------------------------------------------------------------------

option :: a -> Parser a -> Parser a
option a pa =
  pa <|> pure a

(<++) :: Parser a -> Parser a -> Parser a
(<++) p1 p2 = Parser $ \s ->
  case runParser p1 s of
    []      -> runParser p2 s
    matches -> matches

munch :: (Char -> Bool) -> Parser String
munch pred = Parser $ \s ->
  [span pred s]

sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy pa psep =
  sepBy1 pa psep <|> pure []

sepBy1 :: Parser a -> Parser sep -> Parser [a]
sepBy1 pa psep =
  pure (:)
    <*> pa
    <*> (many (psep >> pa))

between :: Parser open -> Parser close -> Parser a -> Parser a
between p1 p2 pa =
  pure id
    <*  p1
    <*> pa
    <*  p2

skipSpaces :: Parser ()
skipSpaces =
  const () <$> munch isSpace

----------------------------------------------------------------------

readEither :: Read a => String -> Either String a
readEither s0 =
  case reads s0 of
    [(a,"")] -> Right a
    [(a,s1)] -> Left $ "suffix not consumed: [" ++ s1 ++ "]"
    []       -> Left $ "no successful parses"
    _        -> Left $ "multiple successful parses"