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

-- |
-- 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
  ( module Error.Diagnose.Report.Internal
  , Report(.., Warn, Err)
  , WithUnicode(..)
  , TabSize(..)
  ) 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 ((<&>), void)
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.String (IsString (fromString))
import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..))
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)
import Prettyprinter.Internal (Doc (..), textSpaces)
import Data.Bool (bool)

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.
  deriving (forall a b. a -> Report b -> Report a
forall a b. (a -> b) -> Report a -> Report b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Report b -> Report a
$c<$ :: forall a b. a -> Report b -> Report a
fmap :: forall a b. (a -> b) -> Report a -> Report b
$cfmap :: forall a b. (a -> b) -> Report a -> Report b
Functor, forall a. Eq a => a -> Report a -> Bool
forall a. Num a => Report a -> a
forall a. Ord a => Report a -> a
forall m. Monoid m => Report m -> m
forall a. Report a -> Bool
forall a. Report a -> Int
forall a. Report a -> [a]
forall a. (a -> a -> a) -> Report a -> a
forall m a. Monoid m => (a -> m) -> Report a -> m
forall b a. (b -> a -> b) -> b -> Report a -> b
forall a b. (a -> b -> b) -> b -> Report a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Report a -> a
$cproduct :: forall a. Num a => Report a -> a
sum :: forall a. Num a => Report a -> a
$csum :: forall a. Num a => Report a -> a
minimum :: forall a. Ord a => Report a -> a
$cminimum :: forall a. Ord a => Report a -> a
maximum :: forall a. Ord a => Report a -> a
$cmaximum :: forall a. Ord a => Report a -> a
elem :: forall a. Eq a => a -> Report a -> Bool
$celem :: forall a. Eq a => a -> Report a -> Bool
length :: forall a. Report a -> Int
$clength :: forall a. Report a -> Int
null :: forall a. Report a -> Bool
$cnull :: forall a. Report a -> Bool
toList :: forall a. Report a -> [a]
$ctoList :: forall a. Report a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Report a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Report a -> a
foldr1 :: forall a. (a -> a -> a) -> Report a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Report a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Report a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Report a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Report a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Report a -> m
fold :: forall m. Monoid m => Report m -> m
$cfold :: forall m. Monoid m => Report m -> m
Foldable, Functor Report
Foldable Report
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
sequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
$csequence :: forall (m :: * -> *) a. Monad m => Report (m a) -> m (Report a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Report a -> m (Report b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Report (f a) -> f (Report a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Report a -> f (Report b)
Traversable)

-- | Pattern synonym for a warning report.
pattern Warn :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
pattern $bWarn :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
$mWarn :: forall {r} {msg}.
Report msg
-> (Maybe msg
    -> msg -> [(Position, Marker msg)] -> [Note msg] -> r)
-> ((# #) -> r)
-> r
Warn errCode msg reports notes = Report False errCode msg reports notes

-- | Pattern synonym for an error report.
pattern Err :: Maybe msg -> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
pattern $bErr :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
$mErr :: forall {r} {msg}.
Report msg
-> (Maybe msg
    -> msg -> [(Position, Marker msg)] -> [Note msg] -> r)
-> ((# #) -> r)
-> r
Err errCode msg reports notes = Report True errCode msg reports notes

{-# COMPLETE Warn, Err #-}

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

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

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Report msg) where
  toJSON :: Report msg -> Value
toJSON (Report Bool
isError Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
hints) =
    [Pair] -> Value
object [ Key
"kind" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (if Bool
isError then String
"error" else String
"warning" :: String)
           , Key
"code" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe msg
code
           , Key
"message" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msg
msg
           , Key
"markers" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {v} {v}. (ToJSON v, ToJSON v) => (v, Marker v) -> Value
showMarker [(Position, Marker msg)]
markers
           , Key
"hints" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Note msg]
hints
           ]
    where
      showMarker :: (v, Marker v) -> Value
showMarker (v
pos, Marker v
marker) =
        [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ [ Key
"position" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
pos ]
              forall a. Semigroup a => a -> a -> a
<> case Marker v
marker of
                   This v
m  -> [ Key
"message" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
m
                              , Key
"kind" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"this" :: String)
                              ]
                   Where v
m -> [ Key
"message" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
m
                              , Key
"kind" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"where" :: String)
                              ]
                   Maybe v
m -> [ Key
"message" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
m
                              , Key
"kind" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"maybe" :: String)
                              ]
                   Marker v
Blank -> [ Key
"kind" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"blank" :: 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
  deriving (Marker msg -> Marker msg -> Bool
forall msg. Eq msg => Marker msg -> Marker msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Marker msg -> Marker msg -> Bool
$c/= :: forall msg. Eq msg => Marker msg -> Marker msg -> Bool
== :: Marker msg -> Marker msg -> Bool
$c== :: forall msg. Eq msg => Marker msg -> Marker msg -> Bool
Eq, Marker msg -> Marker msg -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {msg}. Ord msg => Eq (Marker msg)
forall msg. Ord msg => Marker msg -> Marker msg -> Bool
forall msg. Ord msg => Marker msg -> Marker msg -> Ordering
forall msg. Ord msg => Marker msg -> Marker msg -> Marker msg
min :: Marker msg -> Marker msg -> Marker msg
$cmin :: forall msg. Ord msg => Marker msg -> Marker msg -> Marker msg
max :: Marker msg -> Marker msg -> Marker msg
$cmax :: forall msg. Ord msg => Marker msg -> Marker msg -> Marker msg
>= :: Marker msg -> Marker msg -> Bool
$c>= :: forall msg. Ord msg => Marker msg -> Marker msg -> Bool
> :: Marker msg -> Marker msg -> Bool
$c> :: forall msg. Ord msg => Marker msg -> Marker msg -> Bool
<= :: Marker msg -> Marker msg -> Bool
$c<= :: forall msg. Ord msg => Marker msg -> Marker msg -> Bool
< :: Marker msg -> Marker msg -> Bool
$c< :: forall msg. Ord msg => Marker msg -> Marker msg -> Bool
compare :: Marker msg -> Marker msg -> Ordering
$ccompare :: forall msg. Ord msg => Marker msg -> Marker msg -> Ordering
Ord, forall a b. a -> Marker b -> Marker a
forall a b. (a -> b) -> Marker a -> Marker b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Marker b -> Marker a
$c<$ :: forall a b. a -> Marker b -> Marker a
fmap :: forall a b. (a -> b) -> Marker a -> Marker b
$cfmap :: forall a b. (a -> b) -> Marker a -> Marker b
Functor, forall a. Eq a => a -> Marker a -> Bool
forall a. Num a => Marker a -> a
forall a. Ord a => Marker a -> a
forall m. Monoid m => Marker m -> m
forall a. Marker a -> Bool
forall a. Marker a -> Int
forall a. Marker a -> [a]
forall a. (a -> a -> a) -> Marker a -> a
forall m a. Monoid m => (a -> m) -> Marker a -> m
forall b a. (b -> a -> b) -> b -> Marker a -> b
forall a b. (a -> b -> b) -> b -> Marker a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Marker a -> a
$cproduct :: forall a. Num a => Marker a -> a
sum :: forall a. Num a => Marker a -> a
$csum :: forall a. Num a => Marker a -> a
minimum :: forall a. Ord a => Marker a -> a
$cminimum :: forall a. Ord a => Marker a -> a
maximum :: forall a. Ord a => Marker a -> a
$cmaximum :: forall a. Ord a => Marker a -> a
elem :: forall a. Eq a => a -> Marker a -> Bool
$celem :: forall a. Eq a => a -> Marker a -> Bool
length :: forall a. Marker a -> Int
$clength :: forall a. Marker a -> Int
null :: forall a. Marker a -> Bool
$cnull :: forall a. Marker a -> Bool
toList :: forall a. Marker a -> [a]
$ctoList :: forall a. Marker a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Marker a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Marker a -> a
foldr1 :: forall a. (a -> a -> a) -> Marker a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Marker a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Marker a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Marker a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Marker a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Marker a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Marker a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Marker a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Marker a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Marker a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Marker a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Marker a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Marker a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Marker a -> m
fold :: forall m. Monoid m => Marker m -> m
$cfold :: forall m. Monoid m => Marker m -> m
Foldable, Functor Marker
Foldable Marker
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Marker (m a) -> m (Marker a)
forall (f :: * -> *) a.
Applicative f =>
Marker (f a) -> f (Marker a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Marker a -> m (Marker b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Marker a -> f (Marker b)
sequence :: forall (m :: * -> *) a. Monad m => Marker (m a) -> m (Marker a)
$csequence :: forall (m :: * -> *) a. Monad m => Marker (m a) -> m (Marker a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Marker a -> m (Marker b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Marker a -> m (Marker b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Marker (f a) -> f (Marker a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Marker (f a) -> f (Marker a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Marker a -> f (Marker b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Marker a -> f (Marker b)
Traversable)

isBlank :: Marker msg -> Bool
isBlank :: forall a. Marker a -> Bool
isBlank = \case
  Marker msg
Blank -> Bool
True
  Marker msg
_ -> Bool
False

-- | 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
  deriving (Note msg -> Note msg -> Bool
forall msg. Eq msg => Note msg -> Note msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note msg -> Note msg -> Bool
$c/= :: forall msg. Eq msg => Note msg -> Note msg -> Bool
== :: Note msg -> Note msg -> Bool
$c== :: forall msg. Eq msg => Note msg -> Note msg -> Bool
Eq, Note msg -> Note msg -> Bool
Note msg -> Note msg -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {msg}. Ord msg => Eq (Note msg)
forall msg. Ord msg => Note msg -> Note msg -> Bool
forall msg. Ord msg => Note msg -> Note msg -> Ordering
forall msg. Ord msg => Note msg -> Note msg -> Note msg
min :: Note msg -> Note msg -> Note msg
$cmin :: forall msg. Ord msg => Note msg -> Note msg -> Note msg
max :: Note msg -> Note msg -> Note msg
$cmax :: forall msg. Ord msg => Note msg -> Note msg -> Note msg
>= :: Note msg -> Note msg -> Bool
$c>= :: forall msg. Ord msg => Note msg -> Note msg -> Bool
> :: Note msg -> Note msg -> Bool
$c> :: forall msg. Ord msg => Note msg -> Note msg -> Bool
<= :: Note msg -> Note msg -> Bool
$c<= :: forall msg. Ord msg => Note msg -> Note msg -> Bool
< :: Note msg -> Note msg -> Bool
$c< :: forall msg. Ord msg => Note msg -> Note msg -> Bool
compare :: Note msg -> Note msg -> Ordering
$ccompare :: forall msg. Ord msg => Note msg -> Note msg -> Ordering
Ord, Int -> Note msg -> ShowS
forall msg. Show msg => Int -> Note msg -> ShowS
forall msg. Show msg => [Note msg] -> ShowS
forall msg. Show msg => Note msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note msg] -> ShowS
$cshowList :: forall msg. Show msg => [Note msg] -> ShowS
show :: Note msg -> String
$cshow :: forall msg. Show msg => Note msg -> String
showsPrec :: Int -> Note msg -> ShowS
$cshowsPrec :: forall msg. Show msg => Int -> Note msg -> ShowS
Show, forall a b. a -> Note b -> Note a
forall a b. (a -> b) -> Note a -> Note b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Note b -> Note a
$c<$ :: forall a b. a -> Note b -> Note a
fmap :: forall a b. (a -> b) -> Note a -> Note b
$cfmap :: forall a b. (a -> b) -> Note a -> Note b
Functor, forall a. Eq a => a -> Note a -> Bool
forall a. Num a => Note a -> a
forall a. Ord a => Note a -> a
forall m. Monoid m => Note m -> m
forall a. Note a -> Bool
forall a. Note a -> Int
forall a. Note a -> [a]
forall a. (a -> a -> a) -> Note a -> a
forall m a. Monoid m => (a -> m) -> Note a -> m
forall b a. (b -> a -> b) -> b -> Note a -> b
forall a b. (a -> b -> b) -> b -> Note a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Note a -> a
$cproduct :: forall a. Num a => Note a -> a
sum :: forall a. Num a => Note a -> a
$csum :: forall a. Num a => Note a -> a
minimum :: forall a. Ord a => Note a -> a
$cminimum :: forall a. Ord a => Note a -> a
maximum :: forall a. Ord a => Note a -> a
$cmaximum :: forall a. Ord a => Note a -> a
elem :: forall a. Eq a => a -> Note a -> Bool
$celem :: forall a. Eq a => a -> Note a -> Bool
length :: forall a. Note a -> Int
$clength :: forall a. Note a -> Int
null :: forall a. Note a -> Bool
$cnull :: forall a. Note a -> Bool
toList :: forall a. Note a -> [a]
$ctoList :: forall a. Note a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Note a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Note a -> a
foldr1 :: forall a. (a -> a -> a) -> Note a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Note a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Note a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Note a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Note a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Note a -> m
fold :: forall m. Monoid m => Note m -> m
$cfold :: forall m. Monoid m => Note m -> m
Foldable, Functor Note
Foldable Note
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
sequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
$csequence :: forall (m :: * -> *) a. Monad m => Note (m a) -> m (Note a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Note a -> m (Note b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Note (f a) -> f (Note a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Note a -> f (Note b)
Traversable)

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Note msg) where
  toJSON :: Note msg -> Value
toJSON (Note msg
msg) = [Pair] -> Value
object [ Key
"note" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msg
msg ]
  toJSON (Hint msg
msg) = [Pair] -> Value
object [ Key
"hint" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msg
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 = forall msg. msg -> Note msg
Note forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
warn = forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False
{-# INLINE warn #-}
{-# DEPRECATED warn "'warn' is deprecated. Use 'Warn' instead." #-}
err :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
err = forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
True
{-# INLINE err #-}
{-# DEPRECATED err "'err' is deprecated. Use 'Err' instead." #-}

-- | Transforms a warning report into an error report.
warningToError :: Report msg -> Report msg
warningToError :: forall msg. Report msg -> Report msg
warningToError (Report Bool
False Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes) = 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 :: forall msg. Report msg -> Report msg
errorToWarning (Report Bool
True Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes) = 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

data WithUnicode = WithoutUnicode | WithUnicode

newtype TabSize = TabSize Int

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

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

      maxLineNumberLength :: Int
maxLineNumberLength = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3 (forall a. Ord a => a -> a -> a
max Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
List.safeLast [(Position, Marker (Doc ann))]
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 ann)
header =
        forall ann. ann -> Doc ann -> Doc ann
annotate
          (forall a. Bool -> Annotation a
KindColor Bool
isError)
          ( forall ann. Doc ann
lbracket
              forall a. Semigroup a => a -> a -> a
<> ( if Bool
isError
                     then Doc (Annotation ann)
"error"
                     else Doc (Annotation ann)
"warning"
                 )
              forall a. Semigroup a => a -> a -> a
<> case Maybe (Doc ann)
code of
                Maybe (Doc ann)
Nothing -> forall ann. Doc ann
rbracket
                Just Doc ann
code -> forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc (Annotation ann)
annotated Doc ann
code forall a. Semigroup a => a -> a -> a
<> 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 ann)
header forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann. Doc ann -> Doc (Annotation ann)
annotated Doc ann
message)
        forall a. Semigroup a => a -> a -> a
<> {- (2), (3), (4) -} forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> Bool
-> [(Position, Marker (Doc ann))]
-> Doc (Annotation ann)
prettySubReport FileMap
fileContent WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
maxLineNumberLength) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, [(Position, Marker (Doc ann))])]
groupedMarkers)
        forall a. Semigroup a => a -> a -> a
<> {- (5) -} ( if
                           | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note (Doc ann)]
hints Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker (Doc ann))]
markers -> forall a. Monoid a => a
mempty
                           | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note (Doc ann)]
hints -> forall a. Monoid a => a
mempty
                           | Bool
otherwise -> forall ann. Doc ann
hardline forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
maxLineNumberLength WithUnicode
withUnicode
                     )
        forall a. Semigroup a => a -> a -> a
<> forall ann.
[Note (Doc ann)] -> Int -> WithUnicode -> Doc (Annotation ann)
prettyAllHints [Note (Doc ann)]
hints Int
maxLineNumberLength WithUnicode
withUnicode
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
        forall a. Semigroup a => a -> a -> a
<> {- (6) -} ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker (Doc ann))]
markers Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note (Doc ann)]
hints
                         then forall a. Monoid a => a
mempty
                         else
                           forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength forall a. Num a => a -> a -> a
+ Int
2) (forall a. a -> a -> WithUnicode -> a
unicode Char
'-' Char
'─' WithUnicode
withUnicode) forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<> forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"+" Doc (Annotation ann)
"╯" WithUnicode
withUnicode)
                             forall a. Semigroup a => a -> a -> a
<> 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 :: forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
n Char
c Doc ann
d = forall ann. Doc ann -> (Int -> Doc ann) -> Doc ann
width Doc ann
d \Int
w -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Int
n 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.
  WithUnicode ->
  Doc (Annotation ann)
dotPrefix :: forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
leftLen WithUnicode
withUnicode =
  forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' forall a. Monoid a => a
mempty
    forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
":" Doc (Annotation ann)
"•" WithUnicode
withUnicode)
{-# 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.
  WithUnicode ->
  Doc (Annotation ann)
pipePrefix :: forall ann. Int -> WithUnicode -> Doc (Annotation ann)
pipePrefix Int
leftLen WithUnicode
withUnicode = forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' forall a. Monoid a => a
mempty forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"|" Doc (Annotation ann)
"│" WithUnicode
withUnicode)
{-# 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.
  WithUnicode ->
  Doc (Annotation ann)
linePrefix :: forall ann. Int -> Int -> WithUnicode -> Doc (Annotation ann)
linePrefix Int
leftLen Int
lineNo WithUnicode
withUnicode =
  let lineNoLen :: Int
lineNoLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show Int
lineNo)
   in forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
leftLen forall a. Num a => a -> a -> a
- Int
lineNoLen) Char
' ' forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Int
lineNo forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"|" Doc (Annotation ann)
"│" WithUnicode
withUnicode
{-# INLINE linePrefix #-}

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

groupMarkersPerFile ::
  [(Position, Marker msg)] ->
  [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile :: forall msg.
[(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [] = []
groupMarkersPerFile [(Position, Marker msg)]
markers =
  let markersPerFile :: HashMap String [(Position, Marker msg)]
markersPerFile = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith forall a. Semigroup a => a -> a -> a
(<>)) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)]
markers forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \tup :: (Position, Marker msg)
tup@(Position
p, 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

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

    go :: Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
_ [(Bool, b)]
acc [] = 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) forall a. a -> [a] -> [a]
: [(Bool, b)]
acc) [b]
xs

    putThisMarkersAtTop :: [[(a, Marker msg)]] -> [[(a, Marker msg)]]
putThisMarkersAtTop = forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy \[(a, Marker msg)]
ms1 [(a, Marker msg)]
ms2 ->
      if
          | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Marker a -> Bool
isThisMarker (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)]
ms1) -> Ordering
LT
          | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Marker a -> Bool
isThisMarker (forall a b. (a, b) -> b
snd 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 ::
  -- | The content of files in the diagnostics
  FileMap ->
  -- | Is the output done with Unicode characters?
  WithUnicode ->
  -- | Is the current report an error report?
  Bool ->
  -- | The number of spaces each TAB character will span
  TabSize ->
  -- | 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 (Doc ann))] ->
  Doc (Annotation ann)
