{-# 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-2022
-- 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 qualified Data.Array.IArray as Array
import Data.Array.Unboxed (Array, IArray, Ix, UArray, listArray, (!))
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.List as List
import qualified Data.List.Safe as List
import Data.Maybe
import Data.Ord (Down (Down))
import Data.String (IsString (fromString))
import qualified Data.Text as Text
import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..))
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>))
import Prettyprinter.Internal (Doc (..))

type FileMap = HashMap FilePath (Array Int String)

type WidthTable = UArray Int Int

-- | 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.
      [Note msg]
      -- ^ A list of notes 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 [Note msg]
hints1 <> :: Report msg -> Report msg -> Report msg
<> Report Bool
isError2 Maybe msg
code2 msg
msg2 [(Position, Marker msg)]
pos2 [Note msg]
hints2 =
    Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note 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) ([Note msg]
hints1 [Note msg] -> [Note msg] -> [Note msg]
forall a. Semigroup a => a -> a -> a
<> [Note msg]
hints2)

instance Monoid msg => Monoid (Report msg) where
  mempty :: Report msg
mempty = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note 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 [Note msg]
forall a. Monoid a => a
mempty

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Report msg) where
  toJSON (Report isError code msg markers hints) =
    object [ "kind" .= (if isError then "error" else "warning" :: String)
           , "code" .= code
           , "message" .= msg
           , "markers" .= fmap showMarker markers
           , "hints" .= hints
           ]
    where
      showMarker (pos, marker) =
        object $ [ "position" .= pos ]
              <> case marker of
                   This m  -> [ "message" .= m
                              , "kind" .= ("this" :: String)
                              ]
                   Where m -> [ "message" .= m
                              , "kind" .= ("where" :: String)
                              ]
                   Maybe m -> [ "message" .= m
                              , "kind" .= ("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
  | -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.
    Blank

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
Blank == Marker msg
Blank = 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
  Marker msg
_ < Marker msg
Blank = Bool
True
  Marker msg
Blank < Marker msg
_ = Bool
False
  {-# 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 (<=) #-}

-- | A note is a piece of information that is found at the end of a report.
data Note msg
  = -- | A note, which is meant to give valuable information related to the encountered error.
    Note msg
  | -- | A hint, to propose potential fixes or help towards fixing the issue.
    Hint msg

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Note msg) where
  toJSON (Note msg) = object [ "note" .= msg ]
  toJSON (Hint msg) = object [ "hint" .= msg ]
#endif

-- | Constructs a 'Note' from the given message as a literal string.
instance IsString msg => IsString (Note msg) where
  fromString :: String -> Note msg
fromString = msg -> Note msg
forall msg. msg -> Note msg
Note (msg -> Note msg) -> (String -> msg) -> String -> Note msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> msg
forall a. IsString a => String -> a
fromString

-- | 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.
    [Note msg] ->
    Report msg
warn :: Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
warn = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False
{-# INLINE warn #-}
err :: Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
err = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
True
{-# INLINE err #-}

-- | Transforms a warning report into an error report.
warningToError :: Report msg -> Report msg
warningToError :: Report msg -> Report msg
warningToError (Report Bool
False Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes) = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
True Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes
warningToError r :: Report msg
r@(Report Bool
True Maybe msg
_ msg
_ [(Position, Marker msg)]
_ [Note msg]
_) = Report msg
r

-- | Transforms an error report into a warning report.
errorToWarning :: Report msg -> Report msg
errorToWarning :: Report msg -> Report msg
errorToWarning (Report Bool
True Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes) = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes
errorToWarning r :: Report msg
r@(Report Bool
False Maybe msg
_ msg
_ [(Position, Marker msg)]
_ [Note msg]
_) = Report msg
r

-- | Pretty prints a report to a 'Doc' handling colors.
prettyReport ::
  Pretty msg =>
  -- | The content of the file the reports are for
  FileMap ->
  -- | 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 Annotation
prettyReport :: FileMap -> Bool -> Int -> Report msg -> Doc Annotation
prettyReport FileMap
fileContent Bool
withUnicode Int
tabSize (Report Bool
isError Maybe msg
code msg
message [(Position, Marker msg)]
markers [Note 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 Annotation
header =
        Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate
          (Bool -> Annotation
KindColor Bool
isError)
          ( Doc Annotation
forall ann. Doc ann
lbracket
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isError
                     then Doc Annotation
"error"
                     else Doc Annotation
"warning"
                 )
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> case Maybe msg
code of
                Maybe msg
Nothing -> Doc Annotation
forall ann. Doc ann
rbracket
                Just msg
code -> Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty msg
code Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
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 Annotation
header Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
colon Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann
align (msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty msg
message)
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> {- (2), (3), (4) -} [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((Bool -> [(Position, Marker msg)] -> Doc Annotation)
-> (Bool, [(Position, Marker msg)]) -> Doc Annotation
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
prettySubReport FileMap
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength) ((Bool, [(Position, Marker msg)]) -> Doc Annotation)
-> [(Bool, [(Position, Marker msg)])] -> [Doc Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, [(Position, Marker msg)])]
groupedMarkers)
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> {- (5) -} ( if
                           | [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints Bool -> Bool -> Bool
&& [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
markers -> Doc Annotation
forall a. Monoid a => a
mempty
                           | [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints -> Doc Annotation
forall a. Monoid a => a
mempty
                           | Bool
otherwise -> Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
maxLineNumberLength Bool
withUnicode
                     )
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Note msg] -> Int -> Bool -> Doc Annotation
forall msg.
Pretty msg =>
[Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [Note msg]
hints Int
maxLineNumberLength Bool
withUnicode
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
        Doc Annotation -> Doc Annotation -> Doc Annotation
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
&& [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints
                         then Doc Annotation
forall a. Monoid a => a
mempty
                         else
                           Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Int -> Char -> Doc Annotation -> Doc Annotation
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 Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> if Bool
withUnicode then Doc Annotation
"╯" else Doc Annotation
"+")
                             Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
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 Annotation
dotPrefix :: Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"•" else Doc Annotation
":")
{-# 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 Annotation
pipePrefix :: Int -> Bool -> Doc Annotation
pipePrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
{-# 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 Annotation
linePrefix :: Int -> Int -> Bool -> Doc Annotation
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 Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Doc Annotation -> Doc Annotation)
-> Doc Annotation -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Char -> Doc Annotation -> Doc Annotation
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 Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty Int
lineNo Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|"
{-# INLINE linePrefix #-}

-- | Creates an ellipsis-prefix, when some line numbers are not consecutive.
--
--   Pretty printing yields those results:
--
--   [with unicode] "@␣␣␣␣␣⋮␣@"
--   [without unicode] "@␣␣␣␣...@"
ellipsisPrefix ::
  Int ->
  Bool ->
  Doc Annotation
ellipsisPrefix :: Int -> Bool -> Doc Annotation
ellipsisPrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
"⋮" else Doc Annotation
"...")

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
  FileMap ->
  -- | 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 Annotation
prettySubReport :: FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
prettySubReport FileMap
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 Annotation
fileMarker =
        ( if Bool
isFirst
            then
              Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
maxLineNumberLength Char
' ' Doc Annotation
forall a. Monoid a => a
mempty
                Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"╭──▶" else Doc Annotation
"+-->")
            else
              Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Doc Annotation
dotPrefix Int
maxLineNumberLength Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
                Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Int -> Char -> Doc Annotation -> Doc Annotation
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 Annotation
forall a. Monoid a => a
mempty)
                Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"┼──▶" else Doc Annotation
"+-->")
        )
          Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
FileColor Doc Annotation
forall ann. Doc ann
reportFile
   in {- (2) -} Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
fileMarker
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
          Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> {- (3) -} Int -> Bool -> Doc Annotation
pipePrefix Int
maxLineNumberLength Bool
withUnicode
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> {- (4) -} FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
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 =>
  FileMap ->
  Bool ->
  Bool ->
  -- | The number of spaces each TAB character will span
  Int ->
  Int ->
  [(Int, [(Position, Marker msg)])] ->
  [(Position, Marker msg)] ->
  [Int] ->
  Doc Annotation
prettyAllLines :: FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
multiline [Int]
lineNumbers =
  case [Int]
lineNumbers of
    [] ->
      Bool -> [(Position, Marker msg)] -> Doc Annotation
forall msg a.
Pretty msg =>
Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline Bool
True [(Position, Marker msg)]
multiline
    [Int
l] ->
      let ([(Position, Marker msg)]
ms, Doc Annotation
doc) = Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
True Int
l
       in Doc Annotation
doc
            Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
ms []
    Int
l1 : Int
l2 : [Int]
ls ->
      let ([(Position, Marker msg)]
ms, Doc Annotation
doc) = Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
False Int
l1
       in Doc Annotation
doc
            Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> (if Int
l2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 then Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode else Doc Annotation
forall a. Monoid a => a
mempty)
            Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
ms (Int
l2 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ls)
  where
    showForLine :: Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
isLastLine Int
line =
      {-
          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 Annotation -> Doc Annotation
colorOfFirstMultilineMarker = (Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Doc Annotation -> Doc Annotation)
-> Maybe (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Annotation -> Doc Annotation
forall a. a -> a
id (Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Annotation -> Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Annotation)
-> (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError (Marker msg -> Annotation)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Annotation
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

          ([(Position, Marker msg)]
multilineEndingOnLine, [(Position, Marker msg)]
otherMultilines) = (((Position, Marker msg) -> Bool)
 -> [(Position, Marker msg)]
 -> ([(Position, Marker msg)], [(Position, Marker msg)]))
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> ([(Position, Marker msg)], [(Position, Marker msg)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
-> ([(Position, Marker msg)], [(Position, Marker msg)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition [(Position, Marker msg)]
multiline \(Position (Int, Int)
_ (Int
el, Int
_) String
_, Marker msg
_) -> Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line

          !additionalPrefix :: Doc Annotation
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 Annotation -> Doc Annotation
colorOfFirstMultilineMarker if Bool
withUnicode then Doc Annotation
"│  " else Doc Annotation
"|  "
                    else Doc Annotation
"   "
                else Doc Annotation
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 Annotation -> Doc Annotation
colorOfFirstMultilineMarker
                    ( if
                          | Bool
hasPredecessor Bool -> Bool -> Bool
&& Bool
withUnicode -> Doc Annotation
"├"
                          | Bool
hasPredecessor -> Doc Annotation
"|"
                          | Bool
withUnicode -> Doc Annotation
"╭"
                          | Bool
otherwise -> Doc Annotation
"+"
                    )
                    Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker msg
marker) (if Bool
withUnicode then Doc Annotation
"┤" else Doc Annotation
">")
                    Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space

          -- we need to remove all blank markers because they are irrelevant to the display
          allInlineMarkersInLine' :: [(Position, Marker msg)]
allInlineMarkersInLine' = ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Marker msg
forall msg. Marker msg
Blank (Marker msg -> Bool)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Bool
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)]
allInlineMarkersInLine
          allMultilineMarkersSpanningLine' :: [(Position, Marker msg)]
allMultilineMarkersSpanningLine' = ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Marker msg
forall msg. Marker msg
Blank (Marker msg -> Bool)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Bool
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)]
allMultilineMarkersSpanningLine

          (WidthTable
widths, Doc Annotation
renderedCode) = FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
forall msg.
FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
getLine_ FileMap
files ([(Position, Marker msg)]
allInlineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersInLine [(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 ( [(Position, Marker msg)]
otherMultilines,
            Doc Annotation
forall ann. Doc ann
hardline
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> {- (1) -} Int -> Int -> Bool -> Doc Annotation
linePrefix Int
leftLen Int
line Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
additionalPrefix
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
renderedCode
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> {- (2) -} Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
forall msg.
Pretty msg =>
Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
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 Annotation -> Doc Annotation
colorOfFirstMultilineMarker Bool
withUnicode Bool
isError Int
leftLen WidthTable
widths [(Position, Marker msg)]
allInlineMarkersInLine'
              Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Bool -> [(Position, Marker msg)] -> Doc Annotation
forall msg a.
Pretty msg =>
Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline (Bool
isLastLine Bool -> Bool -> Bool
|| [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
multilineEndingOnLine Maybe (Position, Marker msg)
-> Maybe (Position, Marker msg) -> Bool
forall a. Eq a => a -> a -> Bool
== [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
multiline) [(Position, Marker msg)]
multilineEndingOnLine
          )

    showMultiline :: Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline Bool
_ [] = Doc Annotation
forall a. Monoid a => a
mempty
    showMultiline Bool
isLastMultiline [(a, Marker msg)]
multiline =
      let colorOfFirstMultilineMarker :: Maybe Annotation
colorOfFirstMultilineMarker = Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError (Marker msg -> Annotation)
-> ((a, Marker msg) -> Marker msg) -> (a, Marker msg) -> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Annotation)
-> Maybe (a, Marker msg) -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)] -> Maybe (a, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(a, Marker msg)]
multiline
          -- take the color of the last multiline marker in case we need to add additional bars

          prefix :: Doc Annotation
prefix = Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space

          prefixWithBar :: Maybe Annotation -> Doc Annotation
prefixWithBar Maybe Annotation
color = Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> (Doc Annotation -> Doc Annotation)
-> (Annotation -> Doc Annotation -> Doc Annotation)
-> Maybe Annotation
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Annotation -> Doc Annotation
forall a. a -> a
id Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Maybe Annotation
color (if Bool
withUnicode then Doc Annotation
"│ " else Doc Annotation
"| ")

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

          showMultilineMarkerMessages :: [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [] = []
          showMultilineMarkerMessages [(a, Marker a)
m] = [(a, Marker a) -> Bool -> Doc Annotation
forall a a. Pretty a => (a, Marker a) -> Bool -> Doc Annotation
showMultilineMarkerMessage (a, Marker a)
m Bool
True]
          showMultilineMarkerMessages ((a, Marker a)
m : [(a, Marker a)]
ms) = (a, Marker a) -> Bool -> Doc Annotation
forall a a. Pretty a => (a, Marker a) -> Bool -> Doc Annotation
showMultilineMarkerMessage (a, Marker a)
m Bool
False Doc Annotation -> [Doc Annotation] -> [Doc Annotation]
forall a. a -> [a] -> [a]
: [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [(a, Marker a)]
ms
       in Maybe Annotation -> Doc Annotation
prefixWithBar Maybe Annotation
colorOfFirstMultilineMarker Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Doc Annotation -> [Doc Annotation] -> [Doc Annotation]
forall a. a -> [a] -> [a]
List.intersperse Doc Annotation
prefix ([Doc Annotation] -> [Doc Annotation])
-> [Doc Annotation] -> [Doc Annotation]
forall a b. (a -> b) -> a -> b
$ [(a, Marker msg)] -> [Doc Annotation]
forall a a. Pretty a => [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [(a, Marker msg)]
multiline)

-- |
getLine_ ::
  FileMap ->
  [(Position, Marker msg)] ->
  Int ->
  Int ->
  Bool ->
  (WidthTable, Doc Annotation)
getLine_ :: FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
getLine_ FileMap
files [(Position, Marker msg)]
markers Int
line Int
tabSize Bool
isError =
  case Int -> Array Int String -> Maybe String
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
i -> a i e -> Maybe e
safeArrayIndex (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Array Int String -> Maybe String)
-> Maybe (Array Int String) -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileMap -> String -> Maybe (Array Int String)
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
(HashMap.!?) FileMap
files (String -> Maybe (Array Int String))
-> ((Position, Marker msg) -> String)
-> (Position, Marker msg)
-> Maybe (Array Int 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 (Array Int String))
-> Maybe (Position, Marker msg) -> Maybe (Array Int 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 ->
      ( String -> WidthTable
mkWidthTable String
"",
        Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
NoLineColor Doc Annotation
"<no line>"
      )
    Just String
code ->
      ( String -> WidthTable
mkWidthTable String
code,
        (((Int, Char) -> Doc Annotation)
 -> [(Int, Char)] -> Doc Annotation)
-> [(Int, Char)]
-> ((Int, Char) -> Doc Annotation)
-> Doc Annotation
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, Char) -> Doc Annotation) -> [(Int, Char)] -> Doc Annotation
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Int] -> String -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] String
code) \(Int
n, Char
c) ->
          let cdoc :: Doc ann
cdoc = Doc ann -> (Char -> Doc ann) -> Char -> Doc ann
forall a. a -> (Char -> a) -> Char -> a
ifTab (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
tabSize Char
' ')) Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
c
              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 \case
                (Position (Int
bl, Int
bc) (Int
el, Int
ec) String
_, Marker msg
_)
                  | Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
el ->
                    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
                  | Bool
otherwise ->
                    (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)
                      Bool -> Bool -> Bool
|| (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)
           in (Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Doc Annotation -> Doc Annotation)
-> Maybe (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
CodeStyle)
                ((\Marker msg
m -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Annotation -> Annotation
MarkerStyle (Annotation -> Annotation) -> Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker msg
m)) (Marker msg -> Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
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)
                Doc Annotation
forall ann. Doc ann
cdoc
      )
  where
    ifTab :: a -> (Char -> a) -> Char -> a
    ifTab :: a -> (Char -> a) -> Char -> a
ifTab a
a Char -> a
_ Char
'\t' = a
a
    ifTab a
_ Char -> a
f Char
c = Char -> a
f Char
c

    mkWidthTable :: String -> WidthTable
    mkWidthTable :: String -> WidthTable
mkWidthTable String
s = (Int, Int) -> [Int] -> WidthTable
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (Int -> (Char -> Int) -> Char -> Int
forall a. a -> (Char -> a) -> Char -> a
ifTab Int
tabSize Char -> Int
wcwidth (Char -> Int) -> String -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s)

-- |
showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation
showAllMarkersInLine :: Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
showAllMarkersInLine Bool
_ Bool
_ Doc Annotation -> Doc Annotation
_ Bool
_ Bool
_ Int
_ WidthTable
_ [] = Doc Annotation
forall a. Monoid a => a
mempty
showAllMarkersInLine Bool
hasMultilines Bool
inSpanOfMultiline Doc Annotation -> Doc Annotation
colorMultilinePrefix Bool
withUnicode Bool
isError Int
leftLen WidthTable
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 Annotation
specialPrefix
        | Bool
inSpanOfMultiline = Doc Annotation -> Doc Annotation
colorMultilinePrefix (if Bool
withUnicode then Doc Annotation
"│ " else Doc Annotation
"| ") Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
        | Bool
hasMultilines = Doc Annotation -> Doc Annotation
colorMultilinePrefix Doc Annotation
"  " Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
        | Bool
otherwise = Doc Annotation
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 Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
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 Annotation
forall a. Monoid a => a
mempty else Doc Annotation
specialPrefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
showMarkers Int
1 Int
maxMarkerColumn Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation -> [(Position, Marker msg)] -> Int -> Doc Annotation
forall a t.
Pretty a =>
Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
specialPrefix [(Position, Marker msg)]
ms Int
maxMarkerColumn)
  where
    widthAt :: Int -> Int
widthAt Int
i = Int
0 Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
`fromMaybe` Int -> WidthTable -> Maybe Int
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
i -> a i e -> Maybe e
safeArrayIndex Int
i WidthTable
widths
    widthsBetween :: Int -> Int -> Int
widthsBetween Int
start Int
end =
      [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ WidthTable -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems WidthTable
widths

    showMarkers :: Int -> Int -> Doc Annotation
showMarkers Int
n Int
lineLen
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineLen = Doc Annotation
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
mark) -> Marker msg
mark Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
/= Marker msg
forall msg. Marker msg
Blank Bool -> Bool -> Bool
&& 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 Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) Doc Annotation
forall ann. Doc ann
space) Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
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)]
_ ->
                Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate
                  (Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
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 Annotation
"┬" else Doc Annotation
"^") Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) if Bool
withUnicode then Doc Annotation
"─" else Doc Annotation
"-")
                      else [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) if Bool
