{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wno-name-shadowing #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Error.Diagnose.Report.Internal
-- Description : Internal workings for report definitions and pretty printing.
-- Copyright   : (c) Mesabloo, 2021
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
--
-- /Warning/: The API of this module can break between two releases, therefore you should not rely on it.
--            It is also highly undocumented.
--
--            Please limit yourself to the "Error.Diagnose.Report" module, which exports some of the useful functions defined here.
module Error.Diagnose.Report.Internal where

#ifdef USE_AESON
import Data.Aeson (ToJSON(..), object, (.=))
#endif
import Control.Applicative ((<|>))
import Data.Bifunctor (bimap, first, second)
import Data.Char.WCWidth (wcwidth)
import Data.Default (def)
import Data.Foldable (fold)
import Data.Function (on)
import Data.Functor ((<&>))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashMap.Lazy as IntMap
import qualified Data.List as List
import qualified Data.List.Safe as List
import Data.Ord (Down (Down))
import Error.Diagnose.Position
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>))
import Prettyprinter.Internal (Doc (..))
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)

-- | The type of diagnostic reports with abstract message type.
data Report msg
  = Report
      Bool
      -- ^ Is the report a warning or an error?
      (Maybe msg)
      -- ^ An optional error code to print at the top.
      msg
      -- ^ The message associated with the error.
      [(Position, Marker msg)]
      -- ^ A map associating positions with marker to show under the source code.
      [msg]
      -- ^ A list of hints to add at the end of the report.

instance Semigroup msg => Semigroup (Report msg) where
  Report Bool
isError1 Maybe msg
code1 msg
msg1 [(Position, Marker msg)]
pos1 [msg]
hints1 <> :: Report msg -> Report msg -> Report msg
<> Report Bool
isError2 Maybe msg
code2 msg
msg2 [(Position, Marker msg)]
pos2 [msg]
hints2 =
    Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
Report (Bool
isError1 Bool -> Bool -> Bool
|| Bool
isError2) (Maybe msg
code1 Maybe msg -> Maybe msg -> Maybe msg
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe msg
code2) (msg
msg1 msg -> msg -> msg
forall a. Semigroup a => a -> a -> a
<> msg
msg2) ([(Position, Marker msg)]
pos1 [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
pos2) ([msg]
hints1 [msg] -> [msg] -> [msg]
forall a. Semigroup a => a -> a -> a
<> [msg]
hints2)

instance Monoid msg => Monoid (Report msg) where
  mempty :: Report msg
mempty = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
Report Bool
False Maybe msg
forall a. Maybe a
Nothing msg
forall a. Monoid a => a
mempty [(Position, Marker msg)]
forall a. Monoid a => a
mempty [msg]
forall a. Monoid a => a
mempty

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Report msg) where
  toJSON :: Report msg -> Value
toJSON (Report Bool
isError Maybe msg
code msg
msg [(Position, Marker msg)]
markers [msg]
hints) =
    [Pair] -> Value
object [ Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (if Bool
isError then String
"error" else String
"warning" :: String)
           , Text
"code" Text -> Maybe msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe msg
code
           , Text
"message" Text -> msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= msg
msg
           , Text
"markers" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Position, Marker msg) -> Value)
-> [(Position, Marker msg)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Position, Marker msg) -> Value
forall v v. (ToJSON v, ToJSON v) => (v, Marker v) -> Value
showMarker [(Position, Marker msg)]
markers
           , Text
"hints" Text -> [msg] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [msg]
hints
           ]
    where
      showMarker :: (v, Marker v) -> Value
showMarker (v
pos, Marker v
marker) =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Text
"position" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
pos ]
              [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> case Marker v
marker of
                   This v
m  -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
                              , Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"this" :: String)
                              ]
                   Where v
m -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
                              , Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"where" :: String)
                              ]
                   Maybe v
m -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
                              , Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"maybe" :: String)
                              ]
#endif

-- | The type of markers with abstract message type, shown under code lines.
data Marker msg
  = -- | A red or yellow marker under source code, marking important parts of the code.
    This msg
  | -- | A blue marker symbolizing additional information.
    Where msg
  | -- | A magenta marker to report potential fixes.
    Maybe msg

instance Eq (Marker msg) where
  This msg
_ == :: Marker msg -> Marker msg -> Bool
== This msg
_ = Bool
True
  Where msg
_ == Where msg
_ = Bool
True
  Maybe msg
_ == Maybe msg
_ = Bool
True
  Marker msg
