{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Text.Megaparsec.Error
-- Copyright   :  © 2015–present Megaparsec contributors
-- License     :  FreeBSD
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Parse errors. The current version of Megaparsec supports typed errors
-- instead of 'String'-based ones. This gives a lot of flexibility in
-- describing what exactly went wrong as well as a way to return arbitrary
-- data in case of failure.
--
-- You probably do not want to import this module directly because
-- "Text.Megaparsec" re-exports it anyway.
module Text.Megaparsec.ErrorList
  ( -- * Parse error type
    ErrorItem (..),
    ErrorFancy (..),
    ParseError (..),
    mapParseError,
    errorOffset,
    setErrorOffset,
    ParseErrorBundle (..),
    attachSourcePos,

    -- * Pretty-printing
    ShowErrorComponent (..),
    parseErrorPretty,
    parseErrorTextPretty,
    showErrorItem,
  )
where

import Control.DeepSeq
import Control.Monad.State.Strict
import Data.Data (Data)
import Data.Foldable (toList)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isNothing)
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as E
import Data.Typeable (Typeable)
import Data.Void
import GHC.Generics
import Text.Megaparsec.Error (ErrorFancy (ErrorCustom, ErrorFail, ErrorIndentation), ErrorItem (EndOfInput, Label, Tokens), ParseError (FancyError, TrivialError))
import Text.Megaparsec.Pos
import Text.Megaparsec.State
import Text.Megaparsec.Stream hiding (VisualStream (..))

----------------------------------------------------------------------------
-- Parse error type

