module Logic.Parse where

import Control.Applicative (Applicative, Alternative(..))
import Data.Functor (Functor)

newtype Parser output = Parser
  { runParser :: Input -> Either ParseError (output, Input)
  }

data Input = Input
  { inputPos :: Int
  , inputSeq :: [Char]
  } deriving (Eq, Show)

mkInput :: [Char] -> Input
mkInput = Input 0

data ParseError =
  ParseError Int String
  deriving (Show)

expected :: String -> Input -> ParseError
expected thing input = ParseError (inputPos input) $
  "expected " <> thing <> ", found " <> show (take 20 $ inputSeq input)

eof :: Parser a -> Input -> Either ParseError a
eof p input = do
  (result, rest) <- runParser p input
  case inputSeq rest of
    [] -> Right result
    _ -> Left $ expected "end of input" rest

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap f (Parser p) = Parser $ \input -> do
    (result, rest) <- p input
    return (f result, rest)

instance Applicative Parser where
  pure :: a -> Parser a
  pure result = Parser $ \input -> Right (result, input)

  (Parser p1) <*> (Parser p2) =
    Parser $ \input -> do
      (f, rest) <- p1 input
      (result, rest') <- p2 rest
      return (f result, rest')

instance Alternative Parser where
  empty :: Parser a
  empty = Parser $ const empty

  (Parser p1) <|> (Parser p2) =
    Parser $ \input -> p1 input <|> p2 input

instance Alternative (Either ParseError) where
  empty :: Either ParseError a
  empty = Left $ ParseError 0 "this parser always fails"

  (Right x) <|> _ = Right x
  (Left _) <|> e = e

parseToken :: String -> Parser String
parseToken token = Parser parse
  where
    n = length token
    parse input@(Input pos xs)
      | token == take n xs = Right $ (token,) $ Input (pos + n) (drop n xs)
      | otherwise = Left $ expected (show token) input

parseIf :: String -> (Char -> Bool) -> Parser Char
parseIf description check = Parser $ \input ->
  case inputSeq input of
    [] -> Left $ ParseError (inputPos input) "unexpected end of input"
    (char:chars)
      | check char -> Right $ (char,) $ Input (inputPos input + 1) chars
      | otherwise -> Left $ expected description input