-- | Report bugs to [gitlab](https://gitlab.com/rdnz/uu-tc-error/-/issues)
-- or @p.rednaz\@googlemail.com@, please.

module ParseLib.Simple.Core
  (
    -- * Running parsers
    parseImproved,
    parseAndTraceImproved,
    parseWithConfig,
    parseAndTrace,
    parse,
    -- * The type of parsers
    Parser,
    -- * Elementary parsers
    anySymbol,
    satisfy,
    empty,
    failp,
    succeed,
    pure,
    fail,
    expected,
    -- * Parser combinators
    (<|>),
    (<<|>),
    (<*>),
    (<$>),
    (>>=),
    -- * Lookahead
    look,
  )
  where

import Data.Bifunctor (first, second)
import Data.DifferenceList (DifferenceList)
import qualified Data.DifferenceList as D
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty ((:|)))
import ParseLib.Error
  ( Config (Config, errorCount),
    ErrorsPretty (errorBundlePrettyImproved),
    ParseError (Fail, ParseError),
    ParseErrorBundle (ParseErrorBundle),
    defaultConfig,
    errorBundlePretty,
    toBundle,
    traceErrorMessage,
  )
import Prelude hiding (MonadFail (..), pure, (<$>), (<*>), (>>=))

-- | An input string is mapped to a list of successful parses.
-- For each succesful parse, we return the result of type 'r',
-- and the remaining input string. The input must be a list of
-- symbols.
type Parser s r = [s] -> ([(r, [s])], DifferenceList (ParseError [s]))

fail :: String -> Parser s a
fail text input = ([], D.singleton $ Fail text input)

expected :: [s] -> Parser s a
expected expect input = ([], D.singleton $ ParseError expect input)

-- | Parses any single symbol.
anySymbol :: Parser s s
anySymbol (x:xs)  =  ([(x,xs)], mempty)
anySymbol []      =  fail "Core.anySymbol expected any symbol." []

-- | Takes a predicate and returns a parser that parses a
-- single symbol satisfying that predicate.
satisfy  ::  (s -> Bool) -> Parser s s
satisfy p (x:xs) | p x  =  ([(x,xs)], mempty)
satisfy _ input         =  fail "symbol does not Core.satisfy predicate argument." input

-- | Parser for the empty language, i.e., parser that always fails.
empty :: Parser s a
empty = fail "Core.empty"

-- | Same as 'empty'; provided for compatibility with the lecture notes.
failp :: Parser s a
failp = fail "Core.failp"

-- | Parser that always succeeds, i.e., for epsilon.
succeed :: a -> Parser s a
succeed r xs = ([(r, xs)], mempty)

-- | Same as 'succeed'; provided for compatiblity with the applicative
-- interface.
pure :: a -> Parser s a
pure = succeed

infixl 4  <$>, <*>
infixr 3  <|>, <<|>
infixl 1  >>=

-- | Choice between two parsers with the same result type.
(<|>) :: Parser s a -> Parser s a -> Parser s a
(p <|> q) xs  =  p xs <> q xs

-- | Biased choice. If the left hand side parser succeeds,
-- the right hand side is not considered. Use with care!
(<<|>) :: Parser s a -> Parser s a -> Parser s a
(p <<|> q) xs  =  let pxs@(r, es) = p xs in if null r then second (es <>) (q xs) else pxs

-- | Sequence of two parsers.
(<*>) :: Parser s (b -> a) -> Parser s b -> Parser s a
(p <*> q) xs =
  second (es0 <>) $
  foldMap (\(f, ys) -> (first . fmap . first) f (q ys)) $
  r0
  where (r0, es0) = p xs

-- | Map a function over the results of a parser. The '<$>' combinator
-- can also be defined in terms of 'succeed' and '<*>':
--
-- > f <$> p  =  succeed f <*> p
--
(<$>) :: (a -> b) -> Parser s a -> Parser s b
(f <$> p) xs =
  (
    [(f y,ys)
    |(  y,ys) <- r
    ]
    ,
    es0
  )
  where (r, es0) = p xs

-- | Monadic bind. Do not use this combinator unless absolutely
-- required. Most sequencing can be done with '<*>'.
(>>=) :: Parser s a -> (a -> Parser s b) -> Parser s b
(p >>= f) xs  =
  second (es0 <>) $
  foldMap (\(a, ys) -> f a ys) $
  r
  where (r, es0) = p xs

