{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE Strict                 #-}
module Language.Cimple.Diagnostics
  ( DiagnosticLevel (..)
  , DiagnosticSpan (..)
  , Diagnostic (..)
  , IsPosition (..)
  , HasDiagnosticInfo (..)
  , CimplePos (..)
  , DiagnosticsT
  , Diagnostics
  , HasDiagnostics (..)
  , HasDiagnosticsRich (..)
  , warn
  , warnRich
  , sloc
  , lexemePos
  , nodePos
  , nodePosAndLen
  , renderPure
  , diagToText
  ) where

import           Control.Monad.State.Strict    (State)
import qualified Control.Monad.State.Strict    as State
import           Data.Fix                      (foldFix)
import           Data.Function                 (on)
import           Data.List                     (groupBy, sortBy)
import           Data.Map.Strict               (Map)
import qualified Data.Map.Strict               as Map
import           Data.Text                     (Text)
import qualified Data.Text                     as Text
import           Language.Cimple.Ast           (Node)
import           Language.Cimple.DescribeAst   (HasLocation (..))
import qualified Language.Cimple.Flatten       as Flatten
import           Language.Cimple.Lexer         (AlexPosn (..), Lexeme (..),
                                                lexemeText)
import           Prettyprinter                 (Doc, align, annotate, line,
                                                pretty, vsep, (<+>))
import qualified Prettyprinter                 as PP
import           Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold,
                                                color, colorDull)
import qualified Prettyprinter.Render.Text     as PP.Text

import qualified Data.ByteString               as BS
import qualified Data.Text.Encoding            as Text

data DiagnosticLevel = ErrorLevel | WarningLevel | NoteLevel | HelpLevel
    deriving (Int -> DiagnosticLevel -> ShowS
[DiagnosticLevel] -> ShowS
DiagnosticLevel -> String
(Int -> DiagnosticLevel -> ShowS)
-> (DiagnosticLevel -> String)
-> ([DiagnosticLevel] -> ShowS)
-> Show DiagnosticLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagnosticLevel] -> ShowS
$cshowList :: [DiagnosticLevel] -> ShowS
show :: DiagnosticLevel -> String
$cshow :: DiagnosticLevel -> String
showsPrec :: Int -> DiagnosticLevel -> ShowS
$cshowsPrec :: Int -> DiagnosticLevel -> ShowS
Show, DiagnosticLevel -> DiagnosticLevel -> Bool
(DiagnosticLevel -> DiagnosticLevel -> Bool)
-> (DiagnosticLevel -> DiagnosticLevel -> Bool)
-> Eq DiagnosticLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c/= :: DiagnosticLevel -> DiagnosticLevel -> Bool
== :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c== :: DiagnosticLevel -> DiagnosticLevel -> Bool
Eq, Eq DiagnosticLevel
Eq DiagnosticLevel
-> (DiagnosticLevel -> DiagnosticLevel -> Ordering)
-> (DiagnosticLevel -> DiagnosticLevel -> Bool)
-> (DiagnosticLevel -> DiagnosticLevel -> Bool)
-> (DiagnosticLevel -> DiagnosticLevel -> Bool)
-> (DiagnosticLevel -> DiagnosticLevel -> Bool)
-> (DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel)
-> (DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel)
-> Ord DiagnosticLevel
DiagnosticLevel -> DiagnosticLevel -> Bool
DiagnosticLevel -> DiagnosticLevel -> Ordering
DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel
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
min :: DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel
$cmin :: DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel
max :: DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel
$cmax :: DiagnosticLevel -> DiagnosticLevel -> DiagnosticLevel
>= :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c>= :: DiagnosticLevel -> DiagnosticLevel -> Bool
> :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c> :: DiagnosticLevel -> DiagnosticLevel -> Bool
<= :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c<= :: DiagnosticLevel -> DiagnosticLevel -> Bool
< :: DiagnosticLevel -> DiagnosticLevel -> Bool
$c< :: DiagnosticLevel -> DiagnosticLevel -> Bool
compare :: DiagnosticLevel -> DiagnosticLevel -> Ordering
$ccompare :: DiagnosticLevel -> DiagnosticLevel -> Ordering
$cp1Ord :: Eq DiagnosticLevel
Ord)

data DiagnosticSpan pos = DiagnosticSpan
    { DiagnosticSpan pos -> pos
spanPos    :: pos
    , DiagnosticSpan pos -> Int
spanLen    :: Int
    , DiagnosticSpan pos -> [Doc AnsiStyle]
spanLabels :: [Doc AnsiStyle]
    }