withUnicode then Doc Annotation
"─" else Doc Annotation
"-")
                  )
                  Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
showMarkers (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen

    showMessages :: Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
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 Annotation
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 ((Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(&&) ((Bool, Bool) -> Bool)
-> ((Position, Marker a) -> (Bool, Bool))
-> (Position, Marker a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Bool)
-> (Marker a -> Bool) -> (Position, Marker a) -> (Bool, Bool)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, Int)
b) ((Int, Int) -> Bool)
-> (Position -> (Int, Int)) -> Position -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin) (Marker a -> Marker a -> Bool
forall a. Eq a => a -> a -> Bool
/= Marker a
forall msg. Marker msg
Blank)) [(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
widthAt Int
n) 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
widthAt Int
n) 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 Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipes =
              let (Int
n, [Doc Annotation]
docs) = Int -> [(Position, Doc Annotation)] -> (Int, [Doc Annotation])
forall b ann.
Num b =>
Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns Int
1 ([(Position, Doc Annotation)] -> (Int, [Doc Annotation]))
-> [(Position, Doc Annotation)] -> (Int, [Doc Annotation])
forall a b. (a -> b) -> a -> b
$ ((Position, Doc Annotation) -> Int)
-> [(Position, Doc Annotation)] -> [(Position, Doc Annotation)]
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 Annotation) -> (Int, Int))
-> (Position, Doc Annotation)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Doc Annotation) -> Position)
-> (Position, Doc Annotation)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Doc Annotation) -> Position
forall a b. (a, b) -> a
fst) [(Position, Doc Annotation)]
pipes
                  numberOfSpaces :: Int