_ == Marker msg
_ = Bool
False
  {-# INLINEABLE (==) #-}

instance Ord (Marker msg) where
  This msg
_ < :: Marker msg -> Marker msg -> Bool
< Marker msg
_ = Bool
False
  Where msg
_ < This msg
_ = Bool
True
  Where msg
_ < Marker msg
_ = Bool
False
  Maybe msg
_ < Marker msg
_ = Bool
True
  {-# INLINEABLE (<) #-}

  Marker msg
m1 <= :: Marker msg -> Marker msg -> Bool
<= Marker msg
m2 = Marker msg
m1 Marker msg -> Marker msg -> Bool
forall a. Ord a => a -> a -> Bool
< Marker msg
m2 Bool -> Bool -> Bool
|| Marker msg
m1 Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
== Marker msg
m2
  {-# INLINEABLE (<=) #-}

-- | Constructs a warning or an error report.
warn,
  err ::
    -- | An optional error code to be shown right next to "error" or "warning".
    Maybe msg ->
    -- | The report message, shown at the very top.
    msg ->
    -- | A list associating positions with markers.
    [(Position, Marker msg)] ->
    -- | A possibly mempty list of hints to add at the end of the report.
    [msg] ->
    Report msg
warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
warn = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
Report Bool
False
{-# INLINE warn #-}
err :: Maybe msg -> msg -> [(Position, Marker msg)] -> [msg] -> Report msg
err = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
Report Bool
True
{-# INLINE err #-}

-- | Pretty prints a report to a 'Doc' handling colors.
prettyReport ::
  Pretty msg =>
  -- | The content of the file the reports are for
  HashMap FilePath [String] ->
  -- | Should we print paths in unicode?
  Bool ->
  -- | The number of spaces each TAB character will span
  Int ->
  -- | The whole report to output
  Report msg ->
  Doc AnsiStyle
prettyReport :: HashMap String [String]
-> Bool -> Int -> Report msg -> Doc AnsiStyle
prettyReport HashMap String [String]
fileContent Bool
withUnicode Int
tabSize (Report Bool
isError Maybe msg
code msg
message [(Position, Marker msg)]
markers [msg]
hints) =
  let sortedMarkers :: [(Position, Marker msg)]
sortedMarkers = ((Position, Marker msg) -> Int)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker msg)]
markers
      -- sort the markers so that the first lines of the reports are the first lines of the file

      groupedMarkers :: [(Bool, [(Position, Marker msg)])]
groupedMarkers = [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
forall msg.
Pretty msg =>
[(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [(Position, Marker msg)]
sortedMarkers
      -- group markers by the file they appear in, and put `This` markers at the top of the report

      maxLineNumberLength :: Int
maxLineNumberLength = Int
-> ((Position, Marker msg) -> Int)
-> Maybe (Position, Marker msg)
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
3 (Int -> Int)
-> ((Position, Marker msg) -> Int) -> (Position, Marker msg) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((Position, Marker msg) -> String)
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Position, Marker msg) -> Int)
-> (Position, Marker msg)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
end (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) (Maybe (Position, Marker msg) -> Int)
-> Maybe (Position, Marker msg) -> Int
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
markers
      -- if there are no markers, then default to 3, else get the maximum between 3 and the length of the last marker

      header :: Doc AnsiStyle
header =
        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 if Bool
isError then Color
Red else Color
Yellow)
          ( Doc AnsiStyle
forall ann. Doc ann
lbracket
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isError
                     then Doc AnsiStyle
"error"
                     else Doc AnsiStyle
"warning"
                 )
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> case Maybe msg
code of
                Maybe msg
Nothing -> Doc AnsiStyle
forall ann. Doc ann
rbracket
                Just msg
code -> Doc AnsiStyle
forall ann. Doc ann
space Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> msg -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty msg
code Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
rbracket
          )
   in {-
              A report is of the form:
              (1)    [error|warning]: <message>
              (2)           +--> <file>
              (3)           :
              (4)    <line> | <line of code>
                            : <marker lines>
                            : <marker messages>
              (5)           :
                            : <hints>
              (6)    -------+
      -}

      {- (1) -} Doc AnsiStyle
header Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
colon 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 (msg -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty msg
message)
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (2), (3), (4) -} [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((Bool -> [(Position, Marker msg)] -> Doc AnsiStyle)
-> (Bool, [(Position, Marker msg)]) -> Doc AnsiStyle
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc AnsiStyle
forall msg.
Pretty msg =>
HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc AnsiStyle
prettySubReport HashMap String [String]
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength) ((Bool, [(Position, Marker msg)]) -> Doc AnsiStyle)
-> [(Bool, [(Position, Marker msg)])] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, [(Position, Marker msg)])]
groupedMarkers)
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (5) -} ( if
                           | [msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [msg]
hints Bool -> Bool -> Bool
&& [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
markers -> Doc AnsiStyle
forall a. Monoid a => a
mempty
                           | [msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [msg]
hints -> Doc AnsiStyle
forall a. Monoid a => a
mempty
                           | Bool
otherwise -> Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc AnsiStyle
dotPrefix Int
maxLineNumberLength Bool
withUnicode
                     )
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [msg] -> Int -> Bool -> Doc AnsiStyle
forall msg. Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle
prettyAllHints [msg]
hints Int
maxLineNumberLength Bool
withUnicode
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (6) -} ( if [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
markers Bool -> Bool -> Bool
&& [msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [msg]
hints
                         then Doc AnsiStyle
forall a. Monoid a => a
mempty
                         else
                           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
Black) (Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (if Bool
withUnicode then Char
'─' else Char
'-') Doc AnsiStyle
forall a. Monoid a => a
mempty Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> if Bool
withUnicode then Doc AnsiStyle
"╯" else Doc AnsiStyle
"+")
                             Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
                     )

-------------------------------------------------------------------------------------
----- INTERNAL STUFF ----------------------------------------------------------------
-------------------------------------------------------------------------------------

-- | Inserts a given number of character after a 'Doc'ument.
pad :: Int -> Char -> Doc ann -> Doc ann
pad :: Int -> Char -> Doc ann -> Doc ann
pad Int
n Char
c Doc ann
d = Doc ann -> (Int -> Doc ann) -> Doc ann
forall ann. Doc ann -> (Int -> Doc ann) -> Doc ann
width Doc ann
d \Int
w -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w) Char
c

-- | Creates a "dot"-prefix for a report line where there is no code.
--
--   Pretty printing yields those results:
--
--   [with unicode] "@␣␣␣␣␣•␣@"
--   [without unicode] "@␣␣␣␣␣:␣@"
dotPrefix ::
  -- | The length of the left space before the bullet.
  Int ->
  -- | Whether to print with unicode characters or not.
  Bool ->
  Doc AnsiStyle
dotPrefix :: Int -> Bool -> Doc AnsiStyle
dotPrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc AnsiStyle
forall a. Monoid a => a
mempty 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
Black) (if Bool
withUnicode then Doc AnsiStyle
"•" else Doc AnsiStyle
":")
{-# INLINE dotPrefix #-}

-- | Creates a "pipe"-prefix for a report line where there is no code.
--
--   Pretty printing yields those results:
--
--   [with unicode] "@␣␣␣␣␣│␣@"
--   [without unicode] "@␣␣␣␣␣|␣@"
pipePrefix ::
  -- | The length of the left space before the pipe.
  Int ->
  -- | Whether to print with unicode characters or not.
  Bool ->
  Doc AnsiStyle
pipePrefix :: Int -> Bool -> Doc AnsiStyle
pipePrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc AnsiStyle
forall a. Monoid a => a
mempty 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
Black) (if Bool
withUnicode then Doc AnsiStyle
"│" else Doc AnsiStyle
"|")
{-# INLINE pipePrefix #-}

-- | Creates a line-prefix for a report line containing source code
--
--   Pretty printing yields those results:
--
--   [with unicode] "@␣␣␣3␣│␣@"
--   [without unicode] "@␣␣␣3␣|␣@"
--
--   Results may be different, depending on the length of the line number.
linePrefix ::
  -- | The length of the amount of space to span before the vertical bar.
  Int ->
  -- | The line number to show.
  Int ->
  -- | Whether to use unicode characters or not.
  Bool ->
  Doc AnsiStyle
linePrefix :: Int -> Int -> Bool -> Doc AnsiStyle
linePrefix Int
leftLen Int
lineNo Bool
withUnicode =
  let lineNoLen :: Int
lineNoLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
lineNo)
   in 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
Black) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
forall a. Monoid a => a
mempty Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
leftLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNoLen) Char
' ' Doc AnsiStyle
forall a. Monoid a => a
mempty 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 Int
lineNo Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
withUnicode then Doc AnsiStyle
"│" else Doc AnsiStyle
"|"
{-# INLINE linePrefix #-}

groupMarkersPerFile ::
  Pretty msg =>
  [(Position, Marker msg)] ->
  [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile :: [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [] = []
groupMarkersPerFile [(Position, Marker msg)]
markers =
  let markersPerFile :: HashMap String [(Position, Marker msg)]
markersPerFile = (HashMap String [(Position, Marker msg)]
 -> HashMap String [(Position, Marker msg)]
 -> HashMap String [(Position, Marker msg)])
-> HashMap String [(Position, Marker msg)]
-> [HashMap String [(Position, Marker msg)]]
-> HashMap String [(Position, Marker msg)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (([(Position, Marker msg)]
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
(<>)) HashMap String [(Position, Marker msg)]
forall a. Monoid a => a
mempty ([HashMap String [(Position, Marker msg)]]
 -> HashMap String [(Position, Marker msg)])
-> [HashMap String [(Position, Marker msg)]]
-> HashMap String [(Position, Marker msg)]
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)]
markers [(Position, Marker msg)]
-> ((Position, Marker msg)
    -> HashMap String [(Position, Marker msg)])
-> [HashMap String [(Position, Marker msg)]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \tup :: (Position, Marker msg)
tup@(Position
p, Marker msg
_) -> String
-> [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (Position -> String
file Position
p) [(Position, Marker msg)
tup]
   in -- put all markers on the same file together
      -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) mempty` does not exist

      [[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])]
forall b. [b] -> [(Bool, b)]
onlyFirstToTrue ([[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])])
-> [[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])]
forall a b. (a -> b) -> a -> b
$ [[(Position, Marker msg)]] -> [[(Position, Marker msg)]]
forall a msg. [[(a, Marker msg)]] -> [[(a, Marker msg)]]
putThisMarkersAtTop ([[(Position, Marker msg)]] -> [[(Position, Marker msg)]])
-> [[(Position, Marker msg)]] -> [[(Position, Marker msg)]]
forall a b. (a -> b) -> a -> b
$ HashMap String [(Position, Marker msg)]
-> [[(Position, Marker msg)]]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap String [(Position, Marker msg)]
markersPerFile
  where
    onlyFirstToTrue :: [b] -> [(Bool, b)]
onlyFirstToTrue = Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
forall b. Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
True []

    go :: Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
_ [(Bool, b)]
acc [] = [(Bool, b)] -> [(Bool, b)]
forall a. [a] -> [a]
reverse [(Bool, b)]
acc
    go Bool
t [(Bool, b)]
acc (b
x : [b]
xs) = Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
False ((Bool
t, b
x) (Bool, b) -> [(Bool, b)] -> [(Bool, b)]
forall a. a -> [a] -> [a]
: [(Bool, b)]
acc) [b]
xs

    putThisMarkersAtTop :: [[(a, Marker msg)]] -> [[(a, Marker msg)]]
putThisMarkersAtTop = ([(a, Marker msg)] -> [(a, Marker msg)] -> Ordering)
-> [[(a, Marker msg)]] -> [[(a, Marker msg)]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy \[(a, Marker msg)]
ms1 [(a, Marker msg)]
ms2 ->
      if
          | (Marker msg -> Bool) -> [Marker msg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Marker msg -> Bool
forall msg. Marker msg -> Bool
isThisMarker ((a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Marker msg)
-> [(a, Marker msg)] -> [Marker msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)]
ms1) -> Ordering
LT
          | (Marker msg -> Bool) -> [Marker msg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Marker msg -> Bool
forall msg. Marker msg -> Bool
isThisMarker ((a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Marker msg)
-> [(a, Marker msg)] -> [Marker msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)]
ms2) -> Ordering
GT
          | Bool
otherwise -> Ordering
EQ

-- | Prettyprint a sub-report, which is a part of the report spanning across a single file
prettySubReport ::
  Pretty msg =>
  -- | The content of files in the diagnostics
  HashMap FilePath [String] ->
  -- | Is the output done with Unicode characters?
  Bool ->
  -- | Is the current report an error report?
  Bool ->
  -- | The number of spaces each TAB character will span
  Int ->
  -- | The size of the biggest line number
  Int ->
  -- | Is this sub-report the first one in the list?
  Bool ->
  -- | The list of line-ordered markers appearing in a single file
  [(Position, Marker msg)] ->
  Doc AnsiStyle
prettySubReport :: HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc AnsiStyle
prettySubReport HashMap String [String]
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength Bool
isFirst [(Position, Marker msg)]
markers =
  let (HashMap Int [(Position, Marker msg)]
markersPerLine, [(Position, Marker msg)]
multilineMarkers) = [(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker msg)]
markers
      -- split the list on whether markers are multiline or not

      sortedMarkersPerLine :: [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} ((Int, [(Position, Marker msg)]) -> Int)
-> [(Int, [(Position, Marker msg)])]
-> [(Int, [(Position, Marker msg)])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst (HashMap Int [(Position, Marker msg)]
-> [(Int, [(Position, Marker msg)])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Int [(Position, Marker msg)]
markersPerLine)

      reportFile :: Doc ann
reportFile = Doc ann
-> ((Position, Marker msg) -> Doc ann)
-> Maybe (Position, Marker msg)
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty @Position Position
forall a. Default a => a
def) (Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Position -> Doc ann)
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) (Maybe (Position, Marker msg) -> Doc ann)
-> Maybe (Position, Marker msg) -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead (((Position, Marker msg) -> Down (Marker msg))
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Marker msg -> Down (Marker msg)
forall a. a -> Down a
Down (Marker msg -> Down (Marker msg))
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Down (Marker msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) [(Position, Marker msg)]
markers)
      -- the reported file is the file of the first 'This' marker (only one must be present)

      allLineNumbers :: [Int]
allLineNumbers = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
List.sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
List.nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst ((Int, [(Position, Marker msg)]) -> Int)
-> [(Int, [(Position, Marker msg)])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine) [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> ([(Position, Marker msg)]
multilineMarkers [(Position, Marker msg)]
-> ((Position, Marker msg) -> [Int]) -> [Int]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> [Int
bl .. Int
el])

      fileMarker :: Doc AnsiStyle
fileMarker =
        ( if Bool
isFirst
            then
              Doc AnsiStyle
forall ann. Doc ann
space Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
maxLineNumberLength Char
' ' Doc AnsiStyle
forall a. Monoid a => a
mempty
                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
Black) (if Bool
withUnicode then Doc AnsiStyle
"╭──▶" else Doc AnsiStyle
"+-->")
            else
              Doc AnsiStyle
forall ann. Doc ann
space Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Doc AnsiStyle
dotPrefix Int
maxLineNumberLength Bool
withUnicode Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> 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
Black) (Int -> Char -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (if Bool
withUnicode then Char
'─' else Char
'-') Doc AnsiStyle
forall a. Monoid a => a
mempty)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> 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
Black) (if Bool
withUnicode then Doc AnsiStyle
"┼──▶" else 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
colorDull Color
Green) Doc AnsiStyle
forall ann. Doc ann
reportFile
   in {- (2) -} Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
fileMarker
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
          Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> {- (3) -} Int -> Bool -> Doc AnsiStyle
pipePrefix Int
maxLineNumberLength Bool
withUnicode
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (4) -} HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc AnsiStyle
forall msg.
Pretty msg =>
HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc AnsiStyle
prettyAllLines HashMap String [String]
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine [(Position, Marker msg)]
multilineMarkers [Int]
allLineNumbers

isThisMarker :: Marker msg -> Bool
isThisMarker :: Marker msg -> Bool
isThisMarker (This msg
_) = Bool
True
isThisMarker Marker msg
_ = Bool
False

-- |
splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine :: [(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [] = (HashMap Int [(Position, Marker msg)]
forall a. Monoid a => a
mempty, [(Position, Marker msg)]
forall a. Monoid a => a
mempty)
splitMarkersPerLine (m :: (Position, Marker msg)
m@(Position {String
(Int, Int)
file :: String
end :: (Int, Int)
begin :: (Int, Int)
file :: Position -> String
end :: Position -> (Int, Int)
begin :: Position -> (Int, Int)
..}, Marker msg
_) : [(Position, Marker msg)]
ms) =
  let (Int
bl, Int
_) = (Int, Int)
begin
      (Int
el, Int
_) = (Int, Int)
end
   in (if Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
el then (HashMap Int [(Position, Marker msg)]
 -> HashMap Int [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (([(Position, Marker msg)]
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> Int
-> [(Position, Marker msg)]
-> HashMap Int [(Position, Marker msg)]
-> HashMap Int [(Position, Marker msg)]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
(<>) Int
bl [(Position, Marker msg)
m]) else ([(Position, Marker msg)] -> [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Position, Marker msg)
m (Position, Marker msg)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. a -> [a] -> [a]
:))
        ([(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker msg)]
ms)

-- |
prettyAllLines ::
  Pretty msg =>
  HashMap FilePath [String] ->
  Bool ->
  Bool ->
  -- | The number of spaces each TAB character will span
  Int ->
  Int ->
  [(Int, [(Position, Marker msg)])] ->
  [(Position, Marker msg)] ->
  [Int] ->
  Doc AnsiStyle
prettyAllLines :: HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc AnsiStyle
prettyAllLines HashMap String [String]
_ Bool
_ Bool
_ Int
_ Int
_ [(Int, [(Position, Marker msg)])]
_ [] [] = Doc AnsiStyle
forall a. Monoid a => a
mempty
prettyAllLines HashMap String [String]
_ Bool
withUnicode Bool
isError Int
_ Int
leftLen [(Int, [(Position, Marker msg)])]
_ [(Position, Marker msg)]
multiline [] =
  let colorOfLastMultilineMarker :: AnsiStyle
colorOfLastMultilineMarker = AnsiStyle
-> ((Position, Marker msg) -> AnsiStyle)
-> Maybe (Position, Marker msg)
-> AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnsiStyle
forall a. Monoid a => a
mempty (Bool -> Marker msg -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError (Marker msg -> AnsiStyle)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) ([(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
multiline)
      -- take the color of the last multiline marker in case we need to add additional bars

      prefix :: Doc AnsiStyle
prefix = Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc AnsiStyle
dotPrefix Int
leftLen Bool
withUnicode Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
space
      prefixWithBar :: AnsiStyle -> Doc AnsiStyle
prefixWithBar AnsiStyle
color = Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
color (if Bool
withUnicode then Doc AnsiStyle
"│ " else Doc AnsiStyle
"| ")

      showMultilineMarkerMessage :: (a, Marker a) -> Bool -> Doc AnsiStyle
showMultilineMarkerMessage (a
_, Marker a
marker) Bool
isLast =
        AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker a
marker) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
          ( if Bool
isLast
              then if Bool
withUnicode then Doc AnsiStyle
"╰╸ " else Doc AnsiStyle
"`- "
              else if Bool
withUnicode then Doc AnsiStyle
"├╸ " else Doc AnsiStyle
"|- "
          )
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (if Bool
isLast then Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"   " else AnsiStyle -> Doc AnsiStyle
prefixWithBar (Bool -> Marker a -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker a
marker) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
space) (a -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc AnsiStyle) -> a -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Marker a -> a
forall msg. Marker msg -> msg
markerMessage Marker a
marker)

      showMultilineMarkerMessages :: [(a, Marker a)] -> [Doc AnsiStyle]
showMultilineMarkerMessages [] = []
      showMultilineMarkerMessages [(a, Marker a)
m] = [(a, Marker a) -> Bool -> Doc AnsiStyle
forall a a. Pretty a => (a, Marker a) -> Bool -> Doc AnsiStyle
showMultilineMarkerMessage (a, Marker a)
m Bool
True]
      showMultilineMarkerMessages ((a, Marker a)
m : [(a, Marker a)]
ms) = (a, Marker a) -> Bool -> Doc AnsiStyle
forall a a. Pretty a => (a, Marker a) -> Bool -> Doc AnsiStyle
showMultilineMarkerMessage (a, Marker a)
m Bool
False Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
: [(a, Marker a)] -> [Doc AnsiStyle]
showMultilineMarkerMessages [(a, Marker a)]
ms
   in AnsiStyle -> Doc AnsiStyle
prefixWithBar AnsiStyle
colorOfLastMultilineMarker Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
List.intersperse Doc AnsiStyle
prefix ([Doc AnsiStyle] -> [Doc AnsiStyle])
-> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> [Doc AnsiStyle]
forall a a. Pretty a => [(a, Marker a)] -> [Doc AnsiStyle]
showMultilineMarkerMessages ([(Position, Marker msg)] -> [Doc AnsiStyle])
-> [(Position, Marker msg)] -> [Doc AnsiStyle]
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. [a] -> [a]
reverse [(Position, Marker msg)]
multiline)
prettyAllLines HashMap String [String]
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
multiline (Int
line : [Int]
ls) =
  {-
      A line of code is composed of:
      (1)     <line> | <source code>
      (2)            : <markers>
      (3)            : <marker messages>

      Multline markers may also take additional space (2 characters) on the right of the bar
  -}
  let allInlineMarkersInLine :: [(Position, Marker msg)]
allInlineMarkersInLine = (Int, [(Position, Marker msg)]) -> [(Position, Marker msg)]
forall a b. (a, b) -> b
snd ((Int, [(Position, Marker msg)]) -> [(Position, Marker msg)])
-> [(Int, [(Position, Marker msg)])] -> [(Position, Marker msg)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Int, [(Position, Marker msg)]) -> Bool)
-> [(Int, [(Position, Marker msg)])]
-> [(Int, [(Position, Marker msg)])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
line (Int -> Bool)
-> ((Int, [(Position, Marker msg)]) -> Int)
-> (Int, [(Position, Marker msg)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst) [(Int, [(Position, Marker msg)])]
inline

      allMultilineMarkersInLine :: [(Position, Marker msg)]
allMultilineMarkersInLine = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
|| Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line

      allMultilineMarkersSpanningLine :: [(Position, Marker msg)]
allMultilineMarkersSpanningLine = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
line Bool -> Bool -> Bool
&& Int
el Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
line

      inSpanOfMultiline :: Bool
inSpanOfMultiline = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)] -> Bool)
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
line Bool -> Bool -> Bool
&& Int
el Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
line

      colorOfFirstMultilineMarker :: Doc AnsiStyle -> Doc AnsiStyle