data Diagnostic pos = Diagnostic
    { Diagnostic pos -> pos
diagPos    :: pos
    , Diagnostic pos -> Int
diagLen    :: Int
    , Diagnostic pos -> DiagnosticLevel
diagLevel  :: DiagnosticLevel
    , Diagnostic pos -> Doc AnsiStyle
diagMsg    :: Doc AnsiStyle
    , Diagnostic pos -> Maybe Text
diagFlag   :: Maybe Text
    , Diagnostic pos -> [DiagnosticSpan pos]
diagSpans  :: [DiagnosticSpan pos]
    , Diagnostic pos -> [(DiagnosticLevel, Doc AnsiStyle)]
diagFooter :: [(DiagnosticLevel, Doc AnsiStyle)]
    }

diagToText :: IsPosition pos => Diagnostic pos -> Text
diagToText :: Diagnostic pos -> Text
diagToText Diagnostic pos
d =
    let p :: pos
p = Diagnostic pos -> pos
forall pos. Diagnostic pos -> pos
diagPos Diagnostic pos
d
        msg :: Text
msg = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.Text.renderStrict (LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions (Doc AnsiStyle -> Doc Any
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate (Diagnostic pos -> Doc AnsiStyle
forall pos. Diagnostic pos -> Doc AnsiStyle
diagMsg Diagnostic pos
d)))
        flag :: Text
flag = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
f -> Text
" [-W" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") (Diagnostic pos -> Maybe Text
forall pos. Diagnostic pos -> Maybe Text
diagFlag Diagnostic pos
d)
        footers :: [Text]