-- | Modify the custom data component in a parse error. This could be done
-- via 'fmap' if not for the 'Ord' constraint.
--
-- @since 7.0.0
mapParseError ::
  (Ord e') =>
  (e -> e') ->
  ParseError s e ->
  ParseError s e'
mapParseError _ (TrivialError o u p) = TrivialError o u p
mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x)

-- | Get the offset of a 'ParseError'.
--
-- @since 7.0.0
errorOffset :: ParseError s e -> Int
errorOffset (TrivialError o _ _) = o
errorOffset (FancyError o _) = o

-- | Set the offset of a 'ParseError'.
--
-- @since 8.0.0
setErrorOffset :: Int -> ParseError s e -> ParseError s e
setErrorOffset o (TrivialError _ u p) = TrivialError o u p
setErrorOffset o (FancyError _ x) = FancyError o x

-- | A non-empty collection of 'ParseError's equipped with 'PosState' that
-- allows us to pretty-print the errors efficiently and correctly.
--
-- @since 7.0.0
data ParseErrorBundle s e = ParseErrorBundle
  { -- | A collection of 'ParseError's that is sorted by parse error offsets
    bundleErrors :: NonEmpty (ParseError s e),
    -- | The state that is used for line\/column calculation
    bundlePosState :: PosState s
  }
  deriving (Generic)

deriving instance
  ( Show s,
    Show (Token s),
    Show e
  ) =>
  Show (ParseErrorBundle s e)

deriving instance
  ( Eq s,
    Eq (Token s),
    Eq e
  ) =>
  Eq (ParseErrorBundle s e)

deriving instance
  ( Typeable s,
    Typeable (Token s),
    Typeable e
  ) =>
  Typeable (ParseErrorBundle s e)

deriving instance
  ( Data s,
    Data (Token s),
    Ord (Token s),
    Data e,
    Ord e
  ) =>
  Data (ParseErrorBundle s e)

instance
  ( NFData s,
    NFData (Token s),
    NFData e
  ) =>
  NFData (ParseErrorBundle s e)

-- | Attach 'SourcePos'es to items in a 'Traversable' container given that
-- there is a projection allowing us to get an offset per item.
--
-- Items must be in ascending order with respect to their offsets.
--
-- @since 7.0.0
attachSourcePos ::
  (Traversable t, TraversableStream s) =>
  -- | How to project offset from an item (e.g. 'errorOffset')
  (a -> Int) ->
  -- | The collection of items
  t a ->
  -- | Initial 'PosState'
  PosState s ->
  -- | The collection with 'SourcePos'es added and the final 'PosState'
  (t (a, SourcePos), PosState s)
attachSourcePos projectOffset xs = runState (traverse f xs)
  where
    f a = do
      pst <- get
      let pst' = reachOffsetNoLine (projectOffset a) pst
      put pst'
      return (a, pstateSourcePos pst')
{-# INLINEABLE attachSourcePos #-}

----------------------------------------------------------------------------
-- Pretty-printing

-- | The type class defines how to print a custom component of 'ParseError'.
--
-- @since 5.0.0
class (Ord a) => ShowErrorComponent a where
  -- | Pretty-print a component of 'ParseError'.
  showErrorComponent :: a -> String

  -- | Length of the error component in characters, used for highlighting of
  -- parse errors in input string.
  --
  -- @since 7.0.0
  errorComponentLen :: a -> Int
  errorComponentLen _ = 1

instance ShowErrorComponent Void where
  showErrorComponent = absurd

-- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a
-- newline.
--
-- @since 5.0.0
parseErrorPretty ::
  (Show (Token s), ShowErrorComponent e) =>
  -- | Parse error to render
  ParseError s e ->
  -- | Result of rendering
  String
parseErrorPretty e =
  "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e

-- | Pretty-print a textual part of a 'ParseError', that is, everything
-- except for its position. The rendered 'String' always ends with a
-- newline.
--
-- @since 5.1.0
parseErrorTextPretty ::
  forall s e.
  (Show (Token s), ShowErrorComponent e) =>
  -- | Parse error to render
  ParseError s e ->
  -- | Result of rendering
  String
parseErrorTextPretty (TrivialError _ us ps) =
  if isNothing us && E.null ps
    then "unknown parse error\n"
    else
      messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us)
        <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps)
  where
    pxy = Proxy :: Proxy s
parseErrorTextPretty (FancyError _ xs) =
  if E.null xs
    then "unknown fancy parse error\n"
    else unlines (showErrorFancy <$> E.toAscList xs)

----------------------------------------------------------------------------
-- Helpers

-- | Pretty-print an 'ErrorItem'.
--
-- @since 9.4.0
showErrorItem :: (Show (Token s)) => Proxy s -> ErrorItem (Token s) -> String
showErrorItem pxy = \case
  Tokens ts -> showTokens pxy ts
  Label label -> NE.toList label
  EndOfInput -> "end of input"

-- | Pretty-print an 'ErrorFancy'.
showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String
showErrorFancy = \case
  ErrorFail msg -> msg
  ErrorIndentation ord ref actual ->
    "incorrect indentation (got "
      <> show (unPos actual)
      <> ", should be "
      <> p
      <> show (unPos ref)
      <> ")"
    where
      p = case ord of
        LT -> "less than "
        EQ -> "equal to "
        GT -> "greater than "
  ErrorCustom a -> showErrorComponent a

-- | Transform a list of error messages into their textual representation.
messageItemsPretty ::
  -- | Prefix to prepend
  String ->
  -- | Collection of messages
  Set String ->
  -- | Result of rendering
  String
messageItemsPretty prefix ts
  | E.null ts = ""
  | otherwise =
      prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n"

-- | Print a pretty list where items are separated with commas and the word
-- “or” according to the rules of English punctuation.
orList :: NonEmpty String -> String
orList (x :| []) = x
orList (x :| [y]) = x <> " or " <> y
orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs

----------------------------------------------------------------------------
-- visual stream

showTokens :: (Show (Token s)) => Proxy s -> NonEmpty (Token s) -> String
showTokens _ =
  (("'" <>) . (<> "'")) .
  intercalate " " .
  fmap (("(" <>) . (<> ")")) .
  fmap show .
  toList