colorOfFirstMultilineMarker = (Doc AnsiStyle -> Doc AnsiStyle)
-> ((Position, Marker msg) -> Doc AnsiStyle -> Doc AnsiStyle)
-> Maybe (Position, Marker msg)
-> Doc AnsiStyle
-> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle -> Doc AnsiStyle
forall a. a -> a
id (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> ((Position, Marker msg) -> AnsiStyle)
-> (Position, Marker msg)
-> Doc AnsiStyle
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Marker msg -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError (Marker msg -> AnsiStyle)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) ([(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead ([(Position, Marker msg)] -> Maybe (Position, Marker msg))
-> [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)]
allMultilineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersSpanningLine)
      -- take the first multiline marker to color the entire line, if there is one

      !additionalPrefix :: Doc AnsiStyle
additionalPrefix = case [(Position, Marker msg)]
allMultilineMarkersInLine of
        [] ->
          if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
multiline
            then
              if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
allMultilineMarkersSpanningLine
                then Doc AnsiStyle -> Doc AnsiStyle
colorOfFirstMultilineMarker if Bool
withUnicode then Doc AnsiStyle
"│  " else Doc AnsiStyle
"|  "
                else Doc AnsiStyle
"   "
            else Doc AnsiStyle
forall a. Monoid a => a
mempty
        (p :: Position
p@(Position (Int, Int)
_ (Int
el, Int
_) String
_), Marker msg
marker) : [(Position, Marker msg)]
_ ->
          let hasPredecessor :: Bool
hasPredecessor = Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
|| Bool
-> (((Position, Marker msg), [(Position, Marker msg)]) -> Bool)
-> Maybe ((Position, Marker msg), [(Position, Marker msg)])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Position
p (Position -> Bool)
-> (((Position, Marker msg), [(Position, Marker msg)]) -> Position)
-> ((Position, Marker msg), [(Position, Marker msg)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Position)
-> (((Position, Marker msg), [(Position, Marker msg)])
    -> (Position, Marker msg))
-> ((Position, Marker msg), [(Position, Marker msg)])
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Position, Marker msg), [(Position, Marker msg)])
-> (Position, Marker msg)
forall a b. (a, b) -> a
fst) ([(Position, Marker msg)]
-> Maybe ((Position, Marker msg), [(Position, Marker msg)])
forall a. [a] -> Maybe (a, [a])
List.safeUncons [(Position, Marker msg)]
multiline)
           in Doc AnsiStyle -> Doc AnsiStyle