prettySubReport :: forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> Bool
-> [(Position, Marker (Doc ann))]
-> Doc (Annotation ann)
prettySubReport FileMap
fileContent WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
maxLineNumberLength Bool
isFirst [(Position, Marker (Doc ann))]
markers =
  let (HashMap Int [(Position, Marker (Doc ann))]
markersPerLine, [(Position, Marker (Doc ann))]
multilineMarkers) = forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker (Doc ann))]
markers
      -- split the list on whether markers are multiline or not

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

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

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

      fileMarker :: Doc (Annotation a)
fileMarker =
        ( if Bool
isFirst
            then
              forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
maxLineNumberLength Char
' ' forall a. Monoid a => a
mempty
                forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation a)
"+-->" Doc (Annotation a)
"╭──▶" WithUnicode
withUnicode)
            else
              forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
maxLineNumberLength WithUnicode
withUnicode forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength forall a. Num a => a -> a -> a
+ Int
2) (forall a. a -> a -> WithUnicode -> a
unicode Char
'-' Char
'─' WithUnicode
withUnicode) forall a. Monoid a => a
mempty)
                forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
RuleColor (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation a)
"+-->" Doc (Annotation a)
"┼──▶" WithUnicode
withUnicode)
        )
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate forall a. Annotation a
FileColor forall ann. Doc ann
reportFile
   in {- (2) -} forall ann. Doc ann
