module DSL.BaseParsers where

-- Parsec is for casuals

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

data ParserError
  = ErrorLeaf String
  | ErrorBranch String [ParserError]
    deriving (Show)

newtype Parser t a =
  Parser { parse :: [t] -> Either ParserError ([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 = flunkWith "Flunked: empty Alternative"

  (<|>) = alt

instance MonadPlus (Parser t)

instance MonadFail (Parser t) where
  fail _ = mzero

type ErrorChanger t a = String -> Parser t a -> Parser t a

nicePrintParserError :: ParserError -> String
nicePrintParserError = unlines . go 0
  where
    indentSize = 4
    go indent (ErrorLeaf s) = [replicate indent ' ' ++ s]
    go indent (ErrorBranch s es) = s':es'
      where
        s'  = replicate indent ' ' ++ s
        es' = es >>= go (indent + indentSize)

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

perr :: String -> Either ParserError Void
perr = Left . ErrorLeaf

overwriteError :: ErrorChanger t a
overwriteError s p = Parser $ \ inp -> case parse p inp of
  Left _  -> absurd <$> perr s
  Right x -> Right x

setError :: ErrorChanger t a
setError s p = Parser $ \ inp -> case parse p inp of
  Left (ErrorLeaf _)      -> absurd <$> perr s
  Left (ErrorBranch _ es) -> Left $ ErrorBranch s es
  Right x                 -> Right x

prependError :: ErrorChanger t a
prependError s p = Parser $ \ inp -> case parse p inp of
  Left e  -> Left $ ErrorBranch s [e]
  Right x -> Right x

flunk :: Parser t a
flunk = flunkWith "Flunked parser"

flunkWith :: String -> Parser t a
flunkWith e = Parser $ \ _ -> absurd <$> perr e

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

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

anyToken :: Parser t t
anyToken = Parser $ \ inp -> case inp of
  t:ts -> Right (ts, t)
  _    -> absurd <$> perr "anyToken: Expected a token, got EOF"

eof :: Parser t ()
eof = Parser $ \ inp -> case inp of
  [] -> Right ([], ())
  _  -> absurd <$> perr "eof: Expected EOF, got a token"

infixl 3 `alt`
alt :: Parser t a -> Parser t a -> Parser t a
alt p q = Parser $ \ inp -> case (parse p inp, parse q inp) of
  (Right x, _)       -> Right x
  (_, Right x)       -> Right x
  (Left e1, Left e2) -> Left $ case (e1, e2) of
    (ErrorLeaf s, ErrorBranch b es) -> ErrorBranch b (ErrorLeaf s:es)
    (ErrorBranch b es, ErrorLeaf s) -> ErrorBranch b (es ++ [ErrorLeaf s])
    _                               -> ErrorBranch "alt:" [e1, e2]

chain :: Parser s [t] -> Parser t a -> Parser s a
chain p q = prependError "chain:" $ Parser $ \ inp1 -> case parse p inp1 of
  Left e1 -> Left e1
  Right (inp1', inp2) -> case parse q inp2 of
    Left e2 -> Left e2
    Right (_, x) -> Right (inp1', x)

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

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

plus :: Parser t a -> Parser t b -> Parser t (a, b)
plus p q = prependError "plus:" $ liftA2 (,) p q

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

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

optionalEither :: e -> Parser t a -> Parser t (Either e a)
optionalEither e = recover (Left e) . fmap Right

optional :: Parser t a -> Parser t ()
optional p = () <$ optionalMaybe p

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

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

token :: Eq t => t -> Parser t t
token t = prependError "token:" $ satisfy (==t)

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

mult :: Parser t a -> Parser t [a]
mult = prependError "mult:" . many

mult1 :: Parser t a -> Parser t [a]
mult1 = prependError "mult1:" . some

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

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

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

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

stopAt :: Parser t a -> Parser t [t]
stopAt p = setError "stopAt: failed to find stop point" $ go
  where
    p' = ([] <$ peek p)
    go = p' <|> liftA2 (:) anyToken go

stopAfter :: Parser t a -> Parser t ([t], a)
stopAfter p = prependError "stopAfter:" $ stopAt p `plus` p

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

firstOf :: [Parser t a] -> Parser t a
firstOf = prependError "firstOf:" . foldr1 (<|>)

sepBy1 :: Parser t a -> Parser t b -> Parser t [a]
sepBy1 a b = prependError "sepBy1:" $ do
  x  <- a
  xs <- mult $ b >> a
  return $ x:xs

sepBy :: Parser t a -> Parser t b -> Parser t [a]
sepBy a b = sepBy1 a b <|> pure []