colorOfFirstMultilineMarker
                ( if
                      | Bool
hasPredecessor Bool -> Bool -> Bool
&& Bool
withUnicode -> Doc AnsiStyle
"├"
                      | Bool
hasPredecessor -> Doc AnsiStyle
"|"
                      | Bool
withUnicode -> Doc AnsiStyle
"╭"
                      | Bool
otherwise -> Doc AnsiStyle
"+"
                )
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker msg -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker msg
marker) (if Bool
withUnicode then Doc AnsiStyle
"┤" else Doc AnsiStyle
">")
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
space

      allMarkersInLine :: [(Position, Marker msg)]
allMarkersInLine = {- List.sortOn fst $ -} [(Position, Marker msg)]
allInlineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersInLine

      (HashMap Int Int
widths, Doc AnsiStyle
renderedCode) = HashMap String [String]
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (HashMap Int Int, Doc AnsiStyle)
forall msg.
HashMap String [String]
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (HashMap Int Int, Doc AnsiStyle)
getLine_ HashMap String [String]
files ([(Position, Marker msg)]
allMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersSpanningLine) Int
line Int
tabSize Bool
isError
   in Doc AnsiStyle
forall ann. Doc ann
hardline
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (1) -} Int -> Int -> Bool -> Doc AnsiStyle
linePrefix Int
leftLen Int
line Bool
withUnicode Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
additionalPrefix
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
renderedCode
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (2) -} Bool
-> Bool
-> (Doc AnsiStyle -> Doc AnsiStyle)
-> Bool
-> Bool
-> Int
-> HashMap Int Int
-> [(Position, Marker msg)]
-> Doc AnsiStyle
forall msg.
Pretty msg =>
Bool
-> Bool
-> (Doc AnsiStyle -> Doc AnsiStyle)
-> Bool
-> Bool
-> Int
-> HashMap Int Int
-> [(Position, Marker msg)]
-> Doc AnsiStyle
showAllMarkersInLine (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
multiline) Bool
inSpanOfMultiline Doc AnsiStyle -> Doc AnsiStyle
colorOfFirstMultilineMarker Bool
withUnicode Bool
isError Int
leftLen HashMap Int Int
widths [(Position, Marker msg)]
allInlineMarkersInLine
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> {- (3) -} HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc AnsiStyle
forall msg.
Pretty msg =>
HashMap String [String]
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc AnsiStyle
prettyAllLines HashMap String [String]
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
multiline [Int]
ls

