{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Text.Megaparsec.Custom (
  -- * Custom parse error type
  CustomErr,

  -- * Constructing custom parse errors
  parseErrorAt,
  parseErrorAtRegion,
  withSource,

  -- * Pretty-printing custom parse errors
  customParseErrorPretty,


  -- * Final parse error types
  FinalParseError,
  FinalParseError',
  FinalParseErrorBundle,
  FinalParseErrorBundle',

  -- * Constructing final parse errors
  errorFinal,
  finalFancyFailure,
  finalFail,
  finalCustomFailure,

  -- * Handling errors from include files with final parse errors
  parseIncludeFile,
  attachSource,

  -- * Pretty-printing final parse errors
  finalParseErrorPretty,
)
where

import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile)

import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Foldable (asum, toList)
import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as S
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec


--- * Custom parse error type

-- | A custom error type for the parser. The type is specialized to
-- parsers of 'Text' streams.

data CustomErr
  -- | Fail with a message at a specific source position interval. The
  -- interval must be contained within a single line.
  = ErrorFailAt SourcePos -- Starting position
                Pos -- Ending position (column; same line as start)
                String -- Error message
  -- | Attach a source file to a parse error (for error reporting from
  -- include files, e.g. with the 'region' parser combinator)
  | ErrorWithSource Text -- Source file contents
                    (ParseError Char CustomErr) -- The original
  deriving (Show, Eq, Ord)

-- We require an 'Ord' instance for 'CustomError' so that they may be
-- stored in a 'Set'. The actual instance is inconsequential, so we just
-- derive it, but this requires an (orphan) instance for 'ParseError'.
-- Hopefully this does not cause any trouble.

deriving instance (Ord c, Ord e) => Ord (ParseError c e)

instance ShowErrorComponent CustomErr where
  showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
  showErrorComponent (ErrorWithSource _ e) = parseErrorTextPretty e


--- * Constructing custom parse errors

-- | Fail at a specific source position.

parseErrorAt :: SourcePos -> String -> CustomErr
parseErrorAt pos msg = ErrorFailAt pos (sourceColumn pos) msg

-- | Fail at a specific source interval (within a single line). The
-- interval is inclusive on the left and exclusive on the right; that is,
-- it spans from the start position to just before (and not including) the
-- end position.

parseErrorAtRegion
  :: SourcePos -- ^ Start position
  -> SourcePos -- ^ End position
  -> String    -- ^ Error message
  -> CustomErr
parseErrorAtRegion startPos endPos msg =
  let startCol = sourceColumn startPos
      endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos
      endCol = if startCol <= endCol'
                    && sourceLine startPos == sourceLine endPos
               then endCol' else startCol
  in  ErrorFailAt startPos endCol msg

-- | Attach a source file to a parse error. Intended for use with the
-- 'region' parser combinator.

withSource :: Text -> ParseError Char CustomErr -> ParseError Char CustomErr
withSource s e =
  FancyError (errorPos e) $ S.singleton $ ErrorCustom $ ErrorWithSource s e


--- * Pretty-printing custom parse errors

-- | Pretty-print our custom parse errors and display the line on which
-- the parse error occured. Use this instead of 'parseErrorPretty'.
--
-- If any custom errors are present, arbitrarily take the first one (since
-- only one custom error should be used at a time).

customParseErrorPretty :: Text -> ParseError Char CustomErr -> String
customParseErrorPretty source err = case findCustomError err of
  Nothing -> customParseErrorPretty' source err pos1

  Just (ErrorWithSource customSource customErr) ->
    customParseErrorPretty customSource customErr

  Just (ErrorFailAt sourcePos col errMsg) ->
    let newPositionStack = sourcePos NE.:| NE.tail (errorPos err)
        errorIntervalLength = mkPos $ max 1 $
          unPos col - unPos (sourceColumn sourcePos) + 1

        newErr :: ParseError Char Void
        newErr = FancyError newPositionStack (S.singleton (ErrorFail errMsg))

    in  customParseErrorPretty' source newErr errorIntervalLength

  where
    findCustomError :: ParseError Char CustomErr -> Maybe CustomErr
    findCustomError err = case err of
      FancyError _ errSet -> 
        finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
      _ -> Nothing

    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b
    finds f = asum . map f . toList


