module Parsers where

-- Parsec is for casuals

import Control.Applicative (Alternative(..), liftA2)
import Control.Monad (MonadPlus(..), guard)
import Data.Maybe (catMaybes)

newtype Parser t a =
  Parser { parse :: [t] -> Maybe ([t], a) }

instance Semigroup a => Semigroup (Parser t a) where
  (<>) = liftA2 (<>)

instance Monoid a => Monoid (Parser t a) where
  mempty = pure mempty

instance Functor (Parser t) where
  fmap f (Parser p) = Parser $ fmap (fmap f) . p

instance Applicative (Parser t) where
  pure = result

  p <*> q = Parser $ \ inp -> do
    (inp', f) <- parse p inp
    parse (f <$> q) inp'

instance Monad (Parser t) where
  return = pure

  p >>= f = Parser $ \ inp -> do
    (inp', x) <- parse p inp
    parse (f x) inp'

instance Alternative (Parser t) where
  empty = flunk

  (<|>) = alt

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

flunk :: Parser t a
flunk = Parser $ \ _ -> Nothing

result :: a -> Parser t a
result x = Parser $ \ inp -> Just (inp, x)

peek :: Parser t a -> Parser t a
peek p = Parser $ \ inp -> do
  (_, x) <- parse p inp
  return (inp, x)

anyToken :: Parser t t
anyToken = Parser $ \ inp -> case inp of
  t:ts -> Just (ts, t)
  _    -> Nothing

eof :: Parser t ()
eof = Parser $ \ inp -> case inp of
  [] -> Just ([], ())
  _  -> Nothing

infixl 3 `alt`
alt :: Parser t a -> Parser t a -> Parser t a
alt (Parser p) (Parser q) = Parser $ \ inp -> p inp <|> q inp

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

phrase :: Parser t a -> Parser t a
phrase = (<* eof)

recover :: a -> Parser t a -> Parser t a
recover x p = p <|> pure x

optional :: Parser t a -> Parser t (Maybe a)
optional = recover Nothing . fmap Just

assert :: (a -> Bool) -> Parser t a -> Parser t a
assert f p = do
  x <- p
  guard $ f x
  return x

satisfy :: (t -> Bool) -> Parser t t
satisfy f = assert f anyToken

token :: Eq t => t -> Parser t t
token t = satisfy (==t)

list :: Eq t => [t] -> Parser t [t]
list = traverse token

mult :: Parser t a -> Parser t [a]
mult = many

mult1 :: Parser t a -> Parser t [a]
mult1 = some

exactly :: Int -> Parser t a -> Parser t [a]
exactly i = sequence . replicate i

atLeast :: Int -> Parser t a -> Parser t [a]
atLeast i p = exactly i p <> mult p

atMost :: Int -> Parser t a -> Parser t [a]
atMost i = fmap catMaybes . exactly i . optional

between :: Int -> Int -> Parser t a -> Parser t [a]
between x y p = exactly (min x y) p <> atMost (abs $ x - y) p

stopAt :: Parser t a -> Parser t [t]
stopAt p = go
  where
    p' = ([] <$ peek p)
    go = p' <|> liftA2 (:) anyToken go

stopAfter :: Parser t a -> Parser t ([t], a)
stopAfter p = (,) <$> stopAt p <*> p

stopIf :: Parser t a -> Parser t [t]
stopIf p = stopAt $ () <$ p <|> eof