-- |
getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Int -> Bool -> (IntMap.HashMap Int Int, Doc AnsiStyle)
getLine_ :: HashMap String [String]
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (HashMap Int Int, Doc AnsiStyle)
getLine_ HashMap String [String]
files [(Position, Marker msg)]
markers Int
line Int
tabSize Bool
isError = case Int -> [String] -> Maybe String
forall a. Int -> [a] -> Maybe a
List.safeIndex (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([String] -> Maybe String) -> Maybe [String] -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HashMap String [String] -> String -> Maybe [String]
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
(HashMap.!?) HashMap String [String]
files (String -> Maybe [String])
-> ((Position, Marker msg) -> String)
-> (Position, Marker msg)
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> String
file (Position -> String)
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Maybe [String])
-> Maybe (Position, Marker msg) -> Maybe [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(Position, Marker msg)]
markers of
  Maybe String
Nothing -> (HashMap Int Int
forall a. Monoid a => a
mempty, 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
colorDull Color
Magenta) Doc AnsiStyle
"<no line>")
  Just String
code ->
    let (HashMap Int Int
tabs, [(Int, Char)]
code') = String -> (HashMap Int Int, [(Int, Char)])
indexedWithTabsReplaced String
code
     in ( HashMap Int Int
tabs,
          [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
            [(Int, Char)]
code' [(Int, Char)] -> ((Int, Char) -> Doc AnsiStyle) -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Int
n, Char
c) ->
              let colorizingMarkers :: [(Position, Marker msg)]
colorizingMarkers = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip
                    ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter
                    [(Position, Marker msg)]
markers
                    \(Position (Int
bl, Int
bc) (Int
el, Int
ec) String
_, Marker msg
_) ->
                      if Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
el
                        then Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec
                        else (Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc) Bool -> Bool -> Bool
|| (Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec)
               in (Doc AnsiStyle -> Doc AnsiStyle)
-> ((Position, Marker msg) -> Doc AnsiStyle -> Doc AnsiStyle)
-> Maybe (Position, Marker msg)
-> Doc AnsiStyle
-> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle -> Doc AnsiStyle
forall a. a -> a
id ((\Marker msg
m -> 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
<> Bool -> Marker msg -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker msg
m)) (Marker msg -> Doc AnsiStyle -> Doc AnsiStyle)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Doc AnsiStyle
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) ([(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(Position, Marker msg)]
colorizingMarkers) (Char -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Char
c)
        )
  where
    indexedWithTabsReplaced :: String -> (IntMap.HashMap Int Int, [(Int, Char)])
    indexedWithTabsReplaced :: String -> (HashMap Int Int, [(Int, Char)])
indexedWithTabsReplaced = Int -> String -> (HashMap Int Int, [(Int, Char)])
goIndexed Int
1

    goIndexed :: Int -> String -> (IntMap.HashMap Int Int, [(Int, Char)])
    goIndexed :: Int -> String -> (HashMap Int Int, [(Int, Char)])
goIndexed Int
_ [] = (HashMap Int Int
forall a. Monoid a => a
mempty, [])
    goIndexed Int
n (Char
'\t' : String
xs) = (HashMap Int Int -> HashMap Int Int)
-> ([(Int, Char)] -> [(Int, Char)])
-> (HashMap Int Int, [(Int, Char)])
-> (HashMap Int Int, [(Int, Char)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int -> Int -> HashMap Int Int -> HashMap Int Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
IntMap.insert Int
n Int
tabSize) (Int -> (Int, Char) -> [(Int, Char)]
forall a. Int -> a -> [a]
replicate Int
tabSize (Int
n, Char
' ') [(Int, Char)] -> [(Int, Char)] -> [(Int, Char)]
forall a. Semigroup a => a -> a -> a
<>) (Int -> String -> (HashMap Int Int, [(Int, Char)])
goIndexed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
xs)
    goIndexed Int
n (Char
x : String
xs) = (HashMap Int Int -> HashMap Int Int)
-> ([(Int, Char)] -> [(Int, Char)])
-> (HashMap Int Int, [(Int, Char)])
-> (HashMap Int Int, [(Int, Char)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int -> Int -> HashMap Int Int -> HashMap Int Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
IntMap.insert Int
n (Char -> Int
wcwidth Char
x)) ((Int
n, Char
x) (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:) (Int -> String -> (HashMap Int Int, [(Int, Char)])
goIndexed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
xs)

-- |
showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc AnsiStyle -> Doc AnsiStyle) -> Bool -> Bool -> Int -> IntMap.HashMap Int Int -> [(Position, Marker msg)] -> Doc AnsiStyle
showAllMarkersInLine :: Bool
-> Bool
-> (Doc AnsiStyle -> Doc AnsiStyle)
-> Bool
-> Bool
-> Int
-> HashMap Int Int
-> [(Position, Marker msg)]
-> Doc AnsiStyle
showAllMarkersInLine Bool
_ Bool
_ Doc AnsiStyle -> Doc AnsiStyle
_ Bool
_ Bool
_ Int
_ HashMap Int Int
_ [] = Doc AnsiStyle
forall a. Monoid a => a
mempty
showAllMarkersInLine Bool
hasMultilines Bool
inSpanOfMultiline Doc AnsiStyle -> Doc AnsiStyle
colorMultilinePrefix Bool
withUnicode Bool
isError Int
leftLen HashMap Int Int
widths [(Position, Marker msg)]
ms =
  let maxMarkerColumn :: Int
maxMarkerColumn = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Position -> (Int, Int)
end (Position -> (Int, Int)) -> Position -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Position)
-> (Position, Marker msg) -> Position
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> (Position, Marker msg)
forall a. [a] -> a
List.last ([(Position, Marker msg)] -> (Position, Marker msg))
-> [(Position, Marker msg)] -> (Position, Marker msg)
forall a b. (a -> b) -> a -> b
$ ((Position, Marker msg) -> Int)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
end (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker msg)]
ms
      specialPrefix :: Doc AnsiStyle
specialPrefix
        | Bool
inSpanOfMultiline = Doc AnsiStyle -> Doc AnsiStyle
colorMultilinePrefix (if Bool
withUnicode then Doc AnsiStyle
"│ " else Doc AnsiStyle
"| ") Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
space
        | Bool
hasMultilines = Doc AnsiStyle -> Doc AnsiStyle
colorMultilinePrefix Doc AnsiStyle
"  " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
space
        | Bool
otherwise = Doc AnsiStyle
forall a. Monoid a => a
mempty
   in -- get the maximum end column, so that we know when to stop looking for other markers on the same line
      Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc AnsiStyle
dotPrefix Int
leftLen Bool
withUnicode Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (if [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [(Position, Marker msg)]
ms then Doc AnsiStyle
forall a. Monoid a => a
mempty else Doc AnsiStyle
specialPrefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc AnsiStyle
showMarkers Int
1 Int
maxMarkerColumn Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> [(Position, Marker msg)] -> Int -> Doc AnsiStyle
forall a t.
Pretty a =>
Doc AnsiStyle -> [(Position, Marker a)] -> t -> Doc AnsiStyle
showMessages Doc AnsiStyle
specialPrefix [(Position, Marker msg)]
ms Int
maxMarkerColumn)
  where
    showMarkers :: Int -> Int -> Doc AnsiStyle
showMarkers Int
n Int
lineLen
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineLen = Doc AnsiStyle
forall a. Monoid a => a
mempty -- reached the end of the line
      | Bool
otherwise =
        let allMarkers :: [(Position, Marker msg)]
allMarkers = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
ms \(Position (Int
_, Int
bc) (Int
_, Int
ec) String
_, Marker msg
_) -> Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec
         in -- only consider markers which span onto the current column
            case [(Position, Marker msg)]
allMarkers of
              [] -> [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc AnsiStyle -> [Doc AnsiStyle]
forall a. Int -> a -> [a]
replicate (Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
n HashMap Int Int
widths) Doc AnsiStyle
forall ann. Doc ann
space) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc AnsiStyle
showMarkers (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen
              (Position {String
(Int, Int)
file :: String
end :: (Int, Int)
begin :: (Int, Int)
file :: Position -> String
end :: Position -> (Int, Int)
begin :: Position -> (Int, Int)
..}, Marker msg
marker) : [(Position, Marker msg)]
_ ->
                AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate
                  (Bool -> Marker msg -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker msg
marker)
                  ( if (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
begin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
                      then (if Bool
withUnicode then Doc AnsiStyle
"┬" else Doc AnsiStyle
"^") Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc AnsiStyle -> [Doc AnsiStyle]
forall a. Int -> a -> [a]
replicate (Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
n HashMap Int Int
widths Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) if Bool
withUnicode then Doc AnsiStyle
"─" else Doc AnsiStyle
"-")
                      else [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc AnsiStyle -> [Doc AnsiStyle]
forall a. Int -> a -> [a]
replicate (Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
n HashMap Int Int
widths) if Bool
withUnicode then Doc AnsiStyle
"─" else Doc AnsiStyle
"-")
                  )
                  Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc AnsiStyle
showMarkers (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen

    showMessages :: Doc AnsiStyle -> [(Position, Marker a)] -> t -> Doc AnsiStyle
showMessages Doc AnsiStyle
specialPrefix [(Position, Marker a)]
ms t
lineLen = case [(Position, Marker a)]
-> Maybe ((Position, Marker a), [(Position, Marker a)])
forall a. [a] -> Maybe (a, [a])
List.safeUncons [(Position, Marker a)]
ms of
      Maybe ((Position, Marker a), [(Position, Marker a)])
Nothing -> Doc AnsiStyle
forall a. Monoid a => a
mempty -- no more messages to show
      Just ((Position b :: (Int, Int)
b@(Int
_, Int
bc) (Int, Int)
_ String
_, Marker a
msg), [(Position, Marker a)]
pipes) ->
        let filteredPipes :: [(Position, Marker a)]
filteredPipes = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, Int)
b) ((Int, Int) -> Bool)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
pipes
            -- record only the pipes corresponding to markers on different starting positions
            nubbedPipes :: [(Position, Marker a)]
nubbedPipes = ((Position, Marker a) -> (Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> a -> Bool) -> [a] -> [a]
List.nubBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> (Position, Marker a)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst)) [(Position, Marker a)]
filteredPipes
            -- and then remove all duplicates

            allColumns :: Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns Int
_ [] = (b
1, [])
            allColumns Int
n ms :: [(Position, Doc ann)]
ms@((Position (Int
_, Int
bc) (Int, Int)
_ String
_, Doc ann
col) : [(Position, Doc ann)]
ms')
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bc = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Doc ann
col Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms')
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bc = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Int -> Doc ann -> [Doc ann]
forall a. Int -> a -> [a]
replicate (Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
n HashMap Int Int
widths) Doc ann
forall ann. Doc ann
space [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms)
              | Bool
otherwise = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Int -> Doc ann -> [Doc ann]
forall a. Int -> a -> [a]
replicate (Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
n HashMap Int Int
widths) Doc ann
forall ann. Doc ann
space [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms')
            -- transform the list of remaining markers into a single document line

            hasSuccessor :: Bool
hasSuccessor = [(Position, Marker a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker a)]
filteredPipes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Position, Marker a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker a)]
pipes

            lineStart :: [(Position, Doc AnsiStyle)] -> Doc AnsiStyle
lineStart [(Position, Doc AnsiStyle)]
pipes =
              let (Int
n, [Doc AnsiStyle]
docs) = Int -> [(Position, Doc AnsiStyle)] -> (Int, [Doc AnsiStyle])
forall b ann.
Num b =>
Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns Int
1 ([(Position, Doc AnsiStyle)] -> (Int, [Doc AnsiStyle]))
-> [(Position, Doc AnsiStyle)] -> (Int, [Doc AnsiStyle])
forall a b. (a -> b) -> a -> b
$ ((Position, Doc AnsiStyle) -> Int)
-> [(Position, Doc AnsiStyle)] -> [(Position, Doc AnsiStyle)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Doc AnsiStyle) -> (Int, Int))
-> (Position, Doc AnsiStyle)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Doc AnsiStyle) -> Position)
-> (Position, Doc AnsiStyle)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Doc AnsiStyle) -> Position
forall a b. (a, b) -> a
fst) [(Position, Doc AnsiStyle)]
pipes
                  numberOfSpaces :: Int