footers = ((DiagnosticLevel, Doc AnsiStyle) -> Text)
-> [(DiagnosticLevel, Doc AnsiStyle)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (DiagnosticLevel, Doc AnsiStyle) -> Text
forall ann. (DiagnosticLevel, Doc ann) -> Text
formatFooter (Diagnostic pos -> [(DiagnosticLevel, Doc AnsiStyle)]
forall pos. Diagnostic pos -> [(DiagnosticLevel, Doc AnsiStyle)]
diagFooter Diagnostic pos
d)
        formatFooter :: (DiagnosticLevel, Doc ann) -> Text
formatFooter (DiagnosticLevel
l, Doc ann
footer) =
            let pref :: Text
pref = case DiagnosticLevel
l of
                    DiagnosticLevel
ErrorLevel   -> Text
"error: "
                    DiagnosticLevel
WarningLevel -> Text
"warning: "
                    DiagnosticLevel
NoteLevel    -> Text
"note: "
                    DiagnosticLevel
HelpLevel    -> Text
"help: "
            in Text
pref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.Text.renderStrict (LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions (Doc ann -> Doc Any
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate Doc ann
footer))
        loc :: Text
loc = String -> Text
Text.pack (pos -> String
forall p. IsPosition p => p -> String
posFile pos
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (pos -> Int
forall p. IsPosition p => p -> Int
posLine pos
p)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        level :: Text
level = case Diagnostic pos -> DiagnosticLevel
forall pos. Diagnostic pos -> DiagnosticLevel
diagLevel Diagnostic pos
d of
            DiagnosticLevel
ErrorLevel   -> Text
"error: "
            DiagnosticLevel
WarningLevel -> Text
"warning: "
            DiagnosticLevel
NoteLevel    -> Text
"note: "
            DiagnosticLevel
HelpLevel    -> Text
"help: "
    in Text -> [Text] -> Text
Text.intercalate Text
"\n" ( (Text
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
level Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
footers )


class IsPosition p where
    posFile   :: p -> FilePath
    posLine   :: p -> Int
    posColumn :: p -> Int
    isRealPos :: p -> Bool
    isRealPos p
_ = Bool
True

class IsPosition pos => HasDiagnosticInfo at pos | at -> pos where
    getDiagnosticInfo :: FilePath -> at -> (pos, Int)

data CimplePos = CimplePos
    { CimplePos -> String
cimpleFile   :: FilePath
    , CimplePos -> Int
cimpleLine   :: Int
    , CimplePos -> Int
cimpleColumn :: Int
    }
    deriving (Int -> CimplePos -> ShowS
[CimplePos] -> ShowS
CimplePos -> String
(Int -> CimplePos -> ShowS)
-> (CimplePos -> String)
-> ([CimplePos] -> ShowS)
-> Show CimplePos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CimplePos] -> ShowS
$cshowList :: [CimplePos] -> ShowS
show :: CimplePos -> String
$cshow :: CimplePos -> String
showsPrec :: Int -> CimplePos -> ShowS
$cshowsPrec :: Int -> CimplePos -> ShowS
Show, CimplePos -> CimplePos -> Bool
(CimplePos -> CimplePos -> Bool)
-> (CimplePos -> CimplePos -> Bool) -> Eq CimplePos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CimplePos -> CimplePos -> Bool
$c/= :: CimplePos -> CimplePos -> Bool
== :: CimplePos -> CimplePos -> Bool
$c== :: CimplePos -> CimplePos -> Bool
Eq, Eq CimplePos
Eq CimplePos
-> (CimplePos -> CimplePos -> Ordering)
-> (CimplePos -> CimplePos -> Bool)
-> (CimplePos -> CimplePos -> Bool)
-> (CimplePos -> CimplePos -> Bool)
-> (CimplePos -> CimplePos -> Bool)
-> (CimplePos -> CimplePos -> CimplePos)
-> (CimplePos -> CimplePos -> CimplePos)
-> Ord CimplePos
CimplePos -> CimplePos -> Bool
CimplePos -> CimplePos -> Ordering
CimplePos -> CimplePos -> CimplePos
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
min :: CimplePos -> CimplePos -> CimplePos
$cmin :: CimplePos -> CimplePos -> CimplePos
max :: CimplePos -> CimplePos -> CimplePos
$cmax :: CimplePos -> CimplePos -> CimplePos
>= :: CimplePos -> CimplePos -> Bool
$c>= :: CimplePos -> CimplePos -> Bool
> :: CimplePos -> CimplePos -> Bool
$c> :: CimplePos -> CimplePos -> Bool
<= :: CimplePos -> CimplePos -> Bool
$c<= :: CimplePos -> CimplePos -> Bool
< :: CimplePos -> CimplePos -> Bool
$c< :: CimplePos -> CimplePos -> Bool
compare :: CimplePos -> CimplePos -> Ordering
$ccompare :: CimplePos -> CimplePos -> Ordering
$cp1Ord :: Eq CimplePos
Ord)

instance IsPosition CimplePos where
    posFile :: CimplePos -> String
posFile = CimplePos -> String
cimpleFile
    posLine :: CimplePos -> Int
posLine = CimplePos -> Int
cimpleLine
    posColumn :: CimplePos -> Int
posColumn = CimplePos -> Int
cimpleColumn

instance HasDiagnosticInfo (Lexeme Text) CimplePos where
    getDiagnosticInfo :: String -> Lexeme Text -> (CimplePos, Int)
getDiagnosticInfo String
file Lexeme Text
l = (String -> Lexeme Text -> CimplePos
forall text. String -> Lexeme text -> CimplePos
lexemePos String
file Lexeme Text
l, Text -> Int
Text.length (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
l))

instance HasDiagnosticInfo (Node (Lexeme Text)) CimplePos where
    getDiagnosticInfo :: String -> Node (Lexeme Text) -> (CimplePos, Int)
getDiagnosticInfo = String -> Node (Lexeme Text) -> (CimplePos, Int)
nodePosAndLen

lexemePos :: FilePath -> Lexeme text -> CimplePos
lexemePos :: String -> Lexeme text -> CimplePos
lexemePos String
file (L (AlexPn Int
_ Int
l Int
c) LexemeClass
_ text
_) = String -> Int -> Int -> CimplePos
CimplePos String
file Int
l Int
c

nodePos :: FilePath -> Node (Lexeme text) -> CimplePos
nodePos :: String -> Node (Lexeme text) -> CimplePos
nodePos String
file Node (Lexeme text)
n =
    case (NodeF (Lexeme text) [Lexeme text] -> [Lexeme text])
-> Node (Lexeme text) -> [Lexeme text]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme text) [Lexeme text] -> [Lexeme text]
forall lexeme. NodeF lexeme [lexeme] -> [lexeme]
Flatten.lexemes Node (Lexeme text)
n of
        []  -> String -> Int -> Int -> CimplePos
CimplePos String
file Int
0 Int
0
        Lexeme text
l:[Lexeme text]
_ -> String -> Lexeme text -> CimplePos
forall text. String -> Lexeme text -> CimplePos
lexemePos String
file Lexeme text
l

nodePosAndLen :: FilePath -> Node (Lexeme Text) -> (CimplePos, Int)
nodePosAndLen :: String -> Node (Lexeme Text) -> (CimplePos, Int)
nodePosAndLen String
file Node (Lexeme Text)
n =
    case (NodeF (Lexeme Text) [Lexeme Text] -> [Lexeme Text])
-> Node (Lexeme Text) -> [Lexeme Text]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme Text) [Lexeme Text] -> [Lexeme Text]
forall lexeme. NodeF lexeme [lexeme] -> [lexeme]
Flatten.lexemes Node (Lexeme Text)
n of
        []  -> (String -> Int -> Int -> CimplePos
CimplePos String
file Int
0 Int
0, Int
0)
        ls :: [Lexeme Text]