numberOfSpaces = Int -> Int -> Int
widthsBetween Int
n Int
bc
               in Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
specialPrefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Doc Annotation]
docs Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> String -> Doc Annotation
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 Annotation
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 Annotation)]
pipesBeforeRendered = [(Position, Marker a)]
pipesBefore [(Position, Marker a)]
-> ((Position, Marker a) -> (Position, Doc Annotation))
-> [(Position, Doc Annotation)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Marker a -> Doc Annotation)
-> (Position, Marker a) -> (Position, Doc Annotation)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker a
marker -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
                  -- 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.safeLast (((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 -> Int
widthsBetween Int
bc Int
col

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

                  lineChar :: Char
lineChar = if Bool
withUnicode then Char
'─' else Char
'-'
                  pointChar :: Doc Annotation
pointChar = if Bool
withUnicode then Doc Annotation
"╸" else Doc Annotation
"-"

                  bc' :: Int
bc' = Int
bc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                  pipesBeforeMessageStart :: [(Position, Marker a)]
pipesBeforeMessageStart = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> Bool) -> [a] -> [a]
List.filter ((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)]
pipesAfter
                  -- consider pipes before, as well as pipes which came before the text rectangle bounds
                  pipesBeforeMessageRendered :: [(Position, Doc Annotation)]
pipesBeforeMessageRendered = ([(Position, Marker a)]
pipesBefore [(Position, Marker a)]
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker a)]
pipesBeforeMessageStart) [(Position, Marker a)]
-> ((Position, Marker a) -> (Position, Doc Annotation))
-> [(Position, Doc Annotation)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Marker a -> Doc Annotation)
-> (Position, Marker a) -> (Position, Doc Annotation)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker a
marker -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
               in -- also pre-render pipes which are before the message text bounds, because they will be shown if the message is on
                  -- multiple lines

                  [(Position, Doc Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipesBeforeRendered
                    Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
msg) (Doc Annotation
currentPipe Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> String -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
lineLen Char
lineChar) Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
pointChar)
                    Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
