{-# options_ghc -Wno-orphans #-}

{-# language UndecidableInstances #-}

module ParseLib.Error where

import Data.Bifunctor (second)
import Data.Either (partitionEithers)
import Data.Foldable (toList)
import Data.List (intercalate, sortOn, stripPrefix)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as N
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import Data.Void (Void)
import Debug.Trace (trace)
import Text.Megaparsec.Error
  ( ErrorFancy (ErrorFail),
    ErrorItem (EndOfInput, Tokens),
  )
import qualified Text.Megaparsec.Error as M
import qualified Text.Megaparsec.ErrorList as ML
import Text.Megaparsec.Pos (SourcePos (SourcePos), mkPos)
import Text.Megaparsec.State (PosState (PosState))
import Text.Megaparsec.Stream (Token)

-- * configuration

data Config =
  Config
    {
      -- | upper limit of positions where to collect errors from. a value
      -- of zero turns off error reporting. a negative value causes all
      -- errors to be reported.
      errorCount :: Int,
      -- | upper limit of symbols to show before the offending symbol
      symbolsBefore :: Int,
      -- | upper limit of symbols to show after the offending symbol
      symbolsAfter :: Int
    }
  deriving (Eq, Ord, Show)

-- | default configuration, setting `errorCount` to 1, `symbolsBefore` to
-- 16, and `symbolsAfter` to 15.
defaultConfig :: Config
defaultConfig =
  Config {errorCount = 1, symbolsBefore = 16, symbolsAfter = 15}

-- | set a configuration's `errorCount`
errorCountSet ::
  -- | new `errorCount`
  Int ->
  Config ->
  Config
errorCountSet errorCount (Config {symbolsBefore, symbolsAfter}) =
  Config {errorCount, symbolsBefore, symbolsAfter}

-- | set a configuration's `symbolsBefore`
symbolsBeforeSet ::
  -- | new `symbolsBefore`
  Int ->
  Config ->
  Config
symbolsBeforeSet symbolsBefore (Config {errorCount, symbolsAfter}) =
  Config {errorCount, symbolsBefore, symbolsAfter}

-- | set a configuration's `symbolsAfter`
symbolsAfterSet ::
  -- | new `symbolsAfter`
  Int ->
  Config ->
  Config
symbolsAfterSet symbolsAfter (Config {errorCount, symbolsBefore}) =
  Config {errorCount, symbolsBefore, symbolsAfter}

-- * parse error bundle

newtype ParseErrorBundle symbols =
  ParseErrorBundle
    [(WithLength symbols, NonEmpty (BundledParseError symbols))]
  deriving (Eq, Ord, Show)

data BundledParseError symbols =
  BundledParseError symbols -- ^ expected
  |
  BundledFail String -- ^ message
  deriving (Eq, Ord, Show)

data WithLength a = WithLength a Int deriving (Eq, Ord, Show)

-- * pretty printing parse error bundles

class (Show symbol) => ErrorsPretty symbol where
  -- | pretty prints a `ParseErrorBundle` like `errorBundlePretty` but
  -- makes error messages bearable for @Parser Char@.
  -- `errorBundlePrettyImproved` is always preferable to
  -- `errorBundlePretty`.
  --
  -- if you see the following GHC error, you usually need to add an
  -- `ErrorsPretty` constraint to your function.
  --
  -- @
  -- Overlapping instances for ErrorsPretty
  -- arising from a use of ‘errorBundlePrettyImproved’
  -- @
  errorBundlePrettyImproved ::
    Config ->
    -- | entire input
    [symbol] ->
    ParseErrorBundle [symbol] ->
    String

-- | an `ErrorsPretty` constraint is automatically fulfilled by `Show`
-- instances.
instance {-# overlappable #-} (Show symbol, Ord symbol) => ErrorsPretty symbol where
  errorBundlePrettyImproved = errorBundlePretty

instance ErrorsPretty Char where
  errorBundlePrettyImproved _ input =
    fromMaybe "" .
    fmap M.errorBundlePretty .
    toMegaparsecBundle input

-- | pretty prints a `ParseErrorBundle` like `errorBundlePrettyImproved`
-- but with much worse error messages for @Parser Char@.
-- `errorBundlePrettyImproved` is always preferable to `errorBundlePretty`.
errorBundlePretty ::
  (Ord symbol, Show symbol) =>
  Config ->
  -- | entire input
  [symbol] ->
  ParseErrorBundle [symbol] ->
  String
errorBundlePretty (Config {symbolsBefore, symbolsAfter}) input (ParseErrorBundle bundle) =
  foldMap
    (\errorBundled@(WithLength _ inputRestLength, _) ->
      let
        position = inputLength - inputRestLength
        symbolsBeforeActual = min symbolsBefore position
        (theSymbolsBefore, theSymbolsAfter) =
          second (take $ 1 + symbolsAfter) $
          splitAt symbolsBeforeActual $
          drop (position - symbolsBeforeActual) $
          input
      in
        "input:" <> show position <> ":\n" <>
        foldMap (\s -> "  " <> show s <> "\n") theSymbolsBefore <>
        ">" <>
        (
          fromMaybe "\n" $
          stripPrefix " " $
          foldMap (\s -> "  " <> show s <> "\n") $
          theSymbolsAfter
        ) <>
        (
          intercalate "\n" $
          fmap ML.parseErrorTextPretty $
          toMegaparsecBundled inputLength $
          errorBundled
        ) <>
        "\n\n"
    )
    bundle
  where
    inputLength :: Int
    inputLength = length input

-- | returns @[]@ in the case of `Left` and prints the `String` to standard
-- error (stderr) using `trace`.
traceErrorMessage :: Either String (NonEmpty (a, [s])) -> [(a, [s])]
traceErrorMessage (Right result) = toList result
traceErrorMessage (Left errorMessage)
  | null errorMessage = []
  | otherwise = trace errorMessage []

-- * unbundled parse error

data ParseError symbols =
  ParseError
    symbols -- ^ expected
    symbols -- ^ actual
  |
  Fail
    String -- ^ message
    symbols -- ^ actual
  deriving (Eq)

toBundle ::
  (Ord s) =>
  [ParseError [s]] -> [(WithLength [s], NonEmpty (BundledParseError [s]))]
toBundle =
  -- [(WithLength [s], NonEmpty (BundledParseError [s]))]
  -- remove duplicates from each `NonEmpty BundledParseError`
  (fmap . second) (fmap N.head . N.group1 . N.sort) .
  -- [(WithLength [s], NonEmpty (BundledParseError [s]))]
  (fmap . second . fmap) toBundled .
  -- [(WithLength [s], NonEmpty (ParseError [s]))]
  fmap (\(n, es@(h :| _)) -> (WithLength (inputRestGet h) n, es)) .
  -- [(Int, NonEmpty (ParseError [s]))]
  groupWithKey (length . inputRestGet)
  -- [ParseError [s]]

-- * utilities

toMegaparsecBundle ::
  (Ord s) =>
  [s] -> ParseErrorBundle [s] -> Maybe (M.ParseErrorBundle [s] Void)
toMegaparsecBundle input (ParseErrorBundle bundle) =
  flip M.ParseErrorBundle
    (PosState
      input
      0
      (SourcePos "input" (mkPos 1) (mkPos 1))
      (mkPos 4)
      ""
    )
    <$> (N.nonEmpty $ foldMap (toMegaparsecBundled $ length input) $ bundle)

toMegaparsecBundled ::
  (Ord s) =>
  Int ->
  (WithLength [s], NonEmpty (BundledParseError [s])) ->
  [M.ParseError [s] Void]
toMegaparsecBundled inputLength (WithLength inputRest inputRestLength, errors) =
  (if null trivialErrors
    then id
    else
      (:)
        (M.TrivialError
          position
          (Just $ toErrorItem $ take (maximum $ (1 :) $ fmap length $ trivialErrors) $ inputRest)
          (S.fromList $ fmap toErrorItem $ trivialErrors)
        )
  ) $
  (if null fancyErrors
    then id
    else (:) (M.FancyError position $ S.fromList $ fmap ErrorFail $ fancyErrors)
  ) $
  []
  where
    fancyErrors :: [String]
    (fancyErrors, trivialErrors) =
      -- ([String], [[s]])
      partitionEithers $
      -- [Either String [s]]
      toList $
      -- NonEmpty (Either String [s])
      fmap
        (\case
          BundledParseError expected -> Right expected
          BundledFail message -> Left message
        ) $
      -- NonEmpty (BundledParseError [s])
      errors
    position :: Int
    position = inputLength - inputRestLength

toErrorItem :: [s] -> ErrorItem (Token [s])
toErrorItem (c : cs) = Tokens (c :| cs)
toErrorItem _ = EndOfInput

toBundled :: ParseError symbols -> BundledParseError symbols
toBundled (ParseError expected _actual) = BundledParseError expected
toBundled (Fail expected _actual) = BundledFail expected

inputRestGet :: ParseError symbols -> symbols
inputRestGet (ParseError _ input) = input
inputRestGet (Fail _ input) = input

groupWithKey :: (Ord b) => (a -> b) -> [a] -> [(b, NonEmpty a)]
groupWithKey f =
  -- [(b, NonEmpty a)]
  (fmap . second . fmap) snd .
  -- [(b, NonEmpty (b, a))]
  fmap (\g@(h :| _) -> (fst h, g)) . -- to do. inelegant ("redundant work")
  -- [NonEmpty (b, a)]
  N.groupWith fst .
  -- [(b, a)]
  sortOn fst .
  -- [(b, a)]
  fmap (\a -> (f a, a))
  -- [a]