ls@(Lexeme Text
l:[Lexeme Text]
_)  ->
            let L (AlexPn Int
start Int
_ Int
_) LexemeClass
_ Text
_ = Lexeme Text
l
                L (AlexPn Int
end Int
_ Int
_) LexemeClass
_ Text
s = [Lexeme Text] -> Lexeme Text
forall p. [p] -> p
last' [Lexeme Text]
ls
            in (String -> Lexeme Text -> CimplePos
forall text. String -> Lexeme text -> CimplePos
lexemePos String
file Lexeme Text
l, Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)
  where
    last' :: [p] -> p
last' [p
x]    = p
x
    last' (p
_:[p]
xs) = [p] -> p
last' [p]
xs
    last' []     = String -> p
forall a. HasCallStack => String -> a
error String
"nodePosAndLen: empty list"

type DiagnosticsT diags a = State diags a
type Diagnostics a = DiagnosticsT [Text] a

warn
    :: (HasLocation at, HasDiagnostics diags)
    => FilePath -> at -> Text -> DiagnosticsT diags ()
warn :: String -> at -> Text -> DiagnosticsT diags ()
warn String
file at
l Text
w = (diags -> diags) -> DiagnosticsT diags ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Text -> diags -> diags
forall a. HasDiagnostics a => Text -> a -> a
addDiagnostic (Text -> diags -> diags) -> Text -> diags -> diags
forall a b. (a -> b) -> a -> b
$ String -> at -> Text
forall a. HasLocation a => String -> a -> Text
sloc String
file at
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w)

warnRich
    :: (HasDiagnosticsRich diags pos)
    => Diagnostic pos -> DiagnosticsT diags ()
warnRich :: Diagnostic pos -> DiagnosticsT diags ()
warnRich = (diags -> diags) -> DiagnosticsT diags ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((diags -> diags) -> DiagnosticsT diags ())
-> (Diagnostic pos -> diags -> diags)
-> Diagnostic pos
-> DiagnosticsT diags ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagnostic pos -> diags -> diags
forall a pos. HasDiagnosticsRich a pos => Diagnostic pos -> a -> a
addDiagnosticRich


class HasDiagnostics a where
    addDiagnostic :: Text -> a -> a

instance HasDiagnostics [Text] where
    addDiagnostic :: Text -> [Text] -> [Text]
addDiagnostic = (:)

class HasDiagnosticsRich a pos | a -> pos where
    addDiagnosticRich :: Diagnostic pos -> a -> a

instance HasDiagnosticsRich [Diagnostic pos] pos where
    addDiagnosticRich :: Diagnostic pos -> [Diagnostic pos] -> [Diagnostic pos]
addDiagnosticRich = (:)


renderPure :: IsPosition pos => Map FilePath [Text] -> [Diagnostic pos] -> [Doc AnsiStyle]
renderPure :: Map String [Text] -> [Diagnostic pos] -> [Doc AnsiStyle]
renderPure Map String [Text]
cache = (Diagnostic pos -> Doc AnsiStyle)
-> [Diagnostic pos] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (Map String [Text] -> Diagnostic pos -> Doc AnsiStyle
forall p.
IsPosition p =>
Map String [Text] -> Diagnostic p -> Doc AnsiStyle
formatRichError Map String [Text]
cache)
  where
    formatRichError :: Map String [Text] -> Diagnostic p -> Doc AnsiStyle
