{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GADTs, DataKinds, UnboxedTuples, PatternSynonyms, CPP #-}
{-# OPTIONS_HADDOCK hide #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire
{-# OPTIONS_GHC -Wno-redundant-strictness-flags -Wno-missing-kind-signatures #-}
#include "portable-unlifted.h"
module Text.Gigaparsec.Internal.Errors.DefuncBuilders (
    asParseError
  ) where

import Text.Gigaparsec.Internal.Errors.DefuncTypes (
    DefuncHints(Blank, AddErr, Replace),
    ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason, AdjustCaret),
    BaseError(Unexpected, Empty, Expected, ClassicSpecialised),
    DefuncError_(Op, Base),
    DefuncError(DefuncError, presentationOffset, errKind, errTy),
    ErrKindSingleton(IsSpecialised, IsVanilla),
    ErrKind(Vanilla, Specialised),
    expecteds, unexpectedWidth
  )
import Text.Gigaparsec.Internal.Errors.ParseError (ParseError(VanillaError, SpecialisedError))
import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, width), isFlexible)
import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical)
import Text.Gigaparsec.Internal.Errors.ErrorItem (
    ExpectItem(ExpectNamed),
    UnexpectItem(UnexpectEndOfInput, UnexpectNamed, UnexpectRaw)
  )

import Data.Set (Set)
import Data.Set qualified as Set (empty, insert, union, member, map)
import Data.List.NonEmpty (nonEmpty)

CPP_import_PortableUnlifted

asParseError :: String -> DefuncError -> ParseError
asParseError :: String -> DefuncError -> ParseError
asParseError !String
input e :: DefuncError
e@DefuncError{Word
DefuncError_ k
ErrKindSingleton k
presentationOffset :: DefuncError -> Word
errKind :: ()
errTy :: ()
errKind :: ErrKindSingleton k
presentationOffset :: Word
errTy :: DefuncError_ k
..} = case ErrKindSingleton k
errKind of
  ErrKindSingleton k