hardline forall a. Semigroup a => a -> a -> a
<> forall {a}. Doc (Annotation a)
fileMarker
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> {- (3) -}  {- (3) -} forall ann. Int -> WithUnicode -> Doc (Annotation ann)
pipePrefix Int
maxLineNumberLength WithUnicode
withUnicode
        forall a. Semigroup a => a -> a -> a
<> {- (4) -} forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> [(Int, [(Position, Marker (Doc ann))])]
-> [(Position, Marker (Doc ann))]
-> [Int]
-> Doc (Annotation ann)
prettyAllLines FileMap
fileContent WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
maxLineNumberLength [(Int, [(Position, Marker (Doc ann))])]
sortedMarkersPerLine [(Position, Marker (Doc ann))]
multilineMarkers [Int]
allLineNumbers

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

-- |
splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine :: forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [] = (forall a. Monoid a => a
mempty, 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 forall a. Eq a => a -> a -> Bool
== Int
el then forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith forall a. Semigroup a => a -> a -> a
(<>) Int
bl [(Position, Marker msg)
m]) else forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Position, Marker msg)
m forall a. a -> [a] -> [a]
:))
        (forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker msg)]
ms)

-- |
prettyAllLines ::
  FileMap ->
  WithUnicode ->
  Bool ->
  -- | The number of spaces each TAB character will span
  TabSize ->
  Int ->
  [(Int, [(Position, Marker (Doc ann))])] ->
  [(Position, Marker (Doc ann))] ->
  [Int] ->
  Doc (Annotation ann)