numberOfSpaces = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
x HashMap Int Int
widths | Int
x <- [Int
n .. Int
bc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] -- bc - n
               in Int -> Bool -> Doc AnsiStyle
dotPrefix Int
leftLen Bool
withUnicode Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
specialPrefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Doc AnsiStyle]
docs 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
numberOfSpaces Char
' ')
            -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages

            prefix :: Doc AnsiStyle
prefix =
              let ([(Position, Marker a)]
pipesBefore, [(Position, Marker a)]
pipesAfter) = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)]
-> ([(Position, Marker a)], [(Position, Marker a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bc) (Int -> Bool)
-> ((Position, Marker a) -> Int) -> (Position, Marker a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
nubbedPipes
                  -- split the list so that all pipes before can have `|`s but pipes after won't

                  pipesBeforeRendered :: [(Position, Doc AnsiStyle)]
pipesBeforeRendered = [(Position, Marker a)]
pipesBefore [(Position, Marker a)]
-> ((Position, Marker a) -> (Position, Doc AnsiStyle))
-> [(Position, Doc AnsiStyle)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Marker a -> Doc AnsiStyle)
-> (Position, Marker a) -> (Position, Doc AnsiStyle)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker a
marker -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker a
marker) (if Bool
withUnicode then Doc AnsiStyle
"│" else Doc AnsiStyle
"|")
                  -- pre-render pipes which are before because they will be shown

                  lastBeginPosition :: Maybe Int
lastBeginPosition = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker a) -> Int)
-> Maybe (Position, Marker a) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Position, Marker a)] -> Maybe (Position, Marker a)
forall a. [a] -> Maybe a
List.safeHead (((Position, Marker a) -> Int)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
pipesAfter)

                  lineLen :: Int