formatRichError Map String [Text]
cache' (Diagnostic p
p Int
len DiagnosticLevel
level Doc AnsiStyle
msg Maybe Text
flag [DiagnosticSpan p]
spans [(DiagnosticLevel, Doc AnsiStyle)]
footers) =
        [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
        [ let msgLines :: [Doc ann]
msgLines = (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> (Text -> Text) -> Text -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.stripEnd) ([Text] -> [Doc ann]) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines (String -> Text
Text.pack (Doc Any -> String
forall a. Show a => a -> String
show (Doc AnsiStyle -> Doc Any
forall ann xxx. Doc ann -> Doc xxx
PP.unAnnotate Doc AnsiStyle
msg)))
          in case [Doc AnsiStyle]
forall ann. [Doc ann]
msgLines of
            (Doc AnsiStyle
l:[Doc AnsiStyle]
ls) -> Doc AnsiStyle
header Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align ([Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ((case Maybe Text
flag of
                Just Text
f -> Doc AnsiStyle
l Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (Doc AnsiStyle
"[-W" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
f Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"]")
                Maybe Text
Nothing -> Doc AnsiStyle
l) Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
: [Doc AnsiStyle]
ls))
            []     -> case Maybe Text
flag of
                Just Text
f -> Doc AnsiStyle
header Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (Doc AnsiStyle
"[-W" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
f Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"]")
                Maybe Text
Nothing -> Doc AnsiStyle
header
        ] [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++
        [ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"-->") Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle
bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (p -> String
forall p. IsPosition p => p -> String
posFile p
p) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (p -> Int
forall p. IsPosition p => p -> Int
posLine p
p) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (p -> Int
forall p. IsPosition p => p -> Int
posColumn p
p))
        | p -> Bool
forall p. IsPosition p => p -> Bool
isRealPos p
p ] [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++
        (if [Doc AnsiStyle] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc AnsiStyle]
snippet then [] else [AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|")] [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle]
snippet) [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++
        ((DiagnosticLevel, Doc AnsiStyle) -> Doc AnsiStyle)
-> [(DiagnosticLevel, Doc AnsiStyle)] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (DiagnosticLevel, Doc AnsiStyle) -> Doc AnsiStyle
formatFooter [(DiagnosticLevel, Doc AnsiStyle)]
footers
      where
                header :: Doc AnsiStyle
header = case DiagnosticLevel
level of
                    DiagnosticLevel
ErrorLevel   -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red    AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"error:"
                    DiagnosticLevel
WarningLevel -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"warning:"
                    DiagnosticLevel
NoteLevel    -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Cyan   AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"note:"
                    DiagnosticLevel
HelpLevel    -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Green  AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"help:"

                spansToShow :: [DiagnosticSpan p]
spansToShow =
                    let primary :: DiagnosticSpan p
primary = p -> Int -> [Doc AnsiStyle] -> DiagnosticSpan p
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan p
p Int
len []
                        samePos :: p -> p -> Bool
samePos p
s1 p
s2 = p -> Bool
forall p. IsPosition p => p -> Bool
isRealPos p
s1 Bool -> Bool -> Bool
&& p -> Bool
forall p. IsPosition p => p -> Bool
isRealPos p
s2 Bool -> Bool -> Bool
&& p -> String
forall p. IsPosition p => p -> String
posFile p
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== p -> String
forall p. IsPosition p => p -> String
posFile p
s2 Bool -> Bool -> Bool
&& p -> Int
forall p. IsPosition p => p -> Int
posLine p
s1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== p -> Int
forall p. IsPosition p => p -> Int
posLine p
s2 Bool -> Bool -> Bool
&& p -> Int
forall p. IsPosition p => p -> Int
posColumn p
s1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== p -> Int
forall p. IsPosition p => p -> Int
posColumn p
s2
                    in if p -> Bool
forall p. IsPosition p => p -> Bool
isRealPos p
p Bool -> Bool -> Bool
&& (DiagnosticSpan p -> Bool) -> [DiagnosticSpan p] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\DiagnosticSpan p
s -> Bool -> Bool
not (p -> p -> Bool
forall p p. (IsPosition p, IsPosition p) => p -> p -> Bool
samePos (DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s) p
p)) [DiagnosticSpan p]
spans
                       then DiagnosticSpan p
primary DiagnosticSpan p -> [DiagnosticSpan p] -> [DiagnosticSpan p]
forall a. a -> [a] -> [a]
: [DiagnosticSpan p]
spans
                       else [DiagnosticSpan p]
spans

                width :: Int
width =
                    let lineNums :: [Int]
lineNums = [p -> Int
forall p. IsPosition p => p -> Int
posLine (DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s) | DiagnosticSpan p
s <- [DiagnosticSpan p]
spansToShow, p -> Bool
forall p. IsPosition p => p -> Bool
isRealPos (DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s)]
                        maxLine :: Int
maxLine = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
lineNums then Int
0 else [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
lineNums
                    in Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
4 (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
maxLine))

                posCompare :: DiagnosticSpan p -> DiagnosticSpan p -> Ordering
posCompare DiagnosticSpan p
s1 DiagnosticSpan p
s2 =
                    let p1 :: p
p1 = DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s1
                        p2 :: p
p2 = DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s2
                        isPrimary :: String -> Bool
isPrimary String
f = String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== p -> String
forall p. IsPosition p => p -> String
posFile p
p
                    in Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Bool -> Bool
not (String -> Bool
isPrimary (p -> String
forall p. IsPosition p => p -> String
posFile p
p1))) (Bool -> Bool
not (String -> Bool
isPrimary (p -> String
forall p. IsPosition p => p -> String
posFile p
p2))) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
                       String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (p -> String
forall p. IsPosition p => p -> String
posFile p
p1) (p -> String
forall p. IsPosition p => p -> String
posFile p
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
                       Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (p -> Int
forall p. IsPosition p => p -> Int
posLine p
p1) (p -> Int
forall p. IsPosition p => p -> Int
posLine p
p2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
                       Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (p -> Int
forall p. IsPosition p => p -> Int
posColumn p
p1) (p -> Int
forall p. IsPosition p => p -> Int
posColumn p
p2)

                posEqLine :: DiagnosticSpan p -> DiagnosticSpan p -> Bool
posEqLine DiagnosticSpan p
s1 DiagnosticSpan p
s2 =
                    let p1 :: p
p1 = DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s1
                        p2 :: p
p2 = DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s2
                    in p -> String
forall p. IsPosition p => p -> String
posFile p
p1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== p -> String
forall p. IsPosition p => p -> String
posFile p
p2 Bool -> Bool -> Bool
&& p -> Int
forall p. IsPosition p => p -> Int
posLine p
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== p -> Int
forall p. IsPosition p => p -> Int
posLine p
p2

                posEqFile :: DiagnosticSpan p -> DiagnosticSpan p -> Bool
posEqFile DiagnosticSpan p
s1 DiagnosticSpan p
s2 = p -> String
forall p. IsPosition p => p -> String
posFile (DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s1) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== p -> String
forall p. IsPosition p => p -> String
posFile (DiagnosticSpan p -> p
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan p
s2)

                groupedByFile :: [[DiagnosticSpan p]]
groupedByFile = (DiagnosticSpan p -> DiagnosticSpan p -> Bool)
-> [DiagnosticSpan p] -> [[DiagnosticSpan p]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy DiagnosticSpan p -> DiagnosticSpan p -> Bool
forall p p.
(IsPosition p, IsPosition p) =>
DiagnosticSpan p -> DiagnosticSpan p -> Bool
posEqFile ([DiagnosticSpan p] -> [[DiagnosticSpan p]])
-> [DiagnosticSpan p] -> [[DiagnosticSpan p]]
forall a b. (a -> b) -> a -> b
$ (DiagnosticSpan p -> DiagnosticSpan p -> Ordering)
-> [DiagnosticSpan p] -> [DiagnosticSpan p]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy DiagnosticSpan p -> DiagnosticSpan p -> Ordering
forall p p.
(IsPosition p, IsPosition p) =>
DiagnosticSpan p -> DiagnosticSpan p -> Ordering
posCompare [DiagnosticSpan p]
spansToShow

                renderFileGroup :: [DiagnosticSpan pos] -> [Doc AnsiStyle]
renderFileGroup gs :: [DiagnosticSpan pos]
gs@(DiagnosticSpan pos
s:[DiagnosticSpan pos]
_) =
                    let p_g :: pos
p_g = DiagnosticSpan pos -> pos
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan pos
s
                        sep :: [Doc AnsiStyle]
sep = if pos -> String
forall p. IsPosition p => p -> String
posFile pos
p_g String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= p -> String
forall p. IsPosition p => p -> String
posFile p
p
                              then [ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":::") Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle
bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (pos -> String
forall p. IsPosition p => p -> String
posFile pos
p_g) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (pos -> Int
forall p. IsPosition p => p -> Int
posLine pos
p_g) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (pos -> Int
forall p. IsPosition p => p -> Int
posColumn pos
p_g))
                                   , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|")
                                   ]
                              else []
                        lineGroups :: [[DiagnosticSpan pos]]
lineGroups = (DiagnosticSpan pos -> DiagnosticSpan pos -> Bool)
-> [DiagnosticSpan pos] -> [[DiagnosticSpan pos]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy DiagnosticSpan pos -> DiagnosticSpan pos -> Bool
forall p p.
(IsPosition p, IsPosition p) =>
DiagnosticSpan p -> DiagnosticSpan p -> Bool
posEqLine [DiagnosticSpan pos]
gs
                    in [Doc AnsiStyle]
sep [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ ([DiagnosticSpan pos] -> [Doc AnsiStyle])
-> [[DiagnosticSpan pos]] -> [Doc AnsiStyle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [DiagnosticSpan pos] -> [Doc AnsiStyle]
forall pos.
IsPosition pos =>
[DiagnosticSpan pos] -> [Doc AnsiStyle]
renderGrouped [[DiagnosticSpan pos]]
lineGroups
                renderFileGroup [] = []

                snippet :: [Doc AnsiStyle]
snippet = ([DiagnosticSpan p] -> [Doc AnsiStyle])
-> [[DiagnosticSpan p]] -> [Doc AnsiStyle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [DiagnosticSpan p] -> [Doc AnsiStyle]
forall pos.
IsPosition pos =>
[DiagnosticSpan pos] -> [Doc AnsiStyle]
renderFileGroup [[DiagnosticSpan p]]
groupedByFile

                formatFooter :: (DiagnosticLevel, Doc AnsiStyle) -> Doc AnsiStyle
formatFooter (DiagnosticLevel
l, Doc AnsiStyle
d) =
                    let pref :: Doc AnsiStyle
pref = case DiagnosticLevel
l of
                            DiagnosticLevel
ErrorLevel   -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red    AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"    = error:"
                            DiagnosticLevel
WarningLevel -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"    = warning:"
                            DiagnosticLevel
NoteLevel    -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Cyan   AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"    = note:"
                            DiagnosticLevel
HelpLevel    -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Green  AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
"    = help:"
                    in Doc AnsiStyle
pref Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align Doc AnsiStyle
d

                renderGrouped :: [DiagnosticSpan pos] -> [Doc AnsiStyle]
renderGrouped ss :: [DiagnosticSpan pos]
ss@(DiagnosticSpan pos
sp Int
_ [Doc AnsiStyle]
_ : [DiagnosticSpan pos]
_) =
                    let mFileLines :: Maybe [Text]
mFileLines = if pos -> Bool
forall p. IsPosition p => p -> Bool
isRealPos pos
sp then String -> Map String [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (pos -> String
forall p. IsPosition p => p -> String
posFile pos
sp) Map String [Text]
cache' else Maybe [Text]
forall a. Maybe a
Nothing
                        row :: Int
row = pos -> Int
forall p. IsPosition p => p -> Int
posLine pos
sp
                        rowStr :: String
rowStr = Int -> String
forall a. Show a => a -> String
show Int
row
                        gutterStr :: String
gutterStr = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rowStr)) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rowStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|"
                        gutter :: Doc ann
gutter = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
gutterStr
                        lineText :: [Doc ann]
lineText = case Maybe [Text]
mFileLines of
                                     Just [Text]
fileLines | Int
row Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
row Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fileLines ->
                                         [Doc ann
forall ann. Doc ann
gutter Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Text -> Text
expandTabs Int
8 ([Text]
fileLines [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))]
                                     Maybe [Text]
_ -> []
                        -- Group spans on the same line by position and merge labels
                        uniqueSpans :: [DiagnosticSpan pos]
uniqueSpans = ([DiagnosticSpan pos] -> DiagnosticSpan pos)
-> [[DiagnosticSpan pos]] -> [DiagnosticSpan pos]
forall a b. (a -> b) -> [a] -> [b]
map [DiagnosticSpan pos] -> DiagnosticSpan pos
forall pos. [DiagnosticSpan pos] -> DiagnosticSpan pos
mergeLabels ([[DiagnosticSpan pos]] -> [DiagnosticSpan pos])
-> ([DiagnosticSpan pos] -> [[DiagnosticSpan pos]])
-> [DiagnosticSpan pos]
-> [DiagnosticSpan pos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticSpan pos -> DiagnosticSpan pos -> Bool)
-> [DiagnosticSpan pos] -> [[DiagnosticSpan pos]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> (DiagnosticSpan pos -> (Int, Int))
-> DiagnosticSpan pos
-> DiagnosticSpan pos
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DiagnosticSpan pos -> (Int, Int)
forall p. IsPosition p => DiagnosticSpan p -> (Int, Int)
posAndLen') ([DiagnosticSpan pos] -> [[DiagnosticSpan pos]])
-> ([DiagnosticSpan pos] -> [DiagnosticSpan pos])
-> [DiagnosticSpan pos]
-> [[DiagnosticSpan pos]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticSpan pos -> DiagnosticSpan pos -> Ordering)
-> [DiagnosticSpan pos] -> [DiagnosticSpan pos]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> (DiagnosticSpan pos -> (Int, Int))
-> DiagnosticSpan pos
-> DiagnosticSpan pos
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DiagnosticSpan pos -> (Int, Int)
forall p. IsPosition p => DiagnosticSpan p -> (Int, Int)
posAndLen') ([DiagnosticSpan pos] -> [DiagnosticSpan pos])
-> [DiagnosticSpan pos] -> [DiagnosticSpan pos]
forall a b. (a -> b) -> a -> b
$ [DiagnosticSpan pos]
ss
                        posAndLen' :: DiagnosticSpan p -> (Int, Int)
posAndLen' (DiagnosticSpan p
s Int
le [Doc AnsiStyle]
_) = (p -> Int
forall p. IsPosition p => p -> Int
posColumn p
s, Int
le)
                        mergeLabels :: [DiagnosticSpan pos] -> DiagnosticSpan pos
mergeLabels [] = String -> DiagnosticSpan pos
forall a. HasCallStack => String -> a
error String
"mergeLabels: empty group"
                        mergeLabels (DiagnosticSpan pos
s Int
le [Doc AnsiStyle]
labels : [DiagnosticSpan pos]
samePosSpans) =
                            let allLabels :: [Doc AnsiStyle]
allLabels = [Doc AnsiStyle]
labels [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ (DiagnosticSpan pos -> [Doc AnsiStyle])
-> [DiagnosticSpan pos] -> [Doc AnsiStyle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DiagnosticSpan pos -> [Doc AnsiStyle]
forall pos. DiagnosticSpan pos -> [Doc AnsiStyle]
spanLabels [DiagnosticSpan pos]
samePosSpans
                            in pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan pos
s Int
le [Doc AnsiStyle]
allLabels

                        sourceLine :: Text
sourceLine = case Maybe [Text]
mFileLines of
                            Just [Text]
fileLines | Int
row Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
row Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fileLines -> [Text]
fileLines [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                            Maybe [Text]
_ -> Text
""
                    in [Doc AnsiStyle]
forall ann. [Doc ann]
lineText [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ (DiagnosticSpan pos -> [Doc AnsiStyle])
-> [DiagnosticSpan pos] -> [Doc AnsiStyle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DiagnosticSpan pos -> [Doc AnsiStyle]
forall pos.
IsPosition pos =>
Text -> DiagnosticSpan pos -> [Doc AnsiStyle]
renderSp Text
sourceLine) [DiagnosticSpan pos]
uniqueSpans
                renderGrouped [] = []

                renderSp :: Text -> DiagnosticSpan pos -> [Doc AnsiStyle]
renderSp Text
sourceLine (DiagnosticSpan pos
sp Int
l [Doc AnsiStyle]
labels) =
                    let col :: Int
col = pos -> Int
forall p. IsPosition p => p -> Int
posColumn pos
sp
                        -- 'col' is 1-based byte offset.
                        -- We need to find how many characters are before this byte offset.
                        charCol :: Int
charCol = Text -> Int -> Int
byteToCharOffset Text
sourceLine (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                        -- Extract the prefix up to that character offset.
                        prefix :: Text
prefix = Int -> Text -> Text
Text.take Int
charCol Text
sourceLine
                        -- Calculate visual width of that prefix (handling tabs).
                        visualCol :: Int
visualCol = Text -> Int
Text.length (Int -> Text -> Text
expandTabs Int
8 Text
prefix)

                        -- Calculate visual width of the span.
                        spanText :: Text
spanText = Int -> Text -> Text
Text.take (Text -> Int -> Int
byteToCharOffset (Int -> Text -> Text
Text.drop Int
charCol Text
sourceLine) Int
l) (Int -> Text -> Text
Text.drop Int
charCol Text
sourceLine)
                        visualLen :: Int
visualLen = Text -> Int
Text.length (Int -> Text -> Text
expandTabs Int
8 Text
spanText)

                        padding :: String
padding = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
visualCol Char
' '
                        underline :: Doc AnsiStyle
underline = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
padding Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
visualLen) Char
'^'))
                        labelDocs :: [Doc AnsiStyle]
labelDocs = (Doc AnsiStyle -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (\Doc AnsiStyle
lab -> Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
padding Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align Doc AnsiStyle
lab) [Doc AnsiStyle]
labels
                        fullLabel :: Doc AnsiStyle
fullLabel = if [Doc AnsiStyle] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc AnsiStyle]
labels
                                    then Doc AnsiStyle
forall a. Monoid a => a
mempty
                                    else Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
padding Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat [Doc AnsiStyle]
labelDocs
                    in [ String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
' ') Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"|" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
underline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
fullLabel ]

expandTabs :: Int -> Text -> Text
expandTabs :: Int -> Text -> Text
expandTabs Int
tabWidth = String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
go Int
0 ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  where
    go :: Int -> ShowS
go Int
_ [] = []
    go Int
col (Char
c:String
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' =
          let spaces :: Int
spaces = Int
tabWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
col Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabWidth)
          in Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
spaces Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
go (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spaces) String
cs
      | Bool
otherwise = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> ShowS
go (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
cs

byteToCharOffset :: Text -> Int -> Int
byteToCharOffset :: Text -> Int -> Int
byteToCharOffset Text
t Int
byteOffset =
    let bs :: ByteString
bs = Text -> ByteString
Text.encodeUtf8 Text
t
    in if Int
byteOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
BS.length ByteString
bs
       then Text -> Int
Text.length Text
t
       else Text -> Int
Text.length (ByteString -> Text
Text.decodeUtf8 (Int -> ByteString -> ByteString
BS.take Int
byteOffset ByteString
bs))