{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DerivingVia, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-import-lists #-}
module Text.Gigaparsec.Errors.DefaultErrorBuilder (module Text.Gigaparsec.Errors.DefaultErrorBuilder) where

import Prelude hiding (lines)

import Data.Monoid (Endo(Endo))
import Data.String (IsString(fromString))
import Data.List (intersperse, sortBy)
import Data.Maybe (mapMaybe)
import Data.Foldable (toList)
import Data.Ord (comparing, Down (Down))

-- For now, this is the home of the default formatting functions

type StringBuilder :: *
newtype StringBuilder = StringBuilder (String -> String)
  deriving (NonEmpty StringBuilder -> StringBuilder
StringBuilder -> StringBuilder -> StringBuilder
(StringBuilder -> StringBuilder -> StringBuilder)
-> (NonEmpty StringBuilder -> StringBuilder)
-> (forall b. Integral b => b -> StringBuilder -> StringBuilder)
-> Semigroup StringBuilder
forall b. Integral b => b -> StringBuilder -> StringBuilder
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: StringBuilder -> StringBuilder -> StringBuilder
<> :: StringBuilder -> StringBuilder -> StringBuilder
$csconcat :: NonEmpty StringBuilder -> StringBuilder
sconcat :: NonEmpty StringBuilder -> StringBuilder
$cstimes :: forall b. Integral b => b -> StringBuilder -> StringBuilder
stimes :: forall b. Integral b => b -> StringBuilder -> StringBuilder
Semigroup, Semigroup StringBuilder
StringBuilder
Semigroup StringBuilder =>
StringBuilder
-> (StringBuilder -> StringBuilder -> StringBuilder)
-> ([StringBuilder] -> StringBuilder)
-> Monoid StringBuilder
[StringBuilder] -> StringBuilder
StringBuilder -> StringBuilder -> StringBuilder
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: StringBuilder
mempty :: StringBuilder
$cmappend :: StringBuilder -> StringBuilder -> StringBuilder
mappend :: StringBuilder -> StringBuilder -> StringBuilder
$cmconcat :: [StringBuilder] -> StringBuilder
mconcat :: [StringBuilder] -> StringBuilder
Monoid) via Endo String

instance IsString StringBuilder where
  {-# INLINE fromString #-}
  fromString :: String -> StringBuilder
  fromString :: String -> StringBuilder
fromString String
str = (String -> String) -> StringBuilder
StringBuilder (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)

{-# INLINE toString #-}
toString :: StringBuilder -> String
toString :: StringBuilder -> String
toString (StringBuilder String -> String
build) = String -> String
build String
forall a. Monoid a => a
mempty

{-# INLINE from #-}
from :: Show a => a -> StringBuilder
from :: forall a. Show a => a -> StringBuilder
from = (String -> String) -> StringBuilder
StringBuilder ((String -> String) -> StringBuilder)
-> (a -> String -> String) -> a -> StringBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> String
forall a. Show a => a -> String -> String
shows

{-# INLINABLE buildDefault #-}
buildDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String
buildDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String
buildDefault StringBuilder
pos Maybe StringBuilder
source [StringBuilder]
lines = StringBuilder -> String
toString (StringBuilder -> [StringBuilder] -> Int -> StringBuilder
blockError StringBuilder
header [StringBuilder]
lines Int
2)
  where header :: StringBuilder
header = StringBuilder
-> (StringBuilder -> StringBuilder)
-> Maybe StringBuilder
-> StringBuilder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StringBuilder
forall a. Monoid a => a
mempty (\StringBuilder
src -> StringBuilder
"In " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
src StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
" ") Maybe StringBuilder
source StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
pos

{-# INLINABLE vanillaErrorDefault #-}
vanillaErrorDefault :: Foldable t => Maybe StringBuilder -> Maybe StringBuilder -> t StringBuilder -> [StringBuilder] -> [StringBuilder]
vanillaErrorDefault :: forall (t :: * -> *).
Foldable t =>
Maybe StringBuilder
-> Maybe StringBuilder
-> t StringBuilder
-> [StringBuilder]
-> [StringBuilder]
vanillaErrorDefault Maybe StringBuilder
unexpected Maybe StringBuilder
expected t StringBuilder
reasons =
  [StringBuilder] -> [StringBuilder] -> [StringBuilder]
combineInfoWithLines (([StringBuilder] -> [StringBuilder])
-> (StringBuilder -> [StringBuilder] -> [StringBuilder])
-> Maybe StringBuilder
-> [StringBuilder]
-> [StringBuilder]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [StringBuilder] -> [StringBuilder]
forall a. a -> a
id (:) Maybe StringBuilder
unexpected (([StringBuilder] -> [StringBuilder])
-> (StringBuilder -> [StringBuilder] -> [StringBuilder])
-> Maybe StringBuilder
-> [StringBuilder]
-> [StringBuilder]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [StringBuilder] -> [StringBuilder]
forall a. a -> a
id (:) Maybe StringBuilder
expected (t StringBuilder -> [StringBuilder]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t StringBuilder
reasons)))

{-# INLINABLE specialisedErrorDefault #-}
specialisedErrorDefault :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]
specialisedErrorDefault :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]
specialisedErrorDefault = [StringBuilder] -> [StringBuilder] -> [StringBuilder]
combineInfoWithLines

{-# INLINABLE combineInfoWithLines #-}
combineInfoWithLines :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]
combineInfoWithLines :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]
combineInfoWithLines [] [StringBuilder]
lines = StringBuilder
"unknown parse error" StringBuilder -> [StringBuilder] -> [StringBuilder]
forall a. a -> [a] -> [a]
: [StringBuilder]
lines
combineInfoWithLines [StringBuilder]
info [StringBuilder]
lines = [StringBuilder]
info [StringBuilder] -> [StringBuilder] -> [StringBuilder]
forall a. [a] -> [a] -> [a]
++ [StringBuilder]
lines

--TODO: this needs to deal with whitespace and unprintables
{-# INLINABLE rawDefault #-}
rawDefault :: String -> String
rawDefault :: String -> String
rawDefault String
n = String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""

{-# INLINABLE namedDefault #-}
namedDefault :: String -> String
namedDefault :: String -> String
namedDefault = String -> String
forall a. a -> a
id

{-# INLINABLE endOfInputDefault #-}
endOfInputDefault :: String
endOfInputDefault :: String
endOfInputDefault = String
"end of input"

{-# INLINABLE messageDefault #-}
messageDefault :: String -> String
messageDefault :: String -> String
messageDefault = String -> String
forall a. a -> a
id

{-# INLINABLE expectedDefault #-}
expectedDefault :: Maybe StringBuilder -> Maybe StringBuilder
expectedDefault :: Maybe StringBuilder -> Maybe StringBuilder
expectedDefault = (StringBuilder -> StringBuilder)
-> Maybe StringBuilder -> Maybe StringBuilder
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StringBuilder
"expected " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<>)

{-# INLINABLE unexpectedDefault #-}
unexpectedDefault :: Maybe String -> Maybe StringBuilder
unexpectedDefault :: Maybe String -> Maybe StringBuilder
unexpectedDefault = (String -> StringBuilder) -> Maybe String -> Maybe StringBuilder
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StringBuilder
"unexpected " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<>) (StringBuilder -> StringBuilder)
-> (String -> StringBuilder) -> String -> StringBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringBuilder
forall a. IsString a => String -> a
fromString)

{-# INLINABLE disjunct #-}
disjunct :: Bool -> [String] -> Maybe StringBuilder
disjunct :: Bool -> [String] -> Maybe StringBuilder
disjunct Bool
oxford [String]
elems = Bool -> [String] -> String -> Maybe StringBuilder
junct Bool
oxford [String]
elems String
"or"

{-# INLINABLE junct #-}
junct :: Bool -> [String] -> String -> Maybe StringBuilder
junct :: Bool -> [String] -> String -> Maybe StringBuilder
junct Bool
oxford [String]
elems String
junction = [String] -> Maybe StringBuilder
junct' ((String -> String -> Ordering) -> [String] -> [String]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((String -> Down String) -> String -> String -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing String -> Down String
forall a. a -> Down a
Down) [String]
elems)
  where
    j :: StringBuilder
    j :: StringBuilder
j = String -> StringBuilder
forall a. IsString a => String -> a
fromString String
junction

    junct' :: [String] -> Maybe StringBuilder
junct' [] = Maybe StringBuilder
forall a. Maybe a
Nothing
    junct' [String
alt] = StringBuilder -> Maybe StringBuilder
forall a. a -> Maybe a
Just (String -> StringBuilder
forall a. IsString a => String -> a
fromString String
alt)
    junct' [String
alt1, String
alt2] = StringBuilder -> Maybe StringBuilder
forall a. a -> Maybe a
Just (String -> StringBuilder
forall a. IsString a => String -> a
fromString String
alt2 StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
" " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> String -> StringBuilder
forall a. IsString a => String -> a
fromString String
junction StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
" " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> String -> StringBuilder
forall a. IsString a => String -> a
fromString String
alt1)
    junct' as :: [String]
as@(String
alt:[String]
alts)
      -- use a semi-colon here, it is more correct
      | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
',') [String]
as = StringBuilder -> Maybe StringBuilder
forall a. a -> Maybe a
Just ([String] -> String -> String -> StringBuilder
junct'' ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
alts) String
alt String
"; ")
      | Bool
otherwise         = StringBuilder -> Maybe StringBuilder
forall a. a -> Maybe a
Just ([String] -> String -> String -> StringBuilder
junct'' ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
alts) String
alt String
", ")

    junct'' :: [String] -> String -> String -> StringBuilder
junct'' [String]
is String
l String
delim = StringBuilder
front StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
back
      where front :: StringBuilder
front = StringBuilder -> [StringBuilder] -> StringBuilder
forall m. Monoid m => m -> [m] -> m
intercalate (String -> StringBuilder
forall a. IsString a => String -> a
fromString String
delim) ((String -> StringBuilder) -> [String] -> [StringBuilder]
forall a b. (a -> b) -> [a] -> [b]
map String -> StringBuilder
forall a. IsString a => String -> a
fromString [String]
is) :: StringBuilder
            back :: StringBuilder
back
              | Bool
oxford    = String -> StringBuilder
forall a. IsString a => String -> a
fromString String
delim StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
j StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
" " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> String -> StringBuilder
forall a. IsString a => String -> a
fromString String
l
              | Bool
otherwise = StringBuilder
" " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
j StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
" " StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> String -> StringBuilder
forall a. IsString a => String -> a
fromString String
l

{-# INLINABLE combineMessagesDefault #-}
combineMessagesDefault :: Foldable t => t String -> [StringBuilder]
combineMessagesDefault :: forall (t :: * -> *). Foldable t => t String -> [StringBuilder]
combineMessagesDefault = (String -> Maybe StringBuilder) -> [String] -> [StringBuilder]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\String
msg -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then Maybe StringBuilder
forall a. Maybe a
Nothing else StringBuilder -> Maybe StringBuilder
forall a. a -> Maybe a
Just (String -> StringBuilder
forall a. IsString a => String -> a
fromString String
msg)) ([String] -> [StringBuilder])
-> (t String -> [String]) -> t String -> [StringBuilder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t String -> [String]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

{-# INLINABLE blockError #-}
blockError :: StringBuilder -> [StringBuilder] -> Int -> StringBuilder
blockError :: StringBuilder -> [StringBuilder] -> Int -> StringBuilder
blockError StringBuilder
header [StringBuilder]
lines Int
indent = StringBuilder
header StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
":\n" StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> [StringBuilder] -> Int -> StringBuilder
indentAndUnlines [StringBuilder]
lines Int
indent

{-# INLINABLE indentAndUnlines #-}
indentAndUnlines :: [StringBuilder] -> Int -> StringBuilder
indentAndUnlines :: [StringBuilder] -> Int -> StringBuilder
indentAndUnlines [StringBuilder]
lines Int
indent = String -> StringBuilder
forall a. IsString a => String -> a
fromString String
pre StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder -> [StringBuilder] -> StringBuilder
forall m. Monoid m => m -> [m] -> m
intercalate (String -> StringBuilder
forall a. IsString a => String -> a
fromString (Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
pre)) [StringBuilder]
lines
  where pre :: String
pre = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indent Char
' '

{-# INLINABLE lineInfoDefault #-}
lineInfoDefault :: String -> [String] -> [String] -> Word -> Word -> Word -> [StringBuilder]
lineInfoDefault :: String
-> [String] -> [String] -> Word -> Word -> Word -> [StringBuilder]
lineInfoDefault String
curLine [String]
beforeLines [String]
afterLines Word
_line Word
pointsAt Word
width =
  [[StringBuilder]] -> [StringBuilder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(String -> StringBuilder) -> [String] -> [StringBuilder]
forall a b. (a -> b) -> [a] -> [b]
map String -> StringBuilder
inputLine [String]
beforeLines, [String -> StringBuilder
inputLine String
curLine, StringBuilder
caretLine], (String -> StringBuilder) -> [String] -> [StringBuilder]
forall a b. (a -> b) -> [a] -> [b]
map String -> StringBuilder
inputLine [String]
afterLines]
  where inputLine :: String -> StringBuilder
        inputLine :: String -> StringBuilder
inputLine = String -> StringBuilder
forall a. IsString a => String -> a
fromString (String -> StringBuilder)
-> (String -> String) -> String -> StringBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'>' Char -> String -> String
forall a. a -> [a] -> [a]
:)
        caretLine :: StringBuilder
        caretLine :: StringBuilder
caretLine = String -> StringBuilder
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
pointsAt Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1)) Char
' ') StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> String -> StringBuilder
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
width) Char
'^')

{-# INLINABLE posDefault #-}
posDefault :: Word -> Word -> StringBuilder
posDefault :: Word -> Word -> StringBuilder
posDefault Word
line Word
col = StringBuilder
"(line "
                   StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> Word -> StringBuilder
forall a. Show a => a -> StringBuilder
from Word
line
                   StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
", column "
                   StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> Word -> StringBuilder
forall a. Show a => a -> StringBuilder
from Word
col
                   StringBuilder -> StringBuilder -> StringBuilder
forall a. Semigroup a => a -> a -> a
<> StringBuilder
")"

{-# INLINABLE intercalate #-}
intercalate :: Monoid m => m -> [m] -> m
intercalate :: forall m. Monoid m => m -> [m] -> m
intercalate m
x [m]
xs = [m] -> m
forall a. Monoid a => [a] -> a
mconcat (m -> [m] -> [m]
forall a. a -> [a] -> [a]
intersperse m
x [m]
xs)