{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-}
#include "portable-unlifted.h"
{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where

import Prelude hiding (lines)

import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|))
import Data.Set (Set)
import Data.Set qualified as Set (empty, map, union, null, foldr, insert)

import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token)
import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..))
import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..))

CPP_import_PortableUnlifted

type Span :: *
type Span = Word

type CaretWidth :: UnliftedDatatype
data CaretWidth = FlexibleCaret { CaretWidth -> Span
width :: {-# UNPACK #-} !Span }
                | RigidCaret { width :: {-# UNPACK #-} !Span }

isFlexible :: CaretWidth -> Bool
isFlexible :: CaretWidth -> Bool
isFlexible FlexibleCaret{} = Bool
True
isFlexible CaretWidth
_               = Bool
False

type ParseError :: UnliftedDatatype
data ParseError = VanillaError { ParseError -> Span
presentationOffset :: {-# UNPACK #-} !Word
                               , ParseError -> Span
line :: {-# UNPACK #-} !Word
                               , ParseError -> Span
col :: {-# UNPACK #-} !Word
                               , ParseError -> Either Span UnexpectItem
unexpected :: !(Either Word UnexpectItem) -- TODO: unlift this!
                               -- sadly, this prevents unlifting of ExpectItem
                               -- perhaps we should make an unlifted+levity polymorphic Set?
                               , ParseError -> Set ExpectItem
expecteds :: !(Set ExpectItem)
                               , ParseError -> Set String
reasons :: !(Set String)
                               , ParseError -> Bool
lexicalError :: !Bool -- TODO: strict bools
                               -- TODO: remove:
                               , ParseError -> Span
underlyingOffset :: {-# UNPACK #-} !Word
                               , ParseError -> Span
entrenchment :: {-# UNPACK #-} !Word
                               }
                | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word
                                   , line :: {-# UNPACK #-} !Word
                                   , col :: {-# UNPACK #-} !Word
                                   , ParseError -> [String]
msgs :: ![String]
                                   --, caretWidth :: {-# UNPACK #-} !Span --FIXME: need defunc before this goes away
                                   , ParseError -> CaretWidth
caretWidth :: CaretWidth
                                   -- TODO: remove:
                                   , underlyingOffset :: {-# UNPACK #-} !Word
                                   , entrenchment :: {-# UNPACK #-} !Word
                                   }

type Input :: *
type Input = NonEmpty Char
type UnexpectItem :: *
data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word
                  | UnexpectNamed !String CaretWidth
                  | UnexpectEndOfInput
type ExpectItem :: *
data ExpectItem = ExpectRaw !String
                | ExpectNamed !String
                | ExpectEndOfInput
                deriving stock (ExpectItem -> ExpectItem -> Bool
(ExpectItem -> ExpectItem -> Bool)
-> (ExpectItem -> ExpectItem -> Bool) -> Eq ExpectItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExpectItem -> ExpectItem -> Bool
== :: ExpectItem -> ExpectItem -> Bool
$c/= :: ExpectItem -> ExpectItem -> Bool
/= :: ExpectItem -> ExpectItem -> Bool
Eq, Eq ExpectItem
Eq ExpectItem =>
(ExpectItem -> ExpectItem -> Ordering)
-> (ExpectItem -> ExpectItem -> Bool)
-> (ExpectItem -> ExpectItem -> Bool)
-> (ExpectItem -> ExpectItem -> Bool)
-> (ExpectItem -> ExpectItem -> Bool)
-> (ExpectItem -> ExpectItem -> ExpectItem)
-> (ExpectItem -> ExpectItem -> ExpectItem)
-> Ord ExpectItem
ExpectItem -> ExpectItem -> Bool
ExpectItem -> ExpectItem -> Ordering
ExpectItem -> ExpectItem -> ExpectItem
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExpectItem -> ExpectItem -> Ordering
compare :: ExpectItem -> ExpectItem -> Ordering
$c< :: ExpectItem -> ExpectItem -> Bool
< :: ExpectItem -> ExpectItem -> Bool
$c<= :: ExpectItem -> ExpectItem -> Bool
<= :: ExpectItem -> ExpectItem -> Bool
$c> :: ExpectItem -> ExpectItem -> Bool
> :: ExpectItem -> ExpectItem -> Bool
$c>= :: ExpectItem -> ExpectItem -> Bool
>= :: ExpectItem -> ExpectItem -> Bool
$cmax :: ExpectItem -> ExpectItem -> ExpectItem
max :: ExpectItem -> ExpectItem -> ExpectItem
$cmin :: ExpectItem -> ExpectItem -> ExpectItem
min :: ExpectItem -> ExpectItem -> ExpectItem
Ord, Int -> ExpectItem -> ShowS
[ExpectItem] -> ShowS
ExpectItem -> String
(Int -> ExpectItem -> ShowS)
-> (ExpectItem -> String)
-> ([ExpectItem] -> ShowS)
-> Show ExpectItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExpectItem -> ShowS
showsPrec :: Int -> ExpectItem -> ShowS
$cshow :: ExpectItem -> String
show :: ExpectItem -> String
$cshowList :: [ExpectItem] -> ShowS
showList :: [ExpectItem] -> ShowS
Show)

entrenched :: ParseError -> Bool
entrenched :: ParseError -> Bool
entrenched ParseError
err = ParseError -> Span
entrenchment ParseError
err Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
/= Span
0

emptyErr :: Word -> Word -> Word -> Word -> ParseError
emptyErr :: Span -> Span -> Span -> Span -> ParseError
emptyErr !Span
presentationOffset !Span
line !Span
col !Span
width = VanillaError {
    presentationOffset :: Span
presentationOffset = Span
presentationOffset,
    line :: Span
line = Span
line,
    col :: Span
col = Span
col,
    unexpected :: Either Span UnexpectItem
unexpected = Span -> Either Span UnexpectItem
forall a b. a -> Either a b
Left Span
width,
    expecteds :: Set ExpectItem
expecteds = Set ExpectItem
forall a. Set a
Set.empty,
    reasons :: Set String
reasons = Set String
forall a. Set a
Set.empty,
    lexicalError :: Bool
lexicalError = Bool
False,
    underlyingOffset :: Span
underlyingOffset = Span
presentationOffset,
    entrenchment :: Span
entrenchment = Span
0
  }

expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> ParseError
expectedErr :: String
-> Span -> Span -> Span -> Set ExpectItem -> Span -> ParseError
expectedErr !String
input !Span
presentationOffset !Span
line !Span
col !Set ExpectItem
expecteds !Span
width = VanillaError {
    presentationOffset :: Span
presentationOffset = Span
presentationOffset,
    line :: Span
line = Span
line,
    col :: Span
col = Span
col,
    unexpected :: Either Span UnexpectItem
unexpected = case String -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty String
input of
      Maybe (NonEmpty Char)
Nothing -> UnexpectItem -> Either Span UnexpectItem
forall a b. b -> Either a b
Right UnexpectItem
UnexpectEndOfInput
      Just NonEmpty Char
cs -> UnexpectItem -> Either Span UnexpectItem
forall a b. b -> Either a b
Right (NonEmpty Char -> Span -> UnexpectItem
UnexpectRaw NonEmpty Char
cs Span
width),
    expecteds :: Set ExpectItem
expecteds = Set ExpectItem
expecteds,
    reasons :: Set String
reasons = Set String
forall a. Set a
Set.empty,
    lexicalError :: Bool
lexicalError = Bool
False,
    underlyingOffset :: Span
underlyingOffset = Span
presentationOffset,
    entrenchment :: Span
entrenchment = Span
0
}

specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> ParseError
specialisedErr :: Span -> Span -> Span -> [String] -> CaretWidth -> ParseError
specialisedErr !Span
presentationOffset !Span
line !Span
col ![String]
msgs CaretWidth
caretWidth = SpecialisedError {[String]
Span
CaretWidth
presentationOffset :: Span
line :: Span
col :: Span
underlyingOffset :: Span
entrenchment :: Span
msgs :: [String]
caretWidth :: CaretWidth
presentationOffset :: Span
line :: Span
col :: Span
msgs :: [String]
caretWidth :: CaretWidth
underlyingOffset :: Span
entrenchment :: Span
..}
  where !underlyingOffset :: Span
underlyingOffset = Span
presentationOffset
        !entrenchment :: Span
entrenchment = Span
0 :: Word

unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> ParseError
unexpectedErr :: Span
-> Span
-> Span
-> Set ExpectItem
-> String
-> CaretWidth
-> ParseError
unexpectedErr !Span
presentationOffset !Span
line !Span
col !Set ExpectItem
expecteds !String
name CaretWidth
caretWidth = VanillaError {
    presentationOffset :: Span
presentationOffset = Span
presentationOffset,
    line :: Span
line = Span
line,
    col :: Span
col = Span
col,
    expecteds :: Set ExpectItem
expecteds = Set ExpectItem
expecteds,
    unexpected :: Either Span UnexpectItem
unexpected = UnexpectItem -> Either Span UnexpectItem
forall a b. b -> Either a b
Right (String -> CaretWidth -> UnexpectItem
UnexpectNamed String
name CaretWidth
caretWidth),
    reasons :: Set String
reasons = Set String
forall a. Set a
Set.empty,
    lexicalError :: Bool
lexicalError = Bool
False,
    underlyingOffset :: Span
underlyingOffset = Span
presentationOffset,
    entrenchment :: Span
entrenchment = Span
0
  }

labelErr :: Word -> Set String -> ParseError -> ParseError
labelErr :: Span -> Set String -> ParseError -> ParseError
labelErr !Span
offset Set String
expecteds err :: ParseError
err@VanillaError{}
  | Span
offset Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== ParseError -> Span
presentationOffset ParseError
err = ParseError
err { expecteds = Set.map ExpectNamed expecteds }
labelErr Span
_ Set String
_ ParseError
err = ParseError
err

explainErr :: Word -> String -> ParseError -> ParseError
explainErr :: Span -> String -> ParseError -> ParseError
explainErr !Span
offset String
reason err :: ParseError
err@VanillaError{}
  | Span
offset Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== ParseError -> Span
presentationOffset ParseError
err = String -> ParseError -> ParseError
addReason String
reason ParseError
err
explainErr Span
_ String
_ ParseError
err = ParseError
err

addReason :: String -> ParseError -> ParseError
addReason :: String -> ParseError -> ParseError
addReason String
reason err :: ParseError
err@VanillaError{} = ParseError
err { reasons = Set.insert reason (reasons err) }
addReason String
_ ParseError
err = ParseError
err

amendErr :: Word -> Word -> Word -> ParseError -> ParseError
amendErr :: Span -> Span -> Span -> ParseError -> ParseError
amendErr !Span
offset !Span
line !Span
col ParseError
err
  | Bool -> Bool
not (ParseError -> Bool
entrenched ParseError
err) = ParseError
err {
      presentationOffset = offset,
      underlyingOffset = offset,
      line = line,
      col = col
    }
amendErr Span
_ Span
_ Span
_ ParseError
err = ParseError
err

partialAmendErr :: Word -> Word -> Word -> ParseError -> ParseError
partialAmendErr :: Span -> Span -> Span -> ParseError -> ParseError
partialAmendErr !Span
offset !Span
line !Span
col ParseError
err
  | Bool -> Bool
not (ParseError -> Bool
entrenched ParseError
err) =  ParseError
err {
      presentationOffset = offset,
      line = line,
      col = col
    }
partialAmendErr Span
_ Span
_ Span
_ ParseError
err = ParseError
err

entrenchErr :: ParseError -> ParseError
entrenchErr :: ParseError -> ParseError
entrenchErr ParseError
err = ParseError
err { entrenchment = entrenchment err + 1 }

dislodgeErr :: Word -> ParseError -> ParseError
dislodgeErr :: Span -> ParseError -> ParseError
dislodgeErr Span
by ParseError
err
  | ParseError -> Span
entrenchment ParseError
err Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== Span
0  = ParseError
err
  -- this case is important to avoid underflow on the unsigned Word
  | Span
by Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
>= ParseError -> Span
entrenchment ParseError
err = ParseError
err { entrenchment = 0 }
  | Bool
otherwise              = ParseError
err { entrenchment = entrenchment err - by }

setLexical :: ParseError -> ParseError
setLexical :: ParseError -> ParseError
setLexical err :: ParseError
err@VanillaError{} = ParseError
err { lexicalError = True }
setLexical ParseError
err = ParseError
err

useHints :: Set ExpectItem -> ParseError -> ParseError
useHints :: Set ExpectItem -> ParseError -> ParseError
useHints !Set ExpectItem
hints err :: ParseError
err@VanillaError{Set ExpectItem
expecteds :: ParseError -> Set ExpectItem
expecteds :: Set ExpectItem
expecteds} = ParseError
err { expecteds = Set.union hints expecteds }
useHints Set ExpectItem
_ ParseError
err = ParseError
err

mergeErr :: ParseError -> ParseError -> ParseError
mergeErr :: ParseError -> ParseError -> ParseError
mergeErr ParseError
err1 ParseError
err2
  | ParseError -> Span
underlyingOffset ParseError
err1 Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
> ParseError -> Span
underlyingOffset ParseError
err2 = ParseError
err1
  | ParseError -> Span
underlyingOffset ParseError
err1 Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
< ParseError -> Span
underlyingOffset ParseError
err2 = ParseError
err2
  | ParseError -> Span
presentationOffset ParseError
err1 Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
> ParseError -> Span
presentationOffset ParseError
err2 = ParseError
err1
  | ParseError -> Span
presentationOffset ParseError
err1 Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
< ParseError -> Span
presentationOffset ParseError
err2 = ParseError
err2
-- offsets are all equal, kinds must match
mergeErr err1 :: ParseError
err1@SpecialisedError{CaretWidth
caretWidth :: ParseError -> CaretWidth
caretWidth :: CaretWidth
caretWidth} _err2 :: ParseError
_err2@VanillaError{}
  | CaretWidth -> Bool
isFlexible CaretWidth
caretWidth = ParseError
err1 -- TODO: flexible caret merging from err2
  | Bool
otherwise             = ParseError
err1
mergeErr _err1 :: ParseError
_err1@VanillaError{} err2 :: ParseError
err2@SpecialisedError{CaretWidth
caretWidth :: ParseError -> CaretWidth
caretWidth :: CaretWidth
caretWidth}
  | CaretWidth -> Bool
isFlexible CaretWidth
caretWidth = ParseError
err2 -- TODO: flexible caret merging from err1
  | Bool
otherwise             = ParseError
err2
mergeErr err1 :: ParseError
err1@VanillaError{} err2 :: ParseError
err2@VanillaError{} =
  ParseError
err1 { unexpected = mergeUnexpect (unexpected err1) (unexpected err2)
       , expecteds = Set.union (expecteds err1) (expecteds err2)
       , reasons = Set.union (reasons err1) (reasons err2)
       , lexicalError = lexicalError err1 || lexicalError err2
       }
mergeErr err1 :: ParseError
err1@SpecialisedError{} err2 :: ParseError
err2@SpecialisedError{} =
  ParseError
err1 { msgs = msgs err1 ++ msgs err2
       , caretWidth = mergeCaret (caretWidth err1) (caretWidth err2)
       }

mergeCaret :: CaretWidth -> CaretWidth -> CaretWidth
mergeCaret :: CaretWidth -> CaretWidth -> CaretWidth
mergeCaret caret :: CaretWidth
caret@RigidCaret{} FlexibleCaret{} = CaretWidth
caret
mergeCaret FlexibleCaret{} caret :: CaretWidth
caret@RigidCaret{} = CaretWidth
caret
mergeCaret CaretWidth
caret1 CaretWidth
caret2 = CaretWidth
caret1 { width = max (width caret1) (width caret2) }

mergeUnexpect :: Either Word UnexpectItem -> Either Word UnexpectItem -> Either Word UnexpectItem
mergeUnexpect :: Either Span UnexpectItem
-> Either Span UnexpectItem -> Either Span UnexpectItem
mergeUnexpect (Left Span
w1) (Left Span
w2) = Span -> Either Span UnexpectItem
forall a b. a -> Either a b
Left (Span -> Span -> Span
forall a. Ord a => a -> a -> a
max Span
w1 Span
w2)
-- TODO: widening can occur with flexible or raw tokens
mergeUnexpect Left{} w :: Either Span UnexpectItem
w@Right{} = Either Span UnexpectItem
w
mergeUnexpect w :: Either Span UnexpectItem
w@Right{} Left{} = Either Span UnexpectItem
w
-- finally, two others will merge independently
mergeUnexpect (Right UnexpectItem
item1) (Right UnexpectItem
item2) = UnexpectItem -> Either Span UnexpectItem
forall a b. b -> Either a b
Right (UnexpectItem -> UnexpectItem -> UnexpectItem
mergeItem UnexpectItem
item1 UnexpectItem
item2)
  where mergeItem :: UnexpectItem -> UnexpectItem -> UnexpectItem
mergeItem UnexpectItem
UnexpectEndOfInput UnexpectItem
_ = UnexpectItem
UnexpectEndOfInput
        mergeItem UnexpectItem
_ UnexpectItem
UnexpectEndOfInput = UnexpectItem
UnexpectEndOfInput
        mergeItem it1 :: UnexpectItem
it1@(UnexpectNamed String
_ CaretWidth
cw1) it2 :: UnexpectItem
it2@(UnexpectNamed String
_ CaretWidth
cw2)
          | CaretWidth -> Bool
isFlexible CaretWidth
cw1, Bool -> Bool
not (CaretWidth -> Bool
isFlexible CaretWidth
cw2) = UnexpectItem
it2
          | Bool -> Bool
not (CaretWidth -> Bool
isFlexible CaretWidth
cw1), CaretWidth -> Bool
isFlexible CaretWidth
cw2 = UnexpectItem
it1
          | CaretWidth -> Span
width CaretWidth
cw1 Span -> Span -> Bool
forall a. Ord a => a -> a -> Bool
< CaretWidth -> Span
width CaretWidth
cw2                = UnexpectItem
it2
          | Bool
otherwise                            = UnexpectItem
it1
        mergeItem item :: UnexpectItem
item@UnexpectNamed{} UnexpectItem
_ = UnexpectItem
item
        mergeItem UnexpectItem
_ item :: UnexpectItem
item@UnexpectNamed{} = UnexpectItem
item
        mergeItem (UnexpectRaw NonEmpty Char
cs Span
w1) (UnexpectRaw NonEmpty Char
_ Span
w2) = NonEmpty Char -> Span -> UnexpectItem
UnexpectRaw NonEmpty Char
cs (Span -> Span -> Span
forall a. Ord a => a -> a -> a
max Span
w1 Span
w2)

isExpectedEmpty :: ParseError -> Bool
isExpectedEmpty :: ParseError -> Bool
isExpectedEmpty VanillaError{Set ExpectItem
expecteds :: ParseError -> Set ExpectItem
expecteds :: Set ExpectItem
expecteds} = Set ExpectItem -> Bool
forall a. Set a -> Bool
Set.null Set ExpectItem
expecteds
isExpectedEmpty ParseError
_                       = Bool
True

{-# INLINABLE fromParseError #-}
fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err
fromParseError :: forall err.
ErrorBuilder err =>
Maybe String -> String -> ParseError -> err
fromParseError Maybe String
srcFile String
input ParseError
err =
  Position err -> Source err -> ErrorInfoLines err -> err
forall err.
ErrorBuilder err =>
Position err -> Source err -> ErrorInfoLines err -> err
Builder.format (forall err. ErrorBuilder err => Span -> Span -> Position err
Builder.pos @err (ParseError -> Span
line ParseError
err) (ParseError -> Span
col ParseError
err)) (forall err. ErrorBuilder err => Maybe String -> Source err
Builder.source @err Maybe String
srcFile)
                 (ParseError -> ErrorInfoLines err
formatErr ParseError
err)
  where formatErr :: ParseError -> Builder.ErrorInfoLines err
        formatErr :: ParseError -> ErrorInfoLines err
formatErr VanillaError{Bool
Span
Either Span UnexpectItem
Set String
Set ExpectItem
presentationOffset :: ParseError -> Span
line :: ParseError -> Span
col :: ParseError -> Span
unexpected :: ParseError -> Either Span UnexpectItem
expecteds :: ParseError -> Set ExpectItem
reasons :: ParseError -> Set String
lexicalError :: ParseError -> Bool
underlyingOffset :: ParseError -> Span
entrenchment :: ParseError -> Span
presentationOffset :: Span
line :: Span
col :: Span
unexpected :: Either Span UnexpectItem
expecteds :: Set ExpectItem
reasons :: Set String
lexicalError :: Bool
underlyingOffset :: Span
entrenchment :: Span
..} =
          forall err.
ErrorBuilder err =>
UnexpectedLine err
-> ExpectedLine err
-> Messages err
-> LineInfo err
-> ErrorInfoLines err
Builder.vanillaError @err
            (forall err.
ErrorBuilder err =>
Maybe (Item err) -> UnexpectedLine err
Builder.unexpected @err ((Span -> Maybe (Item err))
-> ((Item err, Span) -> Maybe (Item err))
-> Either Span (Item err, Span)
-> Maybe (Item err)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Item err) -> Span -> Maybe (Item err)
forall a b. a -> b -> a
const Maybe (Item err)
forall a. Maybe a
Nothing) (Item err -> Maybe (Item err)
forall a. a -> Maybe a
Just (Item err -> Maybe (Item err))
-> ((Item err, Span) -> Item err)
-> (Item err, Span)
-> Maybe (Item err)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item err, Span) -> Item err
forall a b. (a, b) -> a
fst) Either Span (Item err, Span)
unexpectedTok))
            (forall err.
ErrorBuilder err =>
ExpectedItems err -> ExpectedLine err
Builder.expected @err (forall err. ErrorBuilder err => Set (Item err) -> ExpectedItems err
Builder.combineExpectedItems @err ((ExpectItem -> Item err) -> Set ExpectItem -> Set (Item err)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ExpectItem -> Item err
expectItem Set ExpectItem
expecteds)))
            (forall err. ErrorBuilder err => [Message err] -> Messages err
Builder.combineMessages @err ((String -> [Message err] -> [Message err])
-> [Message err] -> Set String -> [Message err]
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr (\String
r -> (forall err. ErrorBuilder err => String -> Message err
Builder.reason @err String
r Message err -> [Message err] -> [Message err]
forall a. a -> [a] -> [a]
:)) [] Set String
reasons))
            (forall err.
ErrorBuilder err =>
String -> [String] -> [String] -> Span -> Span -> LineInfo err
Builder.lineInfo @err String
curLine [String]
linesBefore [String]
linesAfter Span
caret (Span -> Span
trimToLine Span
caretSize))
          where unexpectedTok :: Either Span (Item err, Span)
unexpectedTok = Bool -> UnexpectItem -> (Item err, Span)
unexpectItem Bool
lexicalError (UnexpectItem -> (Item err, Span))
-> Either Span UnexpectItem -> Either Span (Item err, Span)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Span UnexpectItem
unexpected
                caretSize :: Span
caretSize = (Span -> Span)
-> ((Item err, Span) -> Span)
-> Either Span (Item err, Span)
-> Span
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Span -> Span
forall a. a -> a
id (Item err, Span) -> Span
forall a b. (a, b) -> b
snd Either Span (Item err, Span)
unexpectedTok

        formatErr SpecialisedError{[String]
Span
CaretWidth
presentationOffset :: ParseError -> Span
line :: ParseError -> Span
col :: ParseError -> Span
underlyingOffset :: ParseError -> Span
entrenchment :: ParseError -> Span
msgs :: ParseError -> [String]
caretWidth :: ParseError -> CaretWidth
presentationOffset :: Span
line :: Span
col :: Span
msgs :: [String]
caretWidth :: CaretWidth
underlyingOffset :: Span
entrenchment :: Span
..} =
          forall err.
ErrorBuilder err =>
Messages err -> LineInfo err -> ErrorInfoLines err
Builder.specialisedError @err
            (forall err. ErrorBuilder err => [Message err] -> Messages err
Builder.combineMessages @err ((String -> Message err) -> [String] -> [Message err]
forall a b. (a -> b) -> [a] -> [b]
map (forall err. ErrorBuilder err => String -> Message err
Builder.message @err) [String]
msgs))
            (forall err.
ErrorBuilder err =>
String -> [String] -> [String] -> Span -> Span -> LineInfo err
Builder.lineInfo @err String
curLine [String]
linesBefore [String]
linesAfter Span
caret (Span -> Span
trimToLine (CaretWidth -> Span
width CaretWidth
caretWidth)))

        expectItem :: ExpectItem -> Builder.Item err
        expectItem :: ExpectItem -> Item err
expectItem (ExpectRaw String
t) = forall err. ErrorBuilder err => String -> Item err
Builder.raw @err String
t
        expectItem (ExpectNamed String
n) = forall err. ErrorBuilder err => String -> Item err
Builder.named @err String
n
        expectItem ExpectItem
ExpectEndOfInput = forall err. ErrorBuilder err => Item err
Builder.endOfInput @err

        unexpectItem :: Bool -> UnexpectItem -> (Builder.Item err, Span)
        unexpectItem :: Bool -> UnexpectItem -> (Item err, Span)
unexpectItem Bool
lexical (UnexpectRaw NonEmpty Char
cs Span
demanded) =
          case forall err.
ErrorBuilder err =>
NonEmpty Char -> Span -> Bool -> Token
Builder.unexpectedToken @err NonEmpty Char
cs Span
demanded Bool
lexical of
            t :: Token
t@(Token.Raw String
tok) -> (forall err. ErrorBuilder err => String -> Item err
Builder.raw @err String
tok, Token -> Span
tokenSpan Token
t)
            Token.Named String
name Span
w -> (forall err. ErrorBuilder err => String -> Item err
Builder.named @err String
name, Span
w)
        unexpectItem Bool
_ (UnexpectNamed String
name CaretWidth
caretWidth) = (forall err. ErrorBuilder err => String -> Item err
Builder.named @err String
name, CaretWidth -> Span
width CaretWidth
caretWidth)
        unexpectItem Bool
_ UnexpectItem
UnexpectEndOfInput = (forall err. ErrorBuilder err => Item err
Builder.endOfInput @err, Span
1)

        -- it is definitely the case that there are at least `line` lines
        ([String]
allLinesBefore, String
curLine, [String]
allLinesAfter) = Span -> NonEmpty String -> ([String], String, [String])
breakLines (ParseError -> Span
line ParseError
err Span -> Span -> Span
forall a. Num a => a -> a -> a
- Span
1) (String -> NonEmpty String
lines String
input)
        linesBefore :: [String]
linesBefore = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
allLinesBefore Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall err. ErrorBuilder err => Int
Builder.numLinesBefore @err) [String]
allLinesBefore
        linesAfter :: [String]
linesAfter = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (forall err. ErrorBuilder err => Int
Builder.numLinesAfter @err) [String]
allLinesAfter

        caret :: Span
caret = ParseError -> Span
col ParseError
err Span -> Span -> Span
forall a. Num a => a -> a -> a
- Span
1
        trimToLine :: Span -> Span
trimToLine Span
width = Span -> Span -> Span
forall a. Ord a => a -> a -> a
min Span
width (Int -> Span
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curLine) Span -> Span -> Span
forall a. Num a => a -> a -> a
- Span
caret Span -> Span -> Span
forall a. Num a => a -> a -> a
+ Span
1)

        lines :: String -> NonEmpty String
        lines :: String -> NonEmpty String
lines [] = String
"" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
        lines (Char
'\n':String
cs) = String
"" String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
<| String -> NonEmpty String
lines String
cs
        lines (Char
c:String
cs) = let String
l :| [String]
ls = String -> NonEmpty String
lines String
cs in (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
l) String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
ls

        breakLines :: Word -> NonEmpty String -> ([String], String, [String])
        breakLines :: Span -> NonEmpty String -> ([String], String, [String])
breakLines Span
0 (String
l :| [String]
ls) = ([], String
l, [String]
ls)
        breakLines Span
n (String
l :| [String]
ls) = case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
ls of
          Maybe (NonEmpty String)
Nothing -> String -> ([String], String, [String])
forall a. HasCallStack => String -> a
error String
"the focus line is guaranteed to exist"
          Just NonEmpty String
ls' -> let ([String]
before, String
focus, [String]
after) = Span -> NonEmpty String -> ([String], String, [String])
breakLines (Span
n Span -> Span -> Span
forall a. Num a => a -> a -> a
- Span
1) NonEmpty String
ls'
                      in (String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
before, String
focus, [String]
after)

        tokenSpan :: Token -> Word
        tokenSpan :: Token -> Span
tokenSpan (Token.Raw String
cs) = Int -> Span
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs)
        tokenSpan (Token.Named String
_ Span
w) = Span
w