prettyAllLines :: forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> [(Int, [(Position, Marker (Doc ann))])]
-> [(Position, Marker (Doc ann))]
-> [Int]
-> Doc (Annotation ann)
prettyAllLines FileMap
files WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
leftLen [(Int, [(Position, Marker (Doc ann))])]
inline [(Position, Marker (Doc ann))]
multiline [Int]
lineNumbers =
  case [Int]
lineNumbers of
    [] ->
      forall {a} {ann}.
Bool -> [(a, Marker (Doc ann))] -> Doc (Annotation ann)
showMultiline Bool
True [(Position, Marker (Doc ann))]
multiline
    [Int
l] ->
      let ([(Position, Marker (Doc ann))]
ms, Doc (Annotation ann)
doc) = Bool
-> Int -> ([(Position, Marker (Doc ann))], Doc (Annotation ann))
showForLine Bool
True Int
l
       in Doc (Annotation ann)
doc
            forall a. Semigroup a => a -> a -> a
<> forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> [(Int, [(Position, Marker (Doc ann))])]
-> [(Position, Marker (Doc ann))]
-> [Int]
-> Doc (Annotation ann)
prettyAllLines FileMap
files WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
leftLen [(Int, [(Position, Marker (Doc ann))])]
inline [(Position, Marker (Doc ann))]
ms []
    Int