msg) (Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [(Position, Doc Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipesBeforeMessageRendered Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if [(Position, Marker a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [(Position, Marker a)]
pipesBeforeMessageStart then Doc Annotation
"  " else Doc Annotation
" ") (Doc Annotation -> Doc Annotation)
-> Doc Annotation -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ a -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc Annotation) -> a -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Marker a -> a
forall msg. Marker msg -> msg
markerMessage Marker a
msg)
         in Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
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
repl (Text Int
_ Text
s) =
  let lines :: [Doc ann]
lines = (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s [Text] -> (Text -> Doc ann) -> [Doc ann]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
txt -> Int -> Text -> Doc ann
forall ann. Int -> Text -> Doc ann
Text (Text -> Int
Text.length Text
txt) Text
txt
   in [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse Doc ann
repl [Doc ann]
forall ann. [Doc ann]
lines)
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'.
  Annotation
markerColor :: Bool -> Marker msg -> Annotation
markerColor Bool
isError (This msg
_) = Bool -> Annotation
ThisColor Bool
isError
markerColor Bool
_ (Where msg
_) = Annotation
WhereColor
markerColor Bool
_ (Maybe msg
_) = Annotation
MaybeColor
markerColor Bool
_ Marker msg
Blank = Annotation
CodeStyle -- we take the same color as the code, for it to be invisible
{-# 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
markerMessage Marker msg
Blank = msg
forall a. HasCallStack => a
undefined
{-# INLINE markerMessage #-}

-- | Pretty prints all hints.
prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints :: [Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [] Int
_ Bool
_ = Doc Annotation
forall a. Monoid a => a
mempty
prettyAllHints (Note msg
h : [Note msg]
hs) Int
leftLen Bool
withUnicode =
  {-
        A hint is composed of:
        (1)         : Hint: <hint message>
  -}
  let prefix :: Doc Annotation
prefix = Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
pipePrefix Int
leftLen Bool
withUnicode
   in Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
HintColor (Note msg -> Doc Annotation
forall p msg. IsString p => Note msg -> p
notePrefix Note msg
h Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
"      ") (msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (msg -> Doc Annotation) -> msg -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Note msg -> msg
forall p. Note p -> p
noteMessage Note msg
h))
        Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Note msg] -> Int -> Bool -> Doc Annotation
forall msg.
Pretty msg =>
[Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [Note msg]
hs Int
leftLen Bool
withUnicode
  where
    notePrefix :: Note msg -> p
notePrefix (Note msg
_) = p
"Note:"
    notePrefix (Hint msg
_) = p
"Hint:"

    noteMessage :: Note p -> p
noteMessage (Note p
msg) = p
msg
    noteMessage (Hint p
msg) = p
msg

safeArrayIndex :: (Ix i, IArray a e) => i -> a i e -> Maybe e
safeArrayIndex :: i -> a i e -> Maybe e
safeArrayIndex i
i a i e
a
  | (i, i) -> i -> Bool
forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (a i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
Array.bounds a i e
a) i
i = e -> Maybe e
forall a. a -> Maybe a
Just (a i e
a a i e -> i -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! i
i)
  | Bool
otherwise = Maybe e
forall a. Maybe a
Nothing