{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Text.Megaparsec.Custom (
CustomErr,
parseErrorAt,
parseErrorAtRegion,
withSource,
customParseErrorPretty
)
where
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile)
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
data CustomErr
= ErrorFailAt SourcePos
Pos
String
| ErrorWithSource Text
(ParseError Char CustomErr)
deriving (Show, Eq, Ord)
deriving instance (Ord c, Ord e) => Ord (ParseError c e)
instance ShowErrorComponent CustomErr where
showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
showErrorComponent (ErrorWithSource _ e) = parseErrorTextPretty e
parseErrorAt :: MonadParsec CustomErr s m => SourcePos -> String -> m a
parseErrorAt pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg)
{-# INLINABLE parseErrorAt #-}
parseErrorAtRegion
:: MonadParsec CustomErr s m
=> SourcePos
-> SourcePos
-> String
-> m a
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 customFailure (ErrorFailAt startPos endCol msg)
{-# INLINABLE parseErrorAtRegion #-}
withSource :: Text -> ParseError Char CustomErr -> ParseError Char CustomErr
withSource s e =
FancyError (errorPos e) $ S.singleton $ ErrorCustom $ ErrorWithSource s e
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
customParseErrorPretty'
:: ( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> s
-> ParseError (Token s) e
-> Pos
-> String
customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth
customParseErrorPretty_
:: forall s e.
( ShowToken (Token s)
, LineToken (Token s)
, ShowErrorComponent e
, Stream s )
=> Pos
-> s
-> ParseError (Token s) e
-> Pos
-> String
customParseErrorPretty_ w s e l =
sourcePosStackPretty (errorPos e) <> ":\n" <>
padding <> "|\n" <>
lineNumber <> " | " <> rline <> "\n" <>
padding <> "| " <> rpadding <> highlight <> "\n" <>
parseErrorTextPretty e
where
epos = NE.head (errorPos e)
lineNumber = (show . unPos . sourceLine) epos
padding = replicate (length lineNumber + 1) ' '
rpadding = replicate (unPos (sourceColumn epos) - 1) ' '
highlight = replicate (unPos l) '^'
rline =
case rline' of
[] -> "<empty line>"
xs -> expandTab w xs
rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $
selectLine (sourceLine epos) s
selectLine
:: forall s. (LineToken (Token s), Stream s)
=> Pos
-> s
-> Tokens s
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'
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'