IsVanilla -> case Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
0 Word
0 Set ExpectItem
forall a. Set a
Set.empty (Word -> BuilderUnexpectItem
NoItem Word
0) Set String
forall a. Set a
Set.empty Bool
True DefuncError_ k
DefuncError_ 'Vanilla
errTy of
    (# Word
line, Word
col, Set ExpectItem
exs, BuilderUnexpectItem
unex, Set String
reasons #) ->
      Word
-> Word
-> Word
-> Either Word UnexpectItem
-> Set ExpectItem
-> Set String
-> Bool
-> ParseError
VanillaError Word
presentationOffset Word
line Word
col (String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem
toErrorItem String
input Word
presentationOffset BuilderUnexpectItem
unex) Set ExpectItem
exs Set String
reasons (DefuncError -> Bool
isLexical DefuncError
e)
  ErrKindSingleton k
IsSpecialised -> case Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec Word
0 Word
0 Word
0 Bool
True [String] -> [String]
forall a. a -> a
id DefuncError_ k
DefuncError_ 'Specialised
errTy of
    (# Word
line, Word
col, Word
width, Bool
_, [String] -> [String]
dmsgs #) ->
      Word -> Word -> Word -> [String] -> Word -> ParseError
SpecialisedError Word
presentationOffset Word
line Word
col ([String] -> [String]
forall a. Ord a => [a] -> [a]
distinct ([String] -> [String]
dmsgs [])) Word
width
  where
    !outOfRange :: Bool
outOfRange = Word
presentationOffset Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word
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
input)

    makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool
                -> DefuncError_ 'Vanilla
                -> (# Word, Word, Set ExpectItem, BuilderUnexpectItem, Set String #)
    makeVanilla :: Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla !Word
_ !Word
_ !Set ExpectItem
exs BuilderUnexpectItem
unex !Set String
reasons !Bool
acceptingExpected (Base Word
line Word
col BaseError 'Vanilla
err) =
      case BaseError 'Vanilla
err of
        Empty Word
unexWidth ->
          (# Word
line, Word
col, Set ExpectItem
exs, Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateEmptyUnexpected Word
unexWidth BuilderUnexpectItem
unex, Set String
reasons #)
        Expected Set ExpectItem
exs' Word
unexWidth ->
          (# Word
line, Word
col, Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem
addLabels Bool
acceptingExpected Set ExpectItem
exs Set ExpectItem
exs', Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected Bool
outOfRange Word
unexWidth BuilderUnexpectItem
unex, Set String
reasons #)
        Unexpected Set ExpectItem
exs' String
unex' CaretWidth
caretWidth ->
          (# Word
line, Word
col, Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem
addLabels Bool
acceptingExpected Set ExpectItem
exs Set ExpectItem
exs', String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected' String
unex' CaretWidth
caretWidth BuilderUnexpectItem
unex, Set String
reasons #)
    makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex Set String
reasons Bool
acceptingExpected (Op ErrorOp 'Vanilla
op) =
      case ErrorOp 'Vanilla
op of
        Merged DefuncError_ 'Vanilla
err1 DefuncError_ 'Vanilla
err2 ->
          case Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex Set String
reasons Bool
acceptingExpected DefuncError_ 'Vanilla
err1 of
            (# Word
line', Word
col', Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #) ->
              Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line' Word
col' Set ExpectItem
exs' BuilderUnexpectItem
unex' Set String
reasons' Bool
acceptingExpected DefuncError_ 'Vanilla
err2
        WithHints DefuncError_ 'Vanilla
err DefuncHints
hints ->
          case Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex Set String
reasons Bool
acceptingExpected DefuncError_ 'Vanilla
err of
            (# Word
line', Word
col', Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #) ->
              if Bool
acceptingExpected then
                case Set ExpectItem
-> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)
collectHints Set ExpectItem
exs' (# #) -> forall a. UMaybe a
forall a. UMaybe a
UNothing DefuncHints
hints of
                  (# Set ExpectItem
exs'', UJust Word
width #) ->
                    (# Word
line', Word
col', Set ExpectItem
exs'', Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected Bool
outOfRange Word
width BuilderUnexpectItem
unex', Set String
reasons' #)
                  (# Set ExpectItem
exs'', UMaybe Word
UNothing #) -> (# Word
line', Word
col', Set ExpectItem
exs'', BuilderUnexpectItem
unex', Set String
reasons' #)
              else (# Word
line', Word
col', Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #)
        WithLabel DefuncError_ 'Vanilla
err Set String
ls ->
          case Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex Set String
reasons Bool
False DefuncError_ 'Vanilla
err of
            (# Word
line', Word
col', Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #) ->
              (# Word
line', Word
col', Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem
addLabels Bool
acceptingExpected Set ExpectItem
exs' ((String -> ExpectItem) -> Set String -> Set ExpectItem
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> ExpectItem
ExpectNamed Set String
ls), BuilderUnexpectItem
unex', Set String
reasons' #)
        WithReason DefuncError_ 'Vanilla
err String
reason ->
          Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
reason Set String
reasons) Bool
acceptingExpected DefuncError_ 'Vanilla
err
        Amended Word
line' Word
col' DefuncError_ 'Vanilla
err ->
          case Word
-> Word
-> Set ExpectItem
-> BuilderUnexpectItem
-> Set String
-> Bool
-> DefuncError_ 'Vanilla
-> (# Word, Word, Set ExpectItem, BuilderUnexpectItem,
      Set String #)
makeVanilla Word
line Word
col Set ExpectItem
exs BuilderUnexpectItem
unex Set String
reasons Bool
acceptingExpected DefuncError_ 'Vanilla
err of
            (# Word
_, Word
_, Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #) ->
              (# Word
line', Word
col', Set ExpectItem
exs', BuilderUnexpectItem
unex', Set String
reasons' #)

    makeSpec :: Word -> Word -> Word -> Bool -> ([String] -> [String])
             -> DefuncError_ 'Specialised
             -> (# Word, Word, Word, Bool, [String] -> [String] #)
    makeSpec :: Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec !Word
_ !Word
_ !Word
w !Bool
flexible ![String] -> [String]
dmsgs (Base Word
line Word
col (ClassicSpecialised [String]
msgs CaretWidth
cw)) =
      let (# Word
w', Bool
flexible' #) = Bool -> CaretWidth -> Word -> (# Word, Bool #)
updateCaretWidth Bool
flexible CaretWidth
cw Word
w
      in (# Word
line, Word
col, Word
w', Bool
flexible', [String] -> [String]
dmsgs ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) #)
    makeSpec Word
line Word
col Word
w Bool
flexible [String] -> [String]
dmsgs (Op ErrorOp 'Specialised
op) = case ErrorOp 'Specialised
op of
      Merged DefuncError_ 'Specialised
err1 DefuncError_ 'Specialised
err2->
        case Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec Word
line Word
col Word
w Bool
flexible [String] -> [String]
dmsgs DefuncError_ 'Specialised
err1 of
          (# Word
line', Word
col', Word
w', Bool
flexible', [String] -> [String]
dmsgs' #) ->
            Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec Word
line' Word
col' Word
w' Bool
flexible' [String] -> [String]
dmsgs' DefuncError_ 'Specialised
err2
      AdjustCaret DefuncError_ 'Specialised
err1 DefuncError_ 'Vanilla
err2 ->
        case Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec Word
line Word
col Word
w Bool
flexible [String] -> [String]
dmsgs DefuncError_ 'Specialised
err1 of
          (# Word
line', Word
col', Word
w', Bool
flexible', [String] -> [String]
dmsgs' #) ->
              -- assuming flexible == True
              (# Word
line', Word
col', Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w' DefuncError_ 'Vanilla
err2, Bool
flexible', [String] -> [String]
dmsgs' #)
      Amended Word
line' Word
col' DefuncError_ 'Specialised
err -> case Word
-> Word
-> Word
-> Bool
-> ([String] -> [String])
-> DefuncError_ 'Specialised
-> (# Word, Word, Word, Bool, [String] -> [String] #)
makeSpec Word
line Word
col Word
w Bool
flexible [String] -> [String]
dmsgs DefuncError_ 'Specialised
err of
        (# Word
_, Word
_, Word
w', Bool
flexible', [String] -> [String]
dmsgs' #) -> (# Word
line', Word
col', Word
w', Bool
flexible', [String] -> [String]
dmsgs' #)

type BuilderUnexpectItem :: UnliftedDatatype
data BuilderUnexpectItem = NoItem {-# UNPACK #-} !Word
                         | RawItem {-# UNPACK #-} !Word
                         | NamedItem !String {-# UNPACK #-} !CaretWidth
                         | EndOfInput

updateEmptyUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateEmptyUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateEmptyUnexpected !Word
w = BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher (Word -> BuilderUnexpectItem
NoItem Word
w)

updateUnexpected :: Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected :: Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected !Bool
outOfRange !Word
w
 | Bool
outOfRange = BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher BuilderUnexpectItem
EndOfInput
 | Bool
otherwise  = BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher (Word -> BuilderUnexpectItem
RawItem Word
w)

updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem
updateUnexpected' String
item CaretWidth
cw = BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher (String -> CaretWidth -> BuilderUnexpectItem
NamedItem String
item CaretWidth
cw)

pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher BuilderUnexpectItem
EndOfInput BuilderUnexpectItem
_ = BuilderUnexpectItem
EndOfInput
pickHigher BuilderUnexpectItem
_ BuilderUnexpectItem
EndOfInput = BuilderUnexpectItem
EndOfInput
pickHigher x :: BuilderUnexpectItem
x@(RawItem Word
w1) y :: BuilderUnexpectItem
y@(RawItem Word
w2)
  | Word
w1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
w2   = BuilderUnexpectItem
x
  | Bool
otherwise = BuilderUnexpectItem
y
pickHigher x :: BuilderUnexpectItem
x@(NoItem Word
w1) y :: BuilderUnexpectItem
y@(NoItem Word
w2)
  | Word
w1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
w2   = BuilderUnexpectItem
x
  | Bool
otherwise = BuilderUnexpectItem
y
pickHigher x :: BuilderUnexpectItem
x@(NamedItem String
_ CaretWidth
cw1) y :: BuilderUnexpectItem
y@(NamedItem String
_ CaretWidth
cw2)
  | CaretWidth -> Bool
isFlexible CaretWidth
cw1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= CaretWidth -> Bool
isFlexible CaretWidth
cw2 = if CaretWidth -> Bool
isFlexible CaretWidth
cw1 then BuilderUnexpectItem
x else BuilderUnexpectItem
y
  | CaretWidth -> Word
width CaretWidth
cw1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> CaretWidth -> Word
width CaretWidth
cw2            = BuilderUnexpectItem
x
  | Bool
otherwise                        = BuilderUnexpectItem
y
pickHigher x :: BuilderUnexpectItem
x@(RawItem Word
w1) (NoItem Word
w2)
  | Word
w1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
w2   = BuilderUnexpectItem
x
  | Bool
otherwise = Word -> BuilderUnexpectItem
RawItem Word
w2
pickHigher x :: BuilderUnexpectItem
x@(NamedItem String
name (FlexibleCaret Word
w1)) (RawItem Word
w2)
  | Word
w1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
w2   = BuilderUnexpectItem
x
  | Bool
otherwise = String -> CaretWidth -> BuilderUnexpectItem
NamedItem String
name (Word -> CaretWidth
FlexibleCaret Word
w2)
pickHigher x :: BuilderUnexpectItem
x@(NamedItem String
name (FlexibleCaret Word
w1)) (NoItem Word
w2)
  | Word
w1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
w2   = BuilderUnexpectItem
x
  | Bool
otherwise = String -> CaretWidth -> BuilderUnexpectItem
NamedItem String
name (Word -> CaretWidth
FlexibleCaret Word
w2)
pickHigher x :: BuilderUnexpectItem
x@NamedItem{} BuilderUnexpectItem
_ = BuilderUnexpectItem
x
pickHigher BuilderUnexpectItem
x BuilderUnexpectItem
y = BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem
pickHigher BuilderUnexpectItem
y BuilderUnexpectItem
x

addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem
addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem
addLabels Bool
True !Set ExpectItem
exs !Set ExpectItem
exs' = Set ExpectItem -> Set ExpectItem -> Set ExpectItem
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ExpectItem
exs Set ExpectItem
exs'
addLabels Bool
False Set ExpectItem
exs Set ExpectItem
_     = Set ExpectItem
exs

toErrorItem :: String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem
toErrorItem :: String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem
toErrorItem !String
_ !Word
_ (NoItem Word
w) = Word -> Either Word UnexpectItem
forall a b. a -> Either a b
Left Word
w
toErrorItem String
_ Word
_ (NamedItem String
item CaretWidth
cw) = UnexpectItem -> Either Word UnexpectItem
forall a b. b -> Either a b
Right (String -> CaretWidth -> UnexpectItem
UnexpectNamed String
item CaretWidth
cw)
toErrorItem String
_ Word
_ BuilderUnexpectItem
EndOfInput = UnexpectItem -> Either Word UnexpectItem
forall a b. b -> Either a b
Right UnexpectItem
UnexpectEndOfInput
toErrorItem String
input Word
off (RawItem Word
w) =
  case String -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
off) String
input) of
    Maybe (NonEmpty Char)
Nothing -> UnexpectItem -> Either Word UnexpectItem
forall a b. b -> Either a b
Right UnexpectItem
UnexpectEndOfInput
    Just NonEmpty Char
cs -> UnexpectItem -> Either Word UnexpectItem
forall a b. b -> Either a b
Right (NonEmpty Char -> Word -> UnexpectItem
UnexpectRaw NonEmpty Char
cs Word
w)

type UMaybe a = (# (# #) | a #)
{-# COMPLETE UJust, UNothing #-}
pattern UJust :: a -> UMaybe a
pattern $mUJust :: forall {r} {a}. UMaybe a -> (a -> r) -> ((# #) -> r) -> r
$bUJust :: forall a. a -> UMaybe a
UJust x = (# | x #)
pattern UNothing :: UMaybe a
pattern $mUNothing :: forall {r} {a}. UMaybe a -> ((# #) -> r) -> ((# #) -> r) -> r
$bUNothing :: (# #) -> forall a. UMaybe a
UNothing = (# (# #) | #)

collectHints :: Set ExpectItem -> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)
collectHints :: Set ExpectItem
-> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)
collectHints !Set ExpectItem
exs UMaybe Word
width DefuncHints
Blank = (# Set ExpectItem
exs, UMaybe Word
width #)
collectHints Set ExpectItem
exs UMaybe Word
width (Replace Set String
ls) = (# Set ExpectItem -> Set ExpectItem -> Set ExpectItem
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ExpectItem
exs ((String -> ExpectItem) -> Set String -> Set ExpectItem
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> ExpectItem
ExpectNamed Set String
ls), UMaybe Word
width #)
collectHints Set ExpectItem
exs UMaybe Word
width (AddErr DefuncHints
hints DefuncError_ 'Vanilla
err) =
  let !(# Set ExpectItem
exs', UMaybe Word
width' #) = Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs UMaybe Word
width DefuncError_ 'Vanilla
err
  in Set ExpectItem
-> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)
collectHints Set ExpectItem
exs' UMaybe Word
width' DefuncHints
hints

collectHintsErr :: Set ExpectItem -> UMaybe Word -> DefuncError_ 'Vanilla -> (# Set ExpectItem, UMaybe Word #)
collectHintsErr :: Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr !Set ExpectItem
exs UMaybe Word
width (Base Word
_ Word
_ BaseError 'Vanilla
err) =
  (# Set ExpectItem -> Set ExpectItem -> Set ExpectItem
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ExpectItem
exs (BaseError 'Vanilla -> Set ExpectItem
expecteds BaseError 'Vanilla
err), UMaybe Word -> Word -> UMaybe Word
updateWidth UMaybe Word
width (BaseError 'Vanilla -> Word
unexpectedWidth BaseError 'Vanilla
err) #)
collectHintsErr Set ExpectItem
exs UMaybe Word
width (Op ErrorOp 'Vanilla
op) = case ErrorOp 'Vanilla
op of
  -- FIXME: Why doesn't this traverse deeper to collect the width?
  WithLabel DefuncError_ 'Vanilla
_ Set String
ls -> (# Set ExpectItem -> Set ExpectItem -> Set ExpectItem
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ExpectItem
exs ((String -> ExpectItem) -> Set String -> Set ExpectItem
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> ExpectItem
ExpectNamed Set String
ls), UMaybe Word
width #)
  WithHints DefuncError_ 'Vanilla
err DefuncHints
hints ->
    let !(# Set ExpectItem
exs', UMaybe Word
width' #) = Set ExpectItem
-> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)
collectHints Set ExpectItem
exs UMaybe Word
width DefuncHints
hints
    in Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs' UMaybe Word
width' DefuncError_ 'Vanilla
err
  Merged DefuncError_ 'Vanilla
err1 DefuncError_ 'Vanilla
err2 ->
    let !(# Set ExpectItem
exs', UMaybe Word
width' #) = Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs UMaybe Word
width DefuncError_ 'Vanilla
err1
    in Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs' UMaybe Word
width' DefuncError_ 'Vanilla
err2
  WithReason DefuncError_ 'Vanilla
err String
_ -> Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs UMaybe Word
width DefuncError_ 'Vanilla
err
  Amended Word
_ Word
_ DefuncError_ 'Vanilla
err -> Set ExpectItem
-> UMaybe Word
-> DefuncError_ 'Vanilla
-> (# Set ExpectItem, UMaybe Word #)
collectHintsErr Set ExpectItem
exs UMaybe Word
width DefuncError_ 'Vanilla
err

updateWidth :: UMaybe Word -> Word -> UMaybe Word
updateWidth :: UMaybe Word -> Word -> UMaybe Word
updateWidth UMaybe Word
UNothing !Word
w = Word -> UMaybe Word
forall a. a -> UMaybe a
UJust Word
w
updateWidth (UJust Word
w) Word
w' = Word -> UMaybe Word
forall a. a -> UMaybe a
UJust (Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
w Word
w')

distinct :: forall a. Ord a => [a] -> [a]
distinct :: forall a. Ord a => [a] -> [a]
distinct = Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
seen (a
x:[a]
xs)
      | a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
seen = Set a -> [a] -> [a]
go Set a
seen [a]
xs
      | Bool
otherwise         = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
seen) [a]
xs

updateCaretWidth :: Bool -> CaretWidth -> Word -> (# Word, Bool #)
updateCaretWidth :: Bool -> CaretWidth -> Word -> (# Word, Bool #)
updateCaretWidth Bool
flexible CaretWidth
cw !Word
w
  | CaretWidth -> Bool
isFlexible CaretWidth
cw Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
flexible = (# Word -> Word -> Word
forall a. Ord a => a -> a -> a
max (CaretWidth -> Word
width CaretWidth
cw) Word
w, Bool
flexible #)
  | CaretWidth -> Bool
isFlexible CaretWidth
cw             = (# Word
w, Bool
flexible #)
  | Bool
otherwise                 = (# CaretWidth -> Word
width CaretWidth
cw, Bool
False #)

adjustCaret :: Word -> DefuncError_ 'Vanilla -> Word
adjustCaret :: Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w (Base Word
_ Word
_ BaseError 'Vanilla
err) = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max (BaseError 'Vanilla -> Word
unexpectedWidth BaseError 'Vanilla
err) Word
w
adjustCaret Word
w (Op ErrorOp 'Vanilla
op) = case ErrorOp 'Vanilla
op of
  WithLabel DefuncError_ 'Vanilla
err Set String
_  -> Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w DefuncError_ 'Vanilla
err
  WithHints DefuncError_ 'Vanilla
err DefuncHints
_  -> Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w DefuncError_ 'Vanilla
err
  WithReason DefuncError_ 'Vanilla
err String
_ -> Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w DefuncError_ 'Vanilla
err
  Amended Word
_ Word
_ DefuncError_ 'Vanilla
err  -> Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w DefuncError_ 'Vanilla
err
  Merged DefuncError_ 'Vanilla
err1 DefuncError_ 'Vanilla
err2 -> Word -> DefuncError_ 'Vanilla -> Word
adjustCaret (Word -> DefuncError_ 'Vanilla -> Word
adjustCaret Word
w DefuncError_ 'Vanilla
err1) DefuncError_ 'Vanilla
err2