lineLen = case Maybe Int
lastBeginPosition of
                    Maybe Int
Nothing -> Int
0
                    Just Int
col -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> HashMap Int Int -> Int
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
IntMap.lookupDefault Int
0 Int
x HashMap Int Int
widths | Int
x <- [Int
bc .. Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

                  currentPipe :: Doc AnsiStyle
currentPipe =
                    if
                        | Bool
withUnicode Bool -> Bool -> Bool
&& Bool
hasSuccessor -> Doc AnsiStyle
"├"
                        | Bool
withUnicode -> Doc AnsiStyle
"╰"
                        | Bool
hasSuccessor -> Doc AnsiStyle
"|"
                        | Bool
otherwise -> Doc AnsiStyle
"`"

                  lineChar :: Char
lineChar = if Bool
withUnicode then Char
'─' else Char
'-'
                  pointChar :: Doc AnsiStyle
pointChar = if Bool
withUnicode then Doc AnsiStyle
"╸" else Doc AnsiStyle
"-"
               in [(Position, Doc AnsiStyle)] -> Doc AnsiStyle
lineStart [(Position, Doc AnsiStyle)]
pipesBeforeRendered
                    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker a
msg) (Doc AnsiStyle
currentPipe 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
lineLen Char
lineChar) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
pointChar)
                    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 (Bool -> Marker a -> AnsiStyle
forall msg. Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError Marker a
msg) (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [(Position, Doc AnsiStyle)] -> Doc AnsiStyle
lineStart [(Position, Doc AnsiStyle)]
pipesBeforeRendered Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"  ") (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ a -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc AnsiStyle) -> a -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Marker a -> a
forall msg. Marker msg -> msg
markerMessage Marker a
msg)
         in Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> [(Position, Marker a)] -> t -> Doc AnsiStyle