--- * Final parse error types

-- | A parse error type intended for throwing parse errors without the
-- possiblity of backtracking. Intended for use as the error type in an
-- 'ExceptT' layer of the parser.
--
-- In order to pretty-print a parse error, we must bundle it with the
-- source text and its filepaths (the 'ErrorBundle' constructor). However,
-- when an error is thrown from within a parser, we do not have access to
-- the (full) source, so we must hold the parse error until it can be
-- joined with the source text and its filepath by the parser's caller
-- (the 'ErrorFinal' constructor).

data FinalParseError' e
  = ErrorFinal  (ParseError Char e)
  | ErrorBundle (FinalParseErrorBundle' e)
  deriving (Show)

type FinalParseError = FinalParseError' CustomErr

-- A 'Monoid' instance is necessary for 'ExceptT (FinalParseError'' e)' to
-- be an instance of Alternative and MonadPlus, which are required for the
-- use of e.g. the 'many' parser combinator. This monoid instance simply
-- takes the first (left-most) error.

instance Semigroup (FinalParseError' e) where
  e <> _ = e

instance Monoid (FinalParseError' e) where
  mempty = ErrorFinal $
    FancyError (initialPos "" NE.:| [])
               (S.singleton (ErrorFail "default parse error"))
  mappend = (<>)

-- | A type bundling a 'ParseError' with its source file and a stack of
-- include file paths (for pretty printing). Although Megaparsec 6
-- maintains a stack of source files, making a field of this type
-- redundant, this capability will be removed in Megaparsec 7. Therefore,
-- we implement stacks of source files here for a smoother transition in
-- the future.

data FinalParseErrorBundle' e = FinalParseErrorBundle'
  { finalParseError :: ParseError Char e
  , errorSource     :: Text
  , sourceFileStack :: NE.NonEmpty FilePath
  } deriving (Show)

type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr

--- * Constructing and throwing final parse errors

-- | Convert a "regular" parse error into a "final" parse error.

errorFinal :: ParseError Char e -> FinalParseError' e
errorFinal = ErrorFinal

-- | Like 'fancyFailure', but as a "final" parse error.

finalFancyFailure
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)
  => S.Set (ErrorFancy e) -> m a
finalFancyFailure errSet = do
  pos <- getPosition
  let parseErr = FancyError (pos NE.:| []) errSet
  throwError $ ErrorFinal parseErr

-- | Like 'fail', but as a "final" parse error.

finalFail
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a
finalFail = finalFancyFailure . S.singleton . ErrorFail

-- | Like 'customFailure', but as a "final" parse error.

finalCustomFailure
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a
finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom

--- * Handling errors from include files with "final" parse errors

-- Some care must be taken for sources to be attached to the right parse
-- errors when dealing with include files, so we capture the necessary
-- procedure in this function.

parseIncludeFile
  :: forall st m a. Monad m
  => StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
  -> st
  -> FilePath
  -> Text
  -> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
parseIncludeFile parser initState filepath text =
  catchError parser' handler
  where
    parser' = do
      eResult <- lift $ lift $
                  runParserT (evalStateT parser initState) filepath text
      case eResult of
        Left parseError -> throwError $ errorFinal parseError
        Right result -> pure result

    handler e = throwError $ ErrorBundle $ attachSource filepath text e


attachSource
  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource filePath sourceText finalParseError =
  case finalParseError of
    ErrorFinal parseError -> FinalParseErrorBundle'
      { finalParseError = parseError
      , errorSource     = sourceText
      , sourceFileStack = filePath NE.:| []
      }
    ErrorBundle bundle -> bundle
      { sourceFileStack = filePath NE.<| sourceFileStack bundle
      }

--- * Pretty-printing final parse errors

-- | Pretty-print a "final" parse error: print the stack of include files,
-- then apply the pretty-printer for custom parse errors.

finalParseErrorPretty :: FinalParseErrorBundle' CustomErr -> String
finalParseErrorPretty bundle =
     concatMap printIncludeFile (NE.init (sourceFileStack bundle))
  <> customParseErrorPretty (errorSource bundle) (finalParseError bundle)
  where
    printIncludeFile path = "in file included from " <> path <> ",\n"


--- * Modified Megaparsec source

-- The below code has been copied from Megaparsec (v.6.4.1,
-- Text.Megaparsec.Error) and modified to suit our needs. These changes are
-- indicated by square brackets. The following copyright notice, conditions,
-- and disclaimer apply to all code below this point.
--
-- Copyright © 2015–2018 Megaparsec contributors<br>
-- Copyright © 2007 Paolo Martini<br>
-- Copyright © 1999–2000 Daan Leijen
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- * Redistributions of source code must retain the above copyright notice,
--   this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright notice,
--   this list of conditions and the following disclaimer in the documentation
--   and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
-- NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
-- OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
-- EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


-- | Pretty-print a 'ParseError Char CustomErr' and display the line on
-- which the parse error occurred. The rendered 'String' always ends with
-- a newline.

customParseErrorPretty'
  :: ( ShowToken (Token s)
     , LineToken (Token s)
     , ShowErrorComponent e
     , Stream s )
  => s                 -- ^ Original input stream
  -> ParseError (Token s) e -- ^ Parse error to render
  -> Pos               -- ^ Length of error interval [added]
  -> String            -- ^ Result of rendering
customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth


customParseErrorPretty_
  :: forall s e.
     ( ShowToken (Token s)
     , LineToken (Token s)
     , ShowErrorComponent e
     , Stream s )
  => Pos               -- ^ Tab width
  -> s                 -- ^ Original input stream
  -> ParseError (Token s) e -- ^ Parse error to render
  -> Pos               -- ^ Length of error interval [added]
  -> String            -- ^ Result of rendering
customParseErrorPretty_ w s e l =
  sourcePosStackPretty (errorPos e) <> ":\n" <>
    padding <> "|\n" <>
    lineNumber <> " | " <> rline <> "\n" <>
    padding <> "| " <> rpadding <> highlight <> "\n" <> -- [added `highlight`]
    parseErrorTextPretty e
  where
    epos       = NE.head (errorPos e) -- [changed from NE.last to NE.head]
    lineNumber = (show . unPos . sourceLine) epos
    padding    = replicate (length lineNumber + 1) ' '
    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '
    highlight  = replicate (unPos l) '^' -- [added]
    rline      =
      case rline' of
        [] -> "<empty line>"
        xs -> expandTab w xs
    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
      selectLine (sourceLine epos) s

-- | Select a line from input stream given its number.

selectLine
  :: forall s. (LineToken (Token s), Stream s)
  => Pos               -- ^ Number of line to select
  -> s                 -- ^ Input stream
  -> Tokens s          -- ^ Selected line
selectLine l = go pos1
  where
    go !n !s =
      if n == l
        then fst (takeWhile_ notNewline s)
        else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))
    notNewline = not . tokenIsNewline
    stripNewline s =
      case take1_ s of
        Nothing -> s
        Just (_, s') -> s'

-- | Replace tab characters with given number of spaces.

expandTab
  :: Pos
  -> String
  -> String
expandTab w' = go 0
  where
    go 0 []        = []
    go 0 ('\t':xs) = go w xs
    go 0 (x:xs)    = x : go 0 xs
    go !n xs       = ' ' : go (n - 1) xs
    w              = unPos w'