l1 : Int
l2 : [Int]
ls ->
      let ([(Position, Marker (Doc ann))]
ms, Doc (Annotation ann)
doc) = Bool
-> Int -> ([(Position, Marker (Doc ann))], Doc (Annotation ann))
showForLine Bool
False Int
l1
       in Doc (Annotation ann)
doc
            forall a. Semigroup a => a -> a -> a
<> (if Int
l2 forall a. Eq a => a -> a -> Bool
/= Int
l1 forall a. Num a => a -> a -> a
+ Int
1 then forall ann. Doc ann
hardline forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
leftLen WithUnicode
withUnicode else forall a. Monoid a => a
mempty)
            forall a. Semigroup a => a -> a -> a
<> forall ann.
FileMap
-> WithUnicode
-> Bool
-> TabSize
-> Int
-> [(Int, [(Position, Marker (Doc ann))])]
-> [(Position, Marker (Doc ann))]
-> [Int]
-> Doc (Annotation ann)
prettyAllLines FileMap
files WithUnicode
withUnicode Bool
isError TabSize
tabSize Int
leftLen [(Int, [(Position, Marker (Doc ann))])]
inline [(Position, Marker (Doc ann))]
ms (Int
l2 forall a. a -> [a] -> [a]
: [Int]
ls)
  where
    showForLine :: Bool
-> Int -> ([(Position, Marker (Doc ann))], Doc (Annotation ann))
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 (Doc ann))]
allInlineMarkersInLine = forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(==) Int
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Int, [(Position, Marker (Doc ann))])]
inline

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

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

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

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

          ([(Position, Marker (Doc ann))]
multilineEndingOnLine, [(Position, Marker (Doc ann))]
otherMultilines) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition [(Position, Marker (Doc ann))]
multiline \(Position (Int, Int)
_ (Int
el, Int
_) String
_, Marker (Doc ann)
_) -> Int
el forall a. Eq a => a -> a -> Bool
== Int
line
          shouldShowMultiLine :: Bool
shouldShowMultiLine = Bool
isLastLine
            Bool -> Bool -> Bool
|| (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void)) (forall a. [a] -> Maybe a
List.safeLast [(Position, Marker (Doc ann))]
multilineEndingOnLine) (forall a. [a] -> Maybe a
List.safeLast [(Position, Marker (Doc ann))]
multiline)

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

          -- we need to remove all blank markers because they are irrelevant to the display
          allInlineMarkersInLine' :: [(Position, Marker (Doc ann))]