showMessages Doc AnsiStyle
specialPrefix [(Position, Marker a)]
pipes t
lineLen

-- WARN: uses the internal of the library
--
--       DO NOT use a wildcard here, in case the internal API exposes one more constructor

-- |
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
Line = Doc ann
repl
replaceLinesWith Doc ann
_ Doc ann
Fail = Doc ann
forall ann. Doc ann
Fail
replaceLinesWith Doc ann
_ Doc ann
Empty = Doc ann
forall ann. Doc ann
Empty
replaceLinesWith Doc ann
_ (Char Char
c) = Char -> Doc ann
forall ann. Char -> Doc ann
Char Char
c
replaceLinesWith Doc ann
_ (Text Int
n Text
s) = Int -> Text -> Doc ann
forall ann. Int -> Text -> Doc ann
Text Int
n Text
s
replaceLinesWith Doc ann
repl (FlatAlt Doc ann
f Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
FlatAlt (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
f) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Cat Doc ann
c Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
Cat (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
c) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Nest Int
n Doc ann
d) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
Nest Int
n (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Union Doc ann
c Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
Union (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
c) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Column Int -> Doc ann
f) = (Int -> Doc ann) -> Doc ann
forall ann. (Int -> Doc ann) -> Doc ann
Column (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f)
replaceLinesWith Doc ann
repl (Nesting Int -> Doc ann
f) = (Int -> Doc ann) -> Doc ann
forall ann. (Int -> Doc ann) -> Doc ann
Nesting (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f)
replaceLinesWith Doc ann
repl (Annotated ann
ann Doc ann
doc) = ann -> Doc ann -> Doc ann
forall ann. ann -> Doc ann -> Doc ann
Annotated ann
ann (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
doc)
replaceLinesWith Doc ann
repl (WithPageWidth PageWidth -> Doc ann
f) = (PageWidth -> Doc ann) -> Doc ann
forall ann. (PageWidth -> Doc ann) -> Doc ann
WithPageWidth (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann)
-> (PageWidth -> Doc ann) -> PageWidth -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageWidth -> Doc ann
f)

-- | Extracts the color of a marker as a 'Doc' coloring function.
markerColor ::
  -- | Whether the marker is in an error context or not.
  --   This really makes a difference for a 'This' marker.
  Bool ->
  -- | The marker to extract the color from.
  Marker msg ->
  -- | A function used to color a 'Doc'.
  AnsiStyle
markerColor :: Bool -> Marker msg -> AnsiStyle
markerColor Bool
isError (This msg
_) = if Bool
isError then Color -> AnsiStyle
color Color
Red else Color -> AnsiStyle
color Color
Yellow
markerColor Bool
_ (Where msg
_) = Color -> AnsiStyle
colorDull Color
Blue
markerColor Bool
_ (Maybe msg
_) = Color -> AnsiStyle
color Color
Magenta
{-# INLINE markerColor #-}

-- | Retrieves the message held by a marker.
markerMessage :: Marker msg -> msg
markerMessage :: Marker msg -> msg
markerMessage (This msg
m) = msg
m
markerMessage (Where msg
m) = msg
m
markerMessage (Maybe msg
m) = msg
m
{-# INLINE markerMessage #-}

-- | Pretty prints all hints.
prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle
prettyAllHints :: [msg] -> Int -> Bool -> Doc AnsiStyle
prettyAllHints [] Int
_ Bool
_ = Doc AnsiStyle
forall a. Monoid a => a
mempty
prettyAllHints (msg
h : [msg]
hs) Int
leftLen Bool
withUnicode =
  {-
        A hint is composed of:
        (1)         : Hint: <hint message>
  -}
  let prefix :: Doc AnsiStyle
prefix = Doc AnsiStyle
forall ann. Doc ann
hardline Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc AnsiStyle
pipePrefix Int
leftLen Bool
withUnicode
   in Doc AnsiStyle
prefix 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
color Color
Cyan) (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold Doc AnsiStyle
"Hint:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"      ") (msg -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty msg
h))
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [msg] -> Int -> Bool -> Doc AnsiStyle
forall msg. Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle
prettyAllHints [msg]
hs Int
leftLen Bool
withUnicode