{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
module Language.Json.Parser (runParser, Parser, exact, char, oneOf, optional, anyChar, satisfies, times, sepBy, eof) where
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Applicative (Alternative (..), asum)
import Data.Functor (($>))

newtype Parser a = Parser (Text -> Reply a)

data Reply a
  = Done Text a -- rest, result
  | Fail

instance Functor Reply where
  fmap :: (a -> b) -> Reply a -> Reply b
  fmap f = \case
    Done rest result -> Done rest (f result)
    Fail -> Fail

runParser :: Parser a -> Text -> Maybe (Text, a)
runParser (Parser computeA) input = case computeA input of
  Done rest result -> Just (rest, result)
  Fail -> Nothing

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap func (Parser computeA) = Parser (fmap func . computeA)

instance Applicative Parser where
  pure :: a -> Parser a
  pure a = Parser $ \ input -> Done input a
  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
  (<*>) (Parser computeF) (Parser computeA) = Parser $ \ input -> case computeF input of
    Done rest f -> f <$> computeA rest
    Fail -> Fail

instance Monad Parser where
  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  (>>=) (Parser computeA) f = Parser $ \ input -> case computeA input of
    Done rest a -> let
      (Parser computeB) = f a
      in computeB rest
    Fail -> Fail

exact :: Text -> Parser ()
exact prefix = Parser $ \ input -> case Text.stripPrefix prefix input of
  Just rest -> Done rest ()
  Nothing -> Fail

instance Alternative Parser where
  empty :: Parser a
  empty = Parser $ const Fail
  (<|>) :: Parser a -> Parser a -> Parser a
  (<|>) (Parser first) (Parser second) = Parser $ \ input -> case first input of
    Fail -> second input
    x -> x

char :: Char -> Parser Char
char c = exact (Text.singleton c) $> c

oneOf :: [Parser a] -> Parser a
oneOf = asum

optional :: Parser a -> Parser (Maybe a)
optional parser = fmap Just parser <|> pure Nothing

anyChar :: Parser Char
anyChar = Parser $ \ input -> case Text.uncons input of
  Just (c, rest) -> Done rest c
  Nothing -> Fail

satisfies :: (Char -> Bool) -> Parser Char
satisfies f = do
  c <- anyChar
  if f c
    then pure c
    else empty

times :: Int -> Parser a -> Parser [a]
times n body = go n
  where
    go 0 = pure []
    go i = do
      x <- body
      xs <- go $ pred i 
      pure $ x:xs

sepBy :: Parser a -> Parser b -> Parser [a]
sepBy p sep = do
  first <- optional p
  rest <- sep *> sepBy p sep <|> pure []

  pure $ maybe id (:) first rest

eof :: Parser Bool
eof = anyChar *> empty <|> pure True