allInlineMarkersInLine' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Marker a -> Bool
isBlank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Position, Marker (Doc ann))]
allInlineMarkersInLine
          allMultilineMarkersSpanningLine' :: [(Position, Marker (Doc ann))]
allMultilineMarkersSpanningLine' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Marker a -> Bool
isBlank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Position, Marker (Doc ann))]
allMultilineMarkersSpanningLine

          (WidthTable
widths, Doc (Annotation ann)
renderedCode) = forall msg ann.
FileMap
-> [(Position, Marker msg)]
-> Int
-> TabSize
-> Bool
-> (WidthTable, Doc (Annotation ann))
getLine_ FileMap
files ([(Position, Marker (Doc ann))]
allInlineMarkersInLine forall a. Semigroup a => a -> a -> a
<> [(Position, Marker (Doc ann))]
allMultilineMarkersInLine forall a. Semigroup a => a -> a -> a
<> [(Position, Marker (Doc ann))]
allMultilineMarkersSpanningLine') Int
line TabSize
tabSize Bool
isError
       in ( [(Position, Marker (Doc ann))]
otherMultilines,
            forall ann. Doc ann
hardline
              forall a. Semigroup a => a -> a -> a
<> {- (1) -} forall ann. Int -> Int -> WithUnicode -> Doc (Annotation ann)
linePrefix Int
leftLen Int
line WithUnicode
withUnicode forall ann. Doc ann -> Doc ann -> Doc ann
<+>  forall {a}. Doc (Annotation a)
additionalPrefix
              forall a. Semigroup a => a -> a -> a
<> forall {a}. Doc (Annotation a)
renderedCode
              forall a. Semigroup a => a -> a -> a
<> {- (2) -} forall ann.
Bool
-> Bool
-> (Doc (Annotation ann) -> Doc (Annotation ann))
-> WithUnicode
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker (Doc ann))]
-> Doc (Annotation ann)
showAllMarkersInLine (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker (Doc ann))]
multiline) Bool
inSpanOfMultiline forall {ann}. Doc (Annotation ann) -> Doc (Annotation ann)
colorOfFirstMultilineMarker WithUnicode
withUnicode Bool
isError Int
leftLen WidthTable
widths [(Position, Marker (Doc ann))]
allInlineMarkersInLine'
              forall a. Semigroup a => a -> a -> a
<> forall {a} {ann}.
Bool -> [(a, Marker (Doc ann))] -> Doc (Annotation ann)
showMultiline Bool
shouldShowMultiLine [(Position, Marker (Doc ann))]
multilineEndingOnLine
          )

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

          prefix :: Doc (Annotation ann)
prefix = forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
leftLen WithUnicode
withUnicode forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
space

          prefixWithBar :: Maybe (Annotation ann) -> Doc (Annotation ann)
prefixWithBar Maybe (Annotation ann)
color = forall {a}. Doc (Annotation a)
prefix forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall ann. ann -> Doc ann -> Doc ann
annotate Maybe (Annotation ann)
color (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"| " Doc (Annotation ann)
"│ " WithUnicode
withUnicode)

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

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

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

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

    showMarkers :: Int -> Int -> Doc (Annotation ann)
showMarkers Int
n Int
lineLen
      | Int
n forall a. Ord a => a -> a -> Bool
> Int
lineLen = forall a. Monoid a => a
mempty -- reached the end of the line
      | Bool
otherwise =
        let allMarkers :: [(Position, Marker (Doc ann))]
allMarkers = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker (Doc ann))]
ms \(Position (Int
_, Int
bc) (Int
_, Int
ec) String
_, Marker (Doc ann)
mark) -> Bool -> Bool
not (forall a. Marker a -> Bool
isBlank Marker (Doc ann)
mark) Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
>= Int
bc Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
< Int
ec
         in -- only consider markers which span onto the current column
            case [(Position, Marker (Doc ann))]
allMarkers of
              [] -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) forall ann. Doc ann
space) forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc (Annotation ann)
showMarkers (Int
n 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 (Doc ann)
marker) : [(Position, Marker (Doc ann))]
_ ->
                forall ann. ann -> Doc ann -> Doc ann
annotate
                  (forall msg ann. Bool -> Marker msg -> Annotation ann
markerColor Bool
isError Marker (Doc ann)
marker)
                  ( if forall a b. (a, b) -> b
snd (Int, Int)
begin forall a. Eq a => a -> a -> Bool
== Int
n
                      then forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"^" Doc (Annotation ann)
"┬" WithUnicode
withUnicode forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"-" Doc (Annotation ann)
"─" WithUnicode
withUnicode))
                      else forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"-" Doc (Annotation ann)
"─" WithUnicode
withUnicode))
                  )
                  forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc (Annotation ann)
