{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module K.NanoParsec where

import qualified Data.Text as T
import Control.Monad (when, MonadPlus(..))
import Control.Applicative ((<$>), Alternative(..))
import Control.Lens (_1, (&), (%~))

newtype Parser a = Parser { parse :: T.Text -> [(a, T.Text)] }

runParser :: Parser a -> T.Text -> Either T.Text a
runParser m t = case parse m t of
    [(r, t')] -> do
        when (not (T.null  t')) (consumptionError t')
        return r
    _ -> Left "Parser error."

    where consumptionError t =
              Left ("Parser did not consume input: " `T.append` t)

bind :: Parser a -> (a -> Parser b) -> Parser b
bind p f = Parser $ \t -> (concat . fmap fp) (parse p t)
    where fp (x, t') = parse (f x) t'

unit :: a -> Parser a
unit x = Parser (\t -> [(x, t)])

failure :: Parser a
failure = Parser (const [])

combine :: Parser a -> Parser a -> Parser a
combine p q = Parser $ \t -> parse p t ++ parse q t

option :: Parser a -> Parser a -> Parser a
option p q = Parser $ \t ->
    case parse p t of
      [] -> parse q t
      res -> res

instance Functor Parser where
    fmap f p = Parser $ \t -> f' <$> parse p t
        where f' (x, t) = (f x, t)

instance Applicative Parser where
    pure = unit
    (Parser p1) <*> (Parser p2) = Parser $ \t ->
        [(f x, t'') | (f, t') <- p1 t, (x, t'') <- p2 t']

instance Monad Parser where
    return = unit
    (>>=) = bind

instance Alternative Parser where
    empty = mzero
    (<|>) = option

instance MonadPlus Parser where
    mzero = failure
    mplus = combine
        
item :: Parser Char
item = Parser $ \t -> case T.uncons t of
    Nothing -> []
    Just (c, t) -> [(c, t)]

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
  c <- item
  if p c
  then unit c
  else failure