-- | Returns the rest of the input without consuming anything.
look :: Parser s [s]
look xs = ([(xs, xs)], mempty)

-- | Runs a parser on a given string printing error messages to standard
-- error (stderr) like `parse` but makes error messages bearable for
-- @Parser Char@. `parseImproved` is always preferable to `parse`.
--
-- Notice that, when using `parseImproved`, you might need to add `Ord` and
-- `ErrorsPretty` constraints to your own functions and ensure your own
-- data types are @deriving (`Ord`, `Show`)@.
--
-- The `ErrorsPretty` constraint is automatically fulfilled by `Show`
-- instances. But if you see the following GHC error, you usually need to
-- add a @(`ErrorsPretty` s)@ constraint to your function and
-- @import ParseLib.Error (`ErrorsPretty`)@.
--
-- @
-- Overlapping instances for ErrorsPretty s
-- arising from a use of ‘parseImproved’
-- @
parseImproved :: (ErrorsPretty s, Ord s) => Parser s a -> [s] -> [(a, [s])]
parseImproved = parseAndTraceImproved defaultConfig

-- | Runs a parser on a given string printing error messages to standard
-- error (stderr) like `parseAndTrace` but makes error messages bearable
-- for @Parser Char@. `parseAndTraceImproved` is always preferable to
-- `parse`.
--
-- The `ErrorsPretty` constraint is automatically fulfilled by `Show`
-- instances. But if you see the following GHC error, you usually need to
-- add a @(`ErrorsPretty` s)@ constraint to your function and
-- @import ParseLib.Error (`ErrorsPretty`)@.
--
-- @
-- Overlapping instances for ErrorsPretty s
-- arising from a use of ‘parseImproved’
-- @
parseAndTraceImproved ::
  (ErrorsPretty s, Ord s) => Config -> Parser s a -> [s] -> [(a, [s])]
parseAndTraceImproved config p input =
  traceErrorMessage $
  first (errorBundlePrettyImproved config input) $
  parseWithConfig config p input

-- | Runs a parser on a given string. Pretty print the error information
-- with `errorBundlePrettyImproved`.
parseWithConfig ::
  (Ord s) =>
  Config ->
  Parser s a ->
  [s] ->
  Either (ParseErrorBundle [s]) (NonEmpty (a, [s]))
parseWithConfig (Config {errorCount}) p =
  -- Either (ParseErrorBundle [s]) (NonEmpty (a, [s]))
  first ParseErrorBundle .
  -- Either [(WithLength [s], NonEmpty (BundledParseError [s]))] (NonEmpty (a, [s]))
  (if errorCount >= 0 then first (take errorCount) else id) .
  -- Either [(WithLength [s], NonEmpty (BundledParseError [s]))] (NonEmpty (a, [s]))
  first toBundle .
  -- Either [ParseError [s]] (NonEmpty (a, [s]))
  first toList .
  -- Either (DifferenceList (ParseError [s])) (NonEmpty (a, [s]))
  (\case
    ([], errors) -> Left errors
    (a : b, _) -> Right (a :| b)
  ) .
  -- ([(a, [s])], DifferenceList (ParseError [s]))
  p
  -- [s]

-- | Runs a parser on a given string printing error messages to standard
-- error (stderr) like `parseAndTraceImproved` but with much worse error
-- messages for @Parser Char@. `parseAndTraceImproved` is always preferable
-- to `parseAndTrace`.
parseAndTrace ::
  (Show s, Ord s) => Config -> Parser s a -> [s] -> [(a, [s])]
parseAndTrace config p input =
  traceErrorMessage $
  first (errorBundlePretty config input) $
  parseWithConfig config p input

-- | Runs a parser on a given string printing error messages to standard
-- error (stderr) like `parseImproved` but with much worse error messages
-- for @Parser Char@. `parseImproved` is always preferable to `parse`.
--
-- Notice that, when using `parse`, you might need to add `Ord` and `Show`
-- constraints to your own functions and ensure your own data types are
-- @deriving (`Ord`, `Show`)@.
parse :: (Show s, Ord s) => Parser s a -> [s] -> [(a, [s])]
parse = parseAndTrace defaultConfig