showMarkers (Int
n forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen

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

            allColumns :: Int -> [(Position, Doc ann)] -> (a, [Doc ann])
allColumns Int
_ [] = (a
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 forall a. Eq a => a -> a -> Bool
== Int
bc = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Num a => a -> a -> a
+ a
1) (Doc ann
col forall a. a -> [a] -> [a]
:) (Int -> [(Position, Doc ann)] -> (a, [Doc ann])
allColumns (Int
n forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms')
              | Int
n forall a. Ord a => a -> a -> Bool
< Int
bc = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Num a => a -> a -> a
+ a
1) (forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (a, [Doc ann])
allColumns (Int
n forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms)
              | Bool
otherwise = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Num a => a -> a -> a
+ a
1) (forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (a, [Doc ann])
allColumns (Int
n 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker (Doc ann))]
filteredPipes forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker (Doc ann))]
pipes

            lineStart :: [(Position, Doc (Annotation ann))] -> Doc (Annotation ann)
lineStart [(Position, Doc (Annotation ann))]
pipes =
              let (Int
n, [Doc (Annotation ann)]
docs) = forall {a} {ann}.
Num a =>
Int -> [(Position, Doc ann)] -> (a, [Doc ann])
allColumns Int
1 forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Position, Doc (Annotation ann))]
pipes
                  numberOfSpaces :: Int
numberOfSpaces = Int -> Int -> Int
widthsBetween Int
n Int
bc
               in forall ann. Int -> WithUnicode -> Doc (Annotation ann)
dotPrefix Int
leftLen WithUnicode
withUnicode forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (Annotation ann)
specialPrefix forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Doc (Annotation ann)]
docs forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (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 ann)
prefix =
              let ([(Position, Marker (Doc ann))]
pipesBefore, [(Position, Marker (Doc ann))]
pipesAfter) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Ord a => a -> a -> Bool
< Int
bc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Position, Marker (Doc ann))]
nubbedPipes
                  -- split the list so that all pipes before can have `|`s but pipes after won't

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

                  lastBeginPosition :: Maybe Int
lastBeginPosition = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
List.safeLast (forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Position, Marker (Doc ann))]
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 ann)
currentPipe = forall a. a -> a -> WithUnicode -> a
unicode (forall a. a -> a -> Bool -> a
bool Doc (Annotation ann)
"`" Doc (Annotation ann)
"|" Bool
hasSuccessor) (forall a. a -> a -> Bool -> a
bool Doc (Annotation ann)
"╰" Doc (Annotation ann)
"├" Bool
hasSuccessor) WithUnicode
withUnicode

                  lineChar :: Char
lineChar = forall a. a -> a -> WithUnicode -> a
unicode Char
'-' Char
'─' WithUnicode
withUnicode
                  pointChar :: Doc (Annotation ann)
pointChar = forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"-" Doc (Annotation ann)
"╸" WithUnicode
withUnicode

                  bc' :: Int
bc' = Int
bc forall a. Num a => a -> a -> a
+ Int
lineLen forall a. Num a => a -> a -> a
+ Int
2
                  pipesBeforeMessageStart :: [(Position, Marker (Doc ann))]
pipesBeforeMessageStart = forall a. (a -> Bool) -> [a] -> [a]
List.filter ((forall a. Ord a => a -> a -> Bool
< Int
bc') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Position, Marker (Doc ann))]
pipesAfter
                  -- consider pipes before, as well as pipes which came before the text rectangle bounds
                  pipesBeforeMessageRendered :: [(Position, Doc (Annotation ann))]
pipesBeforeMessageRendered = ([(Position, Marker (Doc ann))]
pipesBefore forall a. Semigroup a => a -> a -> a
<> [(Position, Marker (Doc ann))]
pipesBeforeMessageStart) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker (Doc ann)
marker -> forall ann. ann -> Doc ann -> Doc ann
annotate (forall msg ann. Bool -> Marker msg -> Annotation ann
markerColor Bool
isError Marker (Doc ann)
marker) (forall a. a -> a -> WithUnicode -> a
unicode Doc (Annotation ann)
"|" Doc (Annotation ann)
"│" WithUnicode
withUnicode)
               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 ann))] -> Doc (Annotation ann)
lineStart forall {ann}. [(Position, Doc (Annotation ann))]
pipesBeforeRendered
                    forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate (forall msg ann. Bool -> Marker msg -> Annotation ann
markerColor Bool
isError Marker (Doc ann)
msg) (Doc (Annotation ann)
currentPipe forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Int -> a -> [a]
replicate Int
lineLen Char
lineChar) forall a. Semigroup a => a -> a -> a
<> Doc (Annotation ann)
pointChar)
                    forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate (forall msg ann. Bool -> Marker msg -> Annotation ann
markerColor Bool
isError Marker (Doc ann)
msg) (forall ann. Doc ann -> Int -> Doc ann -> Doc ann
replaceLinesWith (forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> [(Position, Doc (Annotation ann))] -> Doc (Annotation ann)
lineStart forall {ann}. [(Position, Doc (Annotation ann))]
pipesBeforeMessageRendered forall ann. Doc ann -> Doc ann -> Doc ann
<+> if forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [(Position, Marker (Doc ann))]
pipesBeforeMessageStart then Doc (Annotation ann)
"  " else Doc (Annotation ann)
" ") Int
0 forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc (Annotation ann)
annotated forall a b. (a -> b) -> a -> b
$ forall msg. Marker msg -> msg
markerMessage Marker (Doc ann)
msg)
         in forall ann. Doc ann
hardline forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (Annotation ann)
prefix forall a. Semigroup a => a -> a -> a
<> Doc (Annotation ann)
-> [(Position, Marker (Doc ann))] -> t -> Doc (Annotation ann)
showMessages Doc (Annotation ann)
specialPrefix [(Position, Marker (Doc ann))]
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 -> Int -> Doc ann -> Doc ann
replaceLinesWith :: forall ann. Doc ann -> Int -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl = Int -> Doc ann -> Doc ann
go
 where
  replWidth :: Int
replWidth = forall {ann}. SimpleDocStream ann -> Int
sdsWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact forall a b. (a -> b) -> a -> b
$ Doc ann
repl
  sdsWidth :: SimpleDocStream ann -> Int
sdsWidth = \case
    SimpleDocStream ann
SFail -> Int
0
    SimpleDocStream ann
SEmpty -> Int
0
    SChar Char
_ SimpleDocStream ann
sds -> Int
1 forall a. Num a => a -> a -> a
+ SimpleDocStream ann -> Int
sdsWidth SimpleDocStream ann
sds
    SText Int
l Text
_ SimpleDocStream ann
sds -> Int
l forall a. Num a => a -> a -> a
+ SimpleDocStream ann -> Int
sdsWidth SimpleDocStream ann
sds
    SLine Int
_ SimpleDocStream ann
_ -> forall a. HasCallStack => String -> a
error String
"replaceLinesWith was given a prefix with a line break"
    SAnnPush ann
_ SimpleDocStream ann
sds -> SimpleDocStream ann -> Int
sdsWidth SimpleDocStream ann
sds
    SAnnPop SimpleDocStream ann
sds -> SimpleDocStream ann -> Int
sdsWidth SimpleDocStream ann
sds
  replWithNesting :: Int -> Doc ann
replWithNesting Int
n = forall ann. Doc ann
hardline forall a. Semigroup a => a -> a -> a
<> Doc ann
repl forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Text
textSpaces Int
n)
  go :: Int -> Doc ann -> Doc ann
go Int
n = \case
    Doc ann
Line -> Int -> Doc ann
replWithNesting Int
n
    Doc ann
Fail -> forall ann. Doc ann
Fail
    Doc ann
Empty -> forall ann. Doc ann
Empty
    Char Char
c -> forall ann. Char -> Doc ann
Char Char
c
    Text Int
l Text
txt -> forall ann. Int -> Text -> Doc ann
Text Int
l Text
txt
    FlatAlt Doc ann
f Doc ann
d -> forall ann. Doc ann -> Doc ann -> Doc ann
FlatAlt (Int -> Doc ann -> Doc ann
go Int
n Doc ann
f) (Int -> Doc ann -> Doc ann
go Int
n Doc ann
d)
    Cat Doc ann
c Doc ann
d -> forall ann. Doc ann -> Doc ann -> Doc ann
Cat (Int -> Doc ann -> Doc ann
go Int
n Doc ann
c) (Int -> Doc ann -> Doc ann
go Int
n Doc ann
d)
    Nest Int
n' Doc ann
d -> Int -> Doc ann -> Doc ann
go (Int
n forall a. Num a => a -> a -> a
+ Int
n') Doc ann
d
    Union Doc ann
c Doc ann
d -> forall ann. Doc ann -> Doc ann -> Doc ann
Union (Int -> Doc ann -> Doc ann
go Int
n Doc ann
c) (Int -> Doc ann -> Doc ann
go Int
n Doc ann
d)
    Column Int -> Doc ann
f -> forall ann. (Int -> Doc ann) -> Doc ann
Column (Int -> Doc ann -> Doc ann
go Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f)
    -- In this case we add both our fake nesting level (from the 'Nest'
    -- constructors we've eliminated) and the nesting level from the line
    -- prefixes
    Nesting Int -> Doc ann
f -> forall ann. (Int -> Doc ann) -> Doc ann
Nesting (Int -> Doc ann -> Doc ann
go Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
replWidth) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
n))
    Annotated ann
ann Doc ann
doc -> forall ann. ann -> Doc ann -> Doc ann
Annotated ann
ann (Int -> Doc ann -> Doc ann
go Int
n Doc ann
doc)
    WithPageWidth PageWidth -> Doc ann
f -> forall ann. (PageWidth -> Doc ann) -> Doc ann
WithPageWidth (Int -> Doc ann -> Doc ann
go Int
n 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 ann
markerColor :: forall msg ann. Bool -> Marker msg -> Annotation ann
markerColor Bool
isError (This msg
_) = forall a. Bool -> Annotation a
ThisColor Bool
isError
markerColor Bool
_ (Where msg
_) = forall a. Annotation a
WhereColor
markerColor Bool
_ (Maybe msg
_) = forall a. Annotation a
MaybeColor
markerColor Bool
_ Marker msg
Blank = forall a. Annotation a
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 :: forall msg. 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 = forall a. HasCallStack => a
undefined
{-# INLINE markerMessage #-}

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

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

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

annotated :: Doc ann -> Doc (Annotation ann)
annotated :: forall ann. Doc ann -> Doc (Annotation ann)
annotated = forall ann ann'. (ann -> ann') -> Doc ann -> Doc ann'
reAnnotate forall a. a -> Annotation a
OtherStyle

unicode :: a -> a -> WithUnicode -> a
unicode :: forall a. a -> a -> WithUnicode -> a
unicode a
f a
t = \case
  WithUnicode
WithoutUnicode -> a
f
  WithUnicode
WithUnicode -> a
t