{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS -Wno-name-shadowing #-}
module Error.Diagnose.Report.Internal
( module Error.Diagnose.Report.Internal
, Report(.., Warn, Err)
) where
#ifdef USE_AESON
import Data.Aeson (ToJSON(..), object, (.=))
#endif
import Control.Applicative ((<|>))
import qualified Data.Array.IArray as Array
import Data.Array.Unboxed (Array, IArray, Ix, UArray, listArray, (!))
import Data.Bifunctor (bimap, first, second)
import Data.Char.WCWidth (wcwidth)
import Data.Default (def)
import Data.Foldable (fold)
import Data.Function (on)
import Data.Functor ((<&>))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.List as List
import qualified Data.List.Safe as List
import Data.Maybe
import Data.Ord (Down (Down))
import Data.String (IsString (fromString))
import qualified Data.Text as Text
import Error.Diagnose.Position
import Error.Diagnose.Style (Annotation (..))
import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>))
import Prettyprinter.Internal (Doc (..))
type FileMap = HashMap FilePath (Array Int String)
type WidthTable = UArray Int Int
data Report msg
= Report
Bool
(Maybe msg)
msg
[(Position, Marker msg)]
[Note msg]
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)
-> (Void# -> r)
-> r
Warn errCode msg reports notes = Report False errCode msg reports notes
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)
-> (Void# -> 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 =
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report (Bool
isError1 Bool -> Bool -> Bool
|| Bool
isError2) (Maybe msg
code1 Maybe msg -> Maybe msg -> Maybe msg
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe msg
code2) (msg
msg1 msg -> msg -> msg
forall a. Semigroup a => a -> a -> a
<> msg
msg2) ([(Position, Marker msg)]
pos1 [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
pos2) ([Note msg]
hints1 [Note msg] -> [Note msg] -> [Note msg]
forall a. Semigroup a => a -> a -> a
<> [Note msg]
hints2)
instance Monoid msg => Monoid (Report msg) where
mempty :: Report msg
mempty = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False Maybe msg
forall a. Maybe a
Nothing msg
forall a. Monoid a => a
mempty [(Position, Marker msg)]
forall a. Monoid a => a
mempty [Note msg]
forall a. Monoid a => a
mempty
#ifdef USE_AESON
instance ToJSON msg => ToJSON (Report msg) where
toJSON :: Report msg -> Value
toJSON (Report Bool
isError Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
hints) =
[Pair] -> Value
object [ Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (if Bool
isError then String
"error" else String
"warning" :: String)
, Text
"code" Text -> Maybe msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe msg
code
, Text
"message" Text -> msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= msg
msg
, Text
"markers" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Position, Marker msg) -> Value)
-> [(Position, Marker msg)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Position, Marker msg) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, Marker v) -> Value
showMarker [(Position, Marker msg)]
markers
, Text
"hints" Text -> [Note msg] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Note msg]
hints
]
where
showMarker :: (v, Marker v) -> Value
showMarker (v
pos, Marker v
marker) =
[Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Text
"position" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
pos ]
[Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> case Marker v
marker of
This v
m -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
, Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"this" :: String)
]
Where v
m -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
, Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"where" :: String)
]
Maybe v
m -> [ Text
"message" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
m
, Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"maybe" :: String)
]
Marker v
Blank -> [ Text
"kind" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"blank" :: String) ]
#endif
data Marker msg
=
This msg
|
Where msg
|
Maybe msg
|
Blank
instance Eq (Marker msg) where
This msg
_ == :: Marker msg -> Marker msg -> Bool
== This msg
_ = Bool
True
Where msg
_ == Where msg
_ = Bool
True
Maybe msg
_ == Maybe msg
_ = Bool
True
Marker msg
Blank == Marker msg
Blank = Bool
True
Marker msg
_ == Marker msg
_ = Bool
False
{-# INLINEABLE (==) #-}
instance Ord (Marker msg) where
This msg
_ < :: Marker msg -> Marker msg -> Bool
< Marker msg
_ = Bool
False
Where msg
_ < This msg
_ = Bool
True
Where msg
_ < Marker msg
_ = Bool
False
Maybe msg
_ < Marker msg
_ = Bool
True
Marker msg
_ < Marker msg
Blank = Bool
True
Marker msg
Blank < Marker msg
_ = Bool
False
{-# INLINEABLE (<) #-}
Marker msg
m1 <= :: Marker msg -> Marker msg -> Bool
<= Marker msg
m2 = Marker msg
m1 Marker msg -> Marker msg -> Bool
forall a. Ord a => a -> a -> Bool
< Marker msg
m2 Bool -> Bool -> Bool
|| Marker msg
m1 Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
== Marker msg
m2
{-# INLINEABLE (<=) #-}
data Note msg
=
Note msg
|
Hint msg
#ifdef USE_AESON
instance ToJSON msg => ToJSON (Note msg) where
toJSON :: Note msg -> Value
toJSON (Note msg
msg) = [Pair] -> Value
object [ Text
"note" Text -> msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= msg
msg ]
toJSON (Hint msg
msg) = [Pair] -> Value
object [ Text
"hint" Text -> msg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= msg
msg ]
#endif
instance IsString msg => IsString (Note msg) where
fromString :: String -> Note msg
fromString = msg -> Note msg
forall msg. msg -> Note msg
Note (msg -> Note msg) -> (String -> msg) -> String -> Note msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> msg
forall a. IsString a => String -> a
fromString
warn,
err ::
Maybe msg ->
msg ->
[(Position, Marker msg)] ->
[Note msg] ->
Report msg
warn :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
warn = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False
{-# INLINE warn #-}
{-# DEPRECATED warn "'warn' is deprecated. Use 'Warn' instead." #-}
err :: forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
err = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
True
{-# INLINE err #-}
{-# DEPRECATED err "'err' is deprecated. Use 'Err' instead." #-}
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) = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
True Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes
warningToError r :: Report msg
r@(Report Bool
True Maybe msg
_ msg
_ [(Position, Marker msg)]
_ [Note msg]
_) = Report msg
r
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) = Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
forall msg.
Bool
-> Maybe msg
-> msg
-> [(Position, Marker msg)]
-> [Note msg]
-> Report msg
Report Bool
False Maybe msg
code msg
msg [(Position, Marker msg)]
markers [Note msg]
notes
errorToWarning r :: Report msg
r@(Report Bool
False Maybe msg
_ msg
_ [(Position, Marker msg)]
_ [Note msg]
_) = Report msg
r
prettyReport ::
Pretty msg =>
FileMap ->
Bool ->
Int ->
Report msg ->
Doc Annotation
prettyReport :: forall msg.
Pretty msg =>
FileMap -> Bool -> Int -> Report msg -> Doc Annotation
prettyReport FileMap
fileContent Bool
withUnicode Int
tabSize (Report Bool
isError Maybe msg
code msg
message [(Position, Marker msg)]
markers [Note msg]
hints) =
let sortedMarkers :: [(Position, Marker msg)]
sortedMarkers = ((Position, Marker msg) -> Int)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker msg)]
markers
groupedMarkers :: [(Bool, [(Position, Marker msg)])]
groupedMarkers = [(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
forall msg.
Pretty msg =>
[(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [(Position, Marker msg)]
sortedMarkers
maxLineNumberLength :: Int
maxLineNumberLength = Int
-> ((Position, Marker msg) -> Int)
-> Maybe (Position, Marker msg)
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
3 (Int -> Int)
-> ((Position, Marker msg) -> Int) -> (Position, Marker msg) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((Position, Marker msg) -> String)
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Position, Marker msg) -> Int)
-> (Position, Marker msg)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
end (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) (Maybe (Position, Marker msg) -> Int)
-> Maybe (Position, Marker msg) -> Int
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
markers
header :: Doc Annotation
header =
Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate
(Bool -> Annotation
KindColor Bool
isError)
( Doc Annotation
forall ann. Doc ann
lbracket
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isError
then Doc Annotation
"error"
else Doc Annotation
"warning"
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> case Maybe msg
code of
Maybe msg
Nothing -> Doc Annotation
forall ann. Doc ann
rbracket
Just msg
code -> Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty msg
code Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
rbracket
)
in
Doc Annotation
header Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
colon Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann
align (msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty msg
message)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((Bool -> [(Position, Marker msg)] -> Doc Annotation)
-> (Bool, [(Position, Marker msg)]) -> Doc Annotation
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
prettySubReport FileMap
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength) ((Bool, [(Position, Marker msg)]) -> Doc Annotation)
-> [(Bool, [(Position, Marker msg)])] -> [Doc Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, [(Position, Marker msg)])]
groupedMarkers)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> ( if
| [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints Bool -> Bool -> Bool
&& [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
markers -> Doc Annotation
forall a. Monoid a => a
mempty
| [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints -> Doc Annotation
forall a. Monoid a => a
mempty
| Bool
otherwise -> Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
maxLineNumberLength Bool
withUnicode
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Note msg] -> Int -> Bool -> Doc Annotation
forall msg.
Pretty msg =>
[Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [Note msg]
hints Int
maxLineNumberLength Bool
withUnicode
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> ( if [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
markers Bool -> Bool -> Bool
&& [Note msg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note msg]
hints
then Doc Annotation
forall a. Monoid a => a
mempty
else
Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (if Bool
withUnicode then Char
'─' else Char
'-') Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> if Bool
withUnicode then Doc Annotation
"╯" else Doc Annotation
"+")
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
)
pad :: Int -> Char -> Doc ann -> Doc ann
pad :: forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
n Char
c Doc ann
d = Doc ann -> (Int -> Doc ann) -> Doc ann
forall ann. Doc ann -> (Int -> Doc ann) -> Doc ann
width Doc ann
d \Int
w -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w) Char
c
dotPrefix ::
Int ->
Bool ->
Doc Annotation
dotPrefix :: Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"•" else Doc Annotation
":")
{-# INLINE dotPrefix #-}
pipePrefix ::
Int ->
Bool ->
Doc Annotation
pipePrefix :: Int -> Bool -> Doc Annotation
pipePrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
{-# INLINE pipePrefix #-}
linePrefix ::
Int ->
Int ->
Bool ->
Doc Annotation
linePrefix :: Int -> Int -> Bool -> Doc Annotation
linePrefix Int
leftLen Int
lineNo Bool
withUnicode =
let lineNoLen :: Int
lineNoLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
lineNo)
in Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Doc Annotation -> Doc Annotation)
-> Doc Annotation -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
leftLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNoLen) Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty Int
lineNo Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|"
{-# INLINE linePrefix #-}
ellipsisPrefix ::
Int ->
Bool ->
Doc Annotation
ellipsisPrefix :: Int -> Bool -> Doc Annotation
ellipsisPrefix Int
leftLen Bool
withUnicode = Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
leftLen Char
' ' Doc Annotation
forall a. Monoid a => a
mempty Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
"⋮" else Doc Annotation
"...")
groupMarkersPerFile ::
Pretty msg =>
[(Position, Marker msg)] ->
[(Bool, [(Position, Marker msg)])]
groupMarkersPerFile :: forall msg.
Pretty msg =>
[(Position, Marker msg)] -> [(Bool, [(Position, Marker msg)])]
groupMarkersPerFile [] = []
groupMarkersPerFile [(Position, Marker msg)]
markers =
let markersPerFile :: HashMap String [(Position, Marker msg)]
markersPerFile = (HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)])
-> HashMap String [(Position, Marker msg)]
-> [HashMap String [(Position, Marker msg)]]
-> HashMap String [(Position, Marker msg)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (([(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
(<>)) HashMap String [(Position, Marker msg)]
forall a. Monoid a => a
mempty ([HashMap String [(Position, Marker msg)]]
-> HashMap String [(Position, Marker msg)])
-> [HashMap String [(Position, Marker msg)]]
-> HashMap String [(Position, Marker msg)]
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)]
markers [(Position, Marker msg)]
-> ((Position, Marker msg)
-> HashMap String [(Position, Marker msg)])
-> [HashMap String [(Position, Marker msg)]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \tup :: (Position, Marker msg)
tup@(Position
p, Marker msg
_) -> String
-> [(Position, Marker msg)]
-> HashMap String [(Position, Marker msg)]
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (Position -> String
file Position
p) [(Position, Marker msg)
tup]
in
[[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])]
forall {b}. [b] -> [(Bool, b)]
onlyFirstToTrue ([[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])])
-> [[(Position, Marker msg)]] -> [(Bool, [(Position, Marker msg)])]
forall a b. (a -> b) -> a -> b
$ [[(Position, Marker msg)]] -> [[(Position, Marker msg)]]
forall {a} {msg}. [[(a, Marker msg)]] -> [[(a, Marker msg)]]
putThisMarkersAtTop ([[(Position, Marker msg)]] -> [[(Position, Marker msg)]])
-> [[(Position, Marker msg)]] -> [[(Position, Marker msg)]]
forall a b. (a -> b) -> a -> b
$ HashMap String [(Position, Marker msg)]
-> [[(Position, Marker msg)]]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap String [(Position, Marker msg)]
markersPerFile
where
onlyFirstToTrue :: [b] -> [(Bool, b)]
onlyFirstToTrue = Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
forall {b}. Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
True []
go :: Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
_ [(Bool, b)]
acc [] = [(Bool, b)] -> [(Bool, b)]
forall a. [a] -> [a]
reverse [(Bool, b)]
acc
go Bool
t [(Bool, b)]
acc (b
x : [b]
xs) = Bool -> [(Bool, b)] -> [b] -> [(Bool, b)]
go Bool
False ((Bool
t, b
x) (Bool, b) -> [(Bool, b)] -> [(Bool, b)]
forall a. a -> [a] -> [a]
: [(Bool, b)]
acc) [b]
xs
putThisMarkersAtTop :: [[(a, Marker msg)]] -> [[(a, Marker msg)]]
putThisMarkersAtTop = ([(a, Marker msg)] -> [(a, Marker msg)] -> Ordering)
-> [[(a, Marker msg)]] -> [[(a, Marker msg)]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy \[(a, Marker msg)]
ms1 [(a, Marker msg)]
ms2 ->
if
| (Marker msg -> Bool) -> [Marker msg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Marker msg -> Bool
forall msg. Marker msg -> Bool
isThisMarker ((a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Marker msg)
-> [(a, Marker msg)] -> [Marker msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)]
ms1) -> Ordering
LT
| (Marker msg -> Bool) -> [Marker msg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Marker msg -> Bool
forall msg. Marker msg -> Bool
isThisMarker ((a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Marker msg)
-> [(a, Marker msg)] -> [Marker msg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)]
ms2) -> Ordering
GT
| Bool
otherwise -> Ordering
EQ
prettySubReport ::
Pretty msg =>
FileMap ->
Bool ->
Bool ->
Int ->
Int ->
Bool ->
[(Position, Marker msg)] ->
Doc Annotation
prettySubReport :: forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> Bool
-> [(Position, Marker msg)]
-> Doc Annotation
prettySubReport FileMap
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength Bool
isFirst [(Position, Marker msg)]
markers =
let (HashMap Int [(Position, Marker msg)]
markersPerLine, [(Position, Marker msg)]
multilineMarkers) = [(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker msg)]
markers
sortedMarkersPerLine :: [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine = ((Int, [(Position, Marker msg)]) -> Int)
-> [(Int, [(Position, Marker msg)])]
-> [(Int, [(Position, Marker msg)])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst (HashMap Int [(Position, Marker msg)]
-> [(Int, [(Position, Marker msg)])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Int [(Position, Marker msg)]
markersPerLine)
reportFile :: Doc ann
reportFile = Doc ann
-> ((Position, Marker msg) -> Doc ann)
-> Maybe (Position, Marker msg)
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a ann. Pretty a => a -> Doc ann
pretty @Position Position
forall a. Default a => a
def) (Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Position -> Doc ann)
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) (Maybe (Position, Marker msg) -> Doc ann)
-> Maybe (Position, Marker msg) -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead (((Position, Marker msg) -> Down (Marker msg))
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Marker msg -> Down (Marker msg)
forall a. a -> Down a
Down (Marker msg -> Down (Marker msg))
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Down (Marker msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) [(Position, Marker msg)]
markers)
allLineNumbers :: [Int]
allLineNumbers = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
List.sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
List.nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst ((Int, [(Position, Marker msg)]) -> Int)
-> [(Int, [(Position, Marker msg)])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine) [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> ([(Position, Marker msg)]
multilineMarkers [(Position, Marker msg)]
-> ((Position, Marker msg) -> [Int]) -> [Int]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> [Int
bl .. Int
el])
fileMarker :: Doc Annotation
fileMarker =
( if Bool
isFirst
then
Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad Int
maxLineNumberLength Char
' ' Doc Annotation
forall a. Monoid a => a
mempty
Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"╭──▶" else Doc Annotation
"+-->")
else
Doc Annotation
forall ann. Doc ann
space Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Doc Annotation
dotPrefix Int
maxLineNumberLength Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (Int -> Char -> Doc Annotation -> Doc Annotation
forall ann. Int -> Char -> Doc ann -> Doc ann
pad (Int
maxLineNumberLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (if Bool
withUnicode then Char
'─' else Char
'-') Doc Annotation
forall a. Monoid a => a
mempty)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
RuleColor (if Bool
withUnicode then Doc Annotation
"┼──▶" else Doc Annotation
"+-->")
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
FileColor Doc Annotation
forall ann. Doc ann
reportFile
in Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
fileMarker
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
hardline
Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
pipePrefix Int
maxLineNumberLength Bool
withUnicode
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
fileContent Bool
withUnicode Bool
isError Int
tabSize Int
maxLineNumberLength [(Int, [(Position, Marker msg)])]
sortedMarkersPerLine [(Position, Marker msg)]
multilineMarkers [Int]
allLineNumbers
isThisMarker :: Marker msg -> Bool
isThisMarker :: forall msg. Marker msg -> Bool
isThisMarker (This msg
_) = Bool
True
isThisMarker Marker msg
_ = Bool
False
splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine :: forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [] = (HashMap Int [(Position, Marker msg)]
forall a. Monoid a => a
mempty, [(Position, Marker msg)]
forall a. Monoid a => a
mempty)
splitMarkersPerLine (m :: (Position, Marker msg)
m@(Position {String
(Int, Int)
file :: String
end :: (Int, Int)
begin :: (Int, Int)
file :: Position -> String
end :: Position -> (Int, Int)
begin :: Position -> (Int, Int)
..}, Marker msg
_) : [(Position, Marker msg)]
ms) =
let (Int
bl, Int
_) = (Int, Int)
begin
(Int
el, Int
_) = (Int, Int)
end
in (if Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
el then (HashMap Int [(Position, Marker msg)]
-> HashMap Int [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (([(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> Int
-> [(Position, Marker msg)]
-> HashMap Int [(Position, Marker msg)]
-> HashMap Int [(Position, Marker msg)]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
(<>) Int
bl [(Position, Marker msg)
m]) else ([(Position, Marker msg)] -> [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Position, Marker msg)
m (Position, Marker msg)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. a -> [a] -> [a]
:))
([(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
forall msg.
[(Position, Marker msg)]
-> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])
splitMarkersPerLine [(Position, Marker msg)]
ms)
prettyAllLines ::
Pretty msg =>
FileMap ->
Bool ->
Bool ->
Int ->
Int ->
[(Int, [(Position, Marker msg)])] ->
[(Position, Marker msg)] ->
[Int] ->
Doc Annotation
prettyAllLines :: forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
multiline [Int]
lineNumbers =
case [Int]
lineNumbers of
[] ->
Bool -> [(Position, Marker msg)] -> Doc Annotation
forall {msg} {a}.
Pretty msg =>
Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline Bool
True [(Position, Marker msg)]
multiline
[Int
l] ->
let ([(Position, Marker msg)]
ms, Doc Annotation
doc) = Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
True Int
l
in Doc Annotation
doc
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
ms []
Int
l1 : Int
l2 : [Int]
ls ->
let ([(Position, Marker msg)]
ms, Doc Annotation
doc) = Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
False Int
l1
in Doc Annotation
doc
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> (if Int
l2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 then Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode else Doc Annotation
forall a. Monoid a => a
mempty)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
forall msg.
Pretty msg =>
FileMap
-> Bool
-> Bool
-> Int
-> Int
-> [(Int, [(Position, Marker msg)])]
-> [(Position, Marker msg)]
-> [Int]
-> Doc Annotation
prettyAllLines FileMap
files Bool
withUnicode Bool
isError Int
tabSize Int
leftLen [(Int, [(Position, Marker msg)])]
inline [(Position, Marker msg)]
ms (Int
l2 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ls)
where
showForLine :: Bool -> Int -> ([(Position, Marker msg)], Doc Annotation)
showForLine Bool
isLastLine Int
line =
let allInlineMarkersInLine :: [(Position, Marker msg)]
allInlineMarkersInLine = (Int, [(Position, Marker msg)]) -> [(Position, Marker msg)]
forall a b. (a, b) -> b
snd ((Int, [(Position, Marker msg)]) -> [(Position, Marker msg)])
-> [(Int, [(Position, Marker msg)])] -> [(Position, Marker msg)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Int, [(Position, Marker msg)]) -> Bool)
-> [(Int, [(Position, Marker msg)])]
-> [(Int, [(Position, Marker msg)])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
line (Int -> Bool)
-> ((Int, [(Position, Marker msg)]) -> Int)
-> (Int, [(Position, Marker msg)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [(Position, Marker msg)]) -> Int
forall a b. (a, b) -> a
fst) [(Int, [(Position, Marker msg)])]
inline
allMultilineMarkersInLine :: [(Position, Marker msg)]
allMultilineMarkersInLine = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
|| Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line
allMultilineMarkersSpanningLine :: [(Position, Marker msg)]
allMultilineMarkersSpanningLine = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
line Bool -> Bool -> Bool
&& Int
el Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
line
inSpanOfMultiline :: Bool
inSpanOfMultiline = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> Bool)
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [(Position, Marker msg)]
multiline \(Position (Int
bl, Int
_) (Int
el, Int
_) String
_, Marker msg
_) -> Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
line Bool -> Bool -> Bool
&& Int
el Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
line
colorOfFirstMultilineMarker :: Doc Annotation -> Doc Annotation
colorOfFirstMultilineMarker = (Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Doc Annotation -> Doc Annotation)
-> Maybe (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Annotation -> Doc Annotation
forall a. a -> a
id (Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Annotation -> Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Annotation)
-> (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError (Marker msg -> Annotation)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) ([(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead ([(Position, Marker msg)] -> Maybe (Position, Marker msg))
-> [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)]
allMultilineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersSpanningLine)
([(Position, Marker msg)]
multilineEndingOnLine, [(Position, Marker msg)]
otherMultilines) = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
-> ([(Position, Marker msg)], [(Position, Marker msg)]))
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> ([(Position, Marker msg)], [(Position, Marker msg)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
-> ([(Position, Marker msg)], [(Position, Marker msg)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition [(Position, Marker msg)]
multiline \(Position (Int, Int)
_ (Int
el, Int
_) String
_, Marker msg
_) -> Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line
!additionalPrefix :: Doc Annotation
additionalPrefix = case [(Position, Marker msg)]
allMultilineMarkersInLine of
[] ->
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
multiline
then
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
allMultilineMarkersSpanningLine
then Doc Annotation -> Doc Annotation
colorOfFirstMultilineMarker if Bool
withUnicode then Doc Annotation
"│ " else Doc Annotation
"| "
else Doc Annotation
" "
else Doc Annotation
forall a. Monoid a => a
mempty
(p :: Position
p@(Position (Int, Int)
_ (Int
el, Int
_) String
_), Marker msg
marker) : [(Position, Marker msg)]
_ ->
let hasPredecessor :: Bool
hasPredecessor = Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
|| Bool
-> (((Position, Marker msg), [(Position, Marker msg)]) -> Bool)
-> Maybe ((Position, Marker msg), [(Position, Marker msg)])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Position
p (Position -> Bool)
-> (((Position, Marker msg), [(Position, Marker msg)]) -> Position)
-> ((Position, Marker msg), [(Position, Marker msg)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Position)
-> (((Position, Marker msg), [(Position, Marker msg)])
-> (Position, Marker msg))
-> ((Position, Marker msg), [(Position, Marker msg)])
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Position, Marker msg), [(Position, Marker msg)])
-> (Position, Marker msg)
forall a b. (a, b) -> a
fst) ([(Position, Marker msg)]
-> Maybe ((Position, Marker msg), [(Position, Marker msg)])
forall a. [a] -> Maybe (a, [a])
List.safeUncons [(Position, Marker msg)]
multiline)
in Doc Annotation -> Doc Annotation
colorOfFirstMultilineMarker
( if
| Bool
hasPredecessor Bool -> Bool -> Bool
&& Bool
withUnicode -> Doc Annotation
"├"
| Bool
hasPredecessor -> Doc Annotation
"|"
| Bool
withUnicode -> Doc Annotation
"╭"
| Bool
otherwise -> Doc Annotation
"+"
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker msg
marker) (if Bool
withUnicode then Doc Annotation
"┤" else Doc Annotation
">")
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
allInlineMarkersInLine' :: [(Position, Marker msg)]
allInlineMarkersInLine' = ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Marker msg
forall msg. Marker msg
Blank (Marker msg -> Bool)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) [(Position, Marker msg)]
allInlineMarkersInLine
allMultilineMarkersSpanningLine' :: [(Position, Marker msg)]
allMultilineMarkersSpanningLine' = ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Marker msg
forall msg. Marker msg
Blank (Marker msg -> Bool)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd) [(Position, Marker msg)]
allMultilineMarkersSpanningLine
(WidthTable
widths, Doc Annotation
renderedCode) = FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
forall msg.
FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
getLine_ FileMap
files ([(Position, Marker msg)]
allInlineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersInLine [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker msg)]
allMultilineMarkersSpanningLine') Int
line Int
tabSize Bool
isError
in ( [(Position, Marker msg)]
otherMultilines,
Doc Annotation
forall ann. Doc ann
hardline
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Bool -> Doc Annotation
linePrefix Int
leftLen Int
line Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
additionalPrefix
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
renderedCode
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
forall msg.
Pretty msg =>
Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
showAllMarkersInLine (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Position, Marker msg)]
multiline) Bool
inSpanOfMultiline Doc Annotation -> Doc Annotation
colorOfFirstMultilineMarker Bool
withUnicode Bool
isError Int
leftLen WidthTable
widths [(Position, Marker msg)]
allInlineMarkersInLine'
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Bool -> [(Position, Marker msg)] -> Doc Annotation
forall {msg} {a}.
Pretty msg =>
Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline (Bool
isLastLine Bool -> Bool -> Bool
|| [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
multilineEndingOnLine Maybe (Position, Marker msg)
-> Maybe (Position, Marker msg) -> Bool
forall a. Eq a => a -> a -> Bool
== [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeLast [(Position, Marker msg)]
multiline) [(Position, Marker msg)]
multilineEndingOnLine
)
showMultiline :: Bool -> [(a, Marker msg)] -> Doc Annotation
showMultiline Bool
_ [] = Doc Annotation
forall a. Monoid a => a
mempty
showMultiline Bool
isLastMultiline [(a, Marker msg)]
multiline =
let colorOfFirstMultilineMarker :: Maybe Annotation
colorOfFirstMultilineMarker = Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError (Marker msg -> Annotation)
-> ((a, Marker msg) -> Marker msg) -> (a, Marker msg) -> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd ((a, Marker msg) -> Annotation)
-> Maybe (a, Marker msg) -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Marker msg)] -> Maybe (a, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(a, Marker msg)]
multiline
prefix :: Doc Annotation
prefix = Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
prefixWithBar :: Maybe Annotation -> Doc Annotation
prefixWithBar Maybe Annotation
color = Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> (Doc Annotation -> Doc Annotation)
-> (Annotation -> Doc Annotation -> Doc Annotation)
-> Maybe Annotation
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Annotation -> Doc Annotation
forall a. a -> a
id Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Maybe Annotation
color (if Bool
withUnicode then Doc Annotation
"│ " else Doc Annotation
"| ")
showMultilineMarkerMessage :: (a, Marker a) -> Bool -> Doc Annotation
showMultilineMarkerMessage (a
_, Marker a
Blank) Bool
_ = Doc Annotation
forall a. Monoid a => a
mempty
showMultilineMarkerMessage (a
_, Marker a
marker) Bool
isLast =
Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) (Doc Annotation -> Doc Annotation)
-> Doc Annotation -> Doc Annotation
forall a b. (a -> b) -> a -> b
$
( if Bool
isLast Bool -> Bool -> Bool
&& Bool
isLastMultiline
then if Bool
withUnicode then Doc Annotation
"╰╸ " else Doc Annotation
"`- "
else if Bool
withUnicode then Doc Annotation
"├╸ " else Doc Annotation
"|- "
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (if Bool
isLast then Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
" " else Maybe Annotation -> Doc Annotation
prefixWithBar (Annotation -> Maybe Annotation
forall a. a -> Maybe a
Just (Annotation -> Maybe Annotation) -> Annotation -> Maybe Annotation
forall a b. (a -> b) -> a -> b
$ Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space) (a -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc Annotation) -> a -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Marker a -> a
forall msg. Marker msg -> msg
markerMessage Marker a
marker)
showMultilineMarkerMessages :: [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [] = []
showMultilineMarkerMessages [(a, Marker a)
m] = [(a, Marker a) -> Bool -> Doc Annotation
forall {a} {a}. Pretty a => (a, Marker a) -> Bool -> Doc Annotation
showMultilineMarkerMessage (a, Marker a)
m Bool
True]
showMultilineMarkerMessages ((a, Marker a)
m : [(a, Marker a)]
ms) = (a, Marker a) -> Bool -> Doc Annotation
forall {a} {a}. Pretty a => (a, Marker a) -> Bool -> Doc Annotation
showMultilineMarkerMessage (a, Marker a)
m Bool
False Doc Annotation -> [Doc Annotation] -> [Doc Annotation]
forall a. a -> [a] -> [a]
: [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [(a, Marker a)]
ms
in Maybe Annotation -> Doc Annotation
prefixWithBar Maybe Annotation
colorOfFirstMultilineMarker Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Doc Annotation -> [Doc Annotation] -> [Doc Annotation]
forall a. a -> [a] -> [a]
List.intersperse Doc Annotation
prefix ([Doc Annotation] -> [Doc Annotation])
-> [Doc Annotation] -> [Doc Annotation]
forall a b. (a -> b) -> a -> b
$ [(a, Marker msg)] -> [Doc Annotation]
forall {a} {a}. Pretty a => [(a, Marker a)] -> [Doc Annotation]
showMultilineMarkerMessages [(a, Marker msg)]
multiline)
getLine_ ::
FileMap ->
[(Position, Marker msg)] ->
Int ->
Int ->
Bool ->
(WidthTable, Doc Annotation)
getLine_ :: forall msg.
FileMap
-> [(Position, Marker msg)]
-> Int
-> Int
-> Bool
-> (WidthTable, Doc Annotation)
getLine_ FileMap
files [(Position, Marker msg)]
markers Int
line Int
tabSize Bool
isError =
case Int -> Array Int String -> Maybe String
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
i -> a i e -> Maybe e
safeArrayIndex (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Array Int String -> Maybe String)
-> Maybe (Array Int String) -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FileMap -> String -> Maybe (Array Int String)
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
(HashMap.!?) FileMap
files (String -> Maybe (Array Int String))
-> ((Position, Marker msg) -> String)
-> (Position, Marker msg)
-> Maybe (Array Int String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> String
file (Position -> String)
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Maybe (Array Int String))
-> Maybe (Position, Marker msg) -> Maybe (Array Int String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(Position, Marker msg)]
markers of
Maybe String
Nothing ->
( String -> WidthTable
mkWidthTable String
"",
Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
NoLineColor Doc Annotation
"<no line>"
)
Just String
code ->
( String -> WidthTable
mkWidthTable String
code,
(((Int, Char) -> Doc Annotation)
-> [(Int, Char)] -> Doc Annotation)
-> [(Int, Char)]
-> ((Int, Char) -> Doc Annotation)
-> Doc Annotation
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, Char) -> Doc Annotation) -> [(Int, Char)] -> Doc Annotation
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Int] -> String -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] String
code) \(Int
n, Char
c) ->
let cdoc :: Doc ann
cdoc = Doc ann -> (Char -> Doc ann) -> Char -> Doc ann
forall a. a -> (Char -> a) -> Char -> a
ifTab (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
tabSize Char
' ')) Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
c
colorizingMarkers :: [(Position, Marker msg)]
colorizingMarkers = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
markers \case
(Position (Int
bl, Int
bc) (Int
el, Int
ec) String
_, Marker msg
_)
| Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
el ->
Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec
| Bool
otherwise ->
(Int
bl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc)
Bool -> Bool -> Bool
|| (Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec)
Bool -> Bool -> Bool
|| (Int
bl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
line Bool -> Bool -> Bool
&& Int
el Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
line)
in (Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Doc Annotation -> Doc Annotation)
-> Maybe (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
CodeStyle)
((\Marker msg
m -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Annotation -> Annotation
MarkerStyle (Annotation -> Annotation) -> Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker msg
m)) (Marker msg -> Doc Annotation -> Doc Annotation)
-> ((Position, Marker msg) -> Marker msg)
-> (Position, Marker msg)
-> Doc Annotation
-> Doc Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Marker msg
forall a b. (a, b) -> b
snd)
([(Position, Marker msg)] -> Maybe (Position, Marker msg)
forall a. [a] -> Maybe a
List.safeHead [(Position, Marker msg)]
colorizingMarkers)
Doc Annotation
forall ann. Doc ann
cdoc
)
where
ifTab :: a -> (Char -> a) -> Char -> a
ifTab :: 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 = (Int, Int) -> [Int] -> WidthTable
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (Int -> (Char -> Int) -> Char -> Int
forall a. a -> (Char -> a) -> Char -> a
ifTab Int
tabSize Char -> Int
wcwidth (Char -> Int) -> String -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s)
showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation
showAllMarkersInLine :: forall msg.
Pretty msg =>
Bool
-> Bool
-> (Doc Annotation -> Doc Annotation)
-> Bool
-> Bool
-> Int
-> WidthTable
-> [(Position, Marker msg)]
-> Doc Annotation
showAllMarkersInLine Bool
_ Bool
_ Doc Annotation -> Doc Annotation
_ Bool
_ Bool
_ Int
_ WidthTable
_ [] = Doc Annotation
forall a. Monoid a => a
mempty
showAllMarkersInLine Bool
hasMultilines Bool
inSpanOfMultiline Doc Annotation -> Doc Annotation
colorMultilinePrefix Bool
withUnicode Bool
isError Int
leftLen WidthTable
widths [(Position, Marker msg)]
ms =
let maxMarkerColumn :: Int
maxMarkerColumn = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Position -> (Int, Int)
end (Position -> (Int, Int)) -> Position -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker msg) -> Position)
-> (Position, Marker msg) -> Position
forall a b. (a -> b) -> a -> b
$ [(Position, Marker msg)] -> (Position, Marker msg)
forall a. [a] -> a
List.last ([(Position, Marker msg)] -> (Position, Marker msg))
-> [(Position, Marker msg)] -> (Position, Marker msg)
forall a b. (a -> b) -> a -> b
$ ((Position, Marker msg) -> Int)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker msg) -> (Int, Int))
-> (Position, Marker msg)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
end (Position -> (Int, Int))
-> ((Position, Marker msg) -> Position)
-> (Position, Marker msg)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker msg) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker msg)]
ms
specialPrefix :: Doc Annotation
specialPrefix
| Bool
inSpanOfMultiline = Doc Annotation -> Doc Annotation
colorMultilinePrefix (if Bool
withUnicode then Doc Annotation
"│ " else Doc Annotation
"| ") Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
| Bool
hasMultilines = Doc Annotation -> Doc Annotation
colorMultilinePrefix Doc Annotation
" " Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
forall ann. Doc ann
space
| Bool
otherwise = Doc Annotation
forall a. Monoid a => a
mempty
in
Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (if [(Position, Marker msg)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [(Position, Marker msg)]
ms then Doc Annotation
forall a. Monoid a => a
mempty else Doc Annotation
specialPrefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
showMarkers Int
1 Int
maxMarkerColumn Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation -> [(Position, Marker msg)] -> Int -> Doc Annotation
forall {a} {t}.
Pretty a =>
Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
specialPrefix [(Position, Marker msg)]
ms Int
maxMarkerColumn)
where
widthAt :: Int -> Int
widthAt Int
i = Int
0 Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
`fromMaybe` Int -> WidthTable -> Maybe Int
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
i -> a i e -> Maybe e
safeArrayIndex Int
i WidthTable
widths
widthsBetween :: Int -> Int -> Int
widthsBetween Int
start Int
end =
[Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ WidthTable -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems WidthTable
widths
showMarkers :: Int -> Int -> Doc Annotation
showMarkers Int
n Int
lineLen
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineLen = Doc Annotation
forall a. Monoid a => a
mempty
| Bool
otherwise =
let allMarkers :: [(Position, Marker msg)]
allMarkers = (((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)])
-> [(Position, Marker msg)]
-> ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Position, Marker msg) -> Bool)
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Position, Marker msg)]
ms \(Position (Int
_, Int
bc) (Int
_, Int
ec) String
_, Marker msg
mark) -> Marker msg
mark Marker msg -> Marker msg -> Bool
forall a. Eq a => a -> a -> Bool
/= Marker msg
forall msg. Marker msg
Blank Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ec
in
case [(Position, Marker msg)]
allMarkers of
[] -> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) Doc Annotation
forall ann. Doc ann
space) Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
showMarkers (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen
(Position {String
(Int, Int)
file :: String
end :: (Int, Int)
begin :: (Int, Int)
file :: Position -> String
end :: Position -> (Int, Int)
begin :: Position -> (Int, Int)
..}, Marker msg
marker) : [(Position, Marker msg)]
_ ->
Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate
(Bool -> Marker msg -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker msg
marker)
( if (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
begin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
then (if Bool
withUnicode then Doc Annotation
"┬" else Doc Annotation
"^") Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) if Bool
withUnicode then Doc Annotation
"─" else Doc Annotation
"-")
else [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Int -> Doc Annotation -> [Doc Annotation]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) if Bool
withUnicode then Doc Annotation
"─" else Doc Annotation
"-")
)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Doc Annotation
showMarkers (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
lineLen
showMessages :: Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
specialPrefix [(Position, Marker a)]
ms t
lineLen = case [(Position, Marker a)]
-> Maybe ((Position, Marker a), [(Position, Marker a)])
forall a. [a] -> Maybe (a, [a])
List.safeUncons [(Position, Marker a)]
ms of
Maybe ((Position, Marker a), [(Position, Marker a)])
Nothing -> Doc Annotation
forall a. Monoid a => a
mempty
Just ((Position b :: (Int, Int)
b@(Int
_, Int
bc) (Int, Int)
_ String
_, Marker a
msg), [(Position, Marker a)]
pipes) ->
let filteredPipes :: [(Position, Marker a)]
filteredPipes = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(&&) ((Bool, Bool) -> Bool)
-> ((Position, Marker a) -> (Bool, Bool))
-> (Position, Marker a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Bool)
-> (Marker a -> Bool) -> (Position, Marker a) -> (Bool, Bool)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, Int)
b) ((Int, Int) -> Bool)
-> (Position -> (Int, Int)) -> Position -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin) (Marker a -> Marker a -> Bool
forall a. Eq a => a -> a -> Bool
/= Marker a
forall msg. Marker msg
Blank)) [(Position, Marker a)]
pipes
nubbedPipes :: [(Position, Marker a)]
nubbedPipes = ((Position, Marker a) -> (Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> a -> Bool) -> [a] -> [a]
List.nubBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> (Position, Marker a)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst)) [(Position, Marker a)]
filteredPipes
allColumns :: Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns Int
_ [] = (b
1, [])
allColumns Int
n ms :: [(Position, Doc ann)]
ms@((Position (Int
_, Int
bc) (Int, Int)
_ String
_, Doc ann
col) : [(Position, Doc ann)]
ms')
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bc = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Doc ann
col Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms')
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bc = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Int -> Doc ann -> [Doc ann]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) Doc ann
forall ann. Doc ann
space [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms)
| Bool
otherwise = (b -> b)
-> ([Doc ann] -> [Doc ann]) -> (b, [Doc ann]) -> (b, [Doc ann])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (Int -> Doc ann -> [Doc ann]
forall a. Int -> a -> [a]
replicate (Int -> Int
widthAt Int
n) Doc ann
forall ann. Doc ann
space [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<>) (Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Position, Doc ann)]
ms')
hasSuccessor :: Bool
hasSuccessor = [(Position, Marker a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker a)]
filteredPipes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Position, Marker a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Position, Marker a)]
pipes
lineStart :: [(Position, Doc Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipes =
let (Int
n, [Doc Annotation]
docs) = Int -> [(Position, Doc Annotation)] -> (Int, [Doc Annotation])
forall {b} {ann}.
Num b =>
Int -> [(Position, Doc ann)] -> (b, [Doc ann])
allColumns Int
1 ([(Position, Doc Annotation)] -> (Int, [Doc Annotation]))
-> [(Position, Doc Annotation)] -> (Int, [Doc Annotation])
forall a b. (a -> b) -> a -> b
$ ((Position, Doc Annotation) -> Int)
-> [(Position, Doc Annotation)] -> [(Position, Doc Annotation)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Doc Annotation) -> (Int, Int))
-> (Position, Doc Annotation)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Doc Annotation) -> Position)
-> (Position, Doc Annotation)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Doc Annotation) -> Position
forall a b. (a, b) -> a
fst) [(Position, Doc Annotation)]
pipes
numberOfSpaces :: Int
numberOfSpaces = Int -> Int -> Int
widthsBetween Int
n Int
bc
in Int -> Bool -> Doc Annotation
dotPrefix Int
leftLen Bool
withUnicode Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
specialPrefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Doc Annotation]
docs Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> String -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
numberOfSpaces Char
' ')
prefix :: Doc Annotation
prefix =
let ([(Position, Marker a)]
pipesBefore, [(Position, Marker a)]
pipesAfter) = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)]
-> ([(Position, Marker a)], [(Position, Marker a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bc) (Int -> Bool)
-> ((Position, Marker a) -> Int) -> (Position, Marker a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
nubbedPipes
pipesBeforeRendered :: [(Position, Doc Annotation)]
pipesBeforeRendered = [(Position, Marker a)]
pipesBefore [(Position, Marker a)]
-> ((Position, Marker a) -> (Position, Doc Annotation))
-> [(Position, Doc Annotation)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Marker a -> Doc Annotation)
-> (Position, Marker a) -> (Position, Doc Annotation)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker a
marker -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
lastBeginPosition :: Maybe Int
lastBeginPosition = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst ((Position, Marker a) -> Int)
-> Maybe (Position, Marker a) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Position, Marker a)] -> Maybe (Position, Marker a)
forall a. [a] -> Maybe a
List.safeLast (((Position, Marker a) -> Int)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
pipesAfter)
lineLen :: Int
lineLen = case Maybe Int
lastBeginPosition of
Maybe Int
Nothing -> Int
0
Just Int
col -> Int -> Int -> Int
widthsBetween Int
bc Int
col
currentPipe :: Doc Annotation
currentPipe =
if
| Bool
withUnicode Bool -> Bool -> Bool
&& Bool
hasSuccessor -> Doc Annotation
"├"
| Bool
withUnicode -> Doc Annotation
"╰"
| Bool
hasSuccessor -> Doc Annotation
"|"
| Bool
otherwise -> Doc Annotation
"`"
lineChar :: Char
lineChar = if Bool
withUnicode then Char
'─' else Char
'-'
pointChar :: Doc Annotation
pointChar = if Bool
withUnicode then Doc Annotation
"╸" else Doc Annotation
"-"
bc' :: Int
bc' = Int
bc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
pipesBeforeMessageStart :: [(Position, Marker a)]
pipesBeforeMessageStart = ((Position, Marker a) -> Bool)
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. (a -> Bool) -> [a] -> [a]
List.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bc') (Int -> Bool)
-> ((Position, Marker a) -> Int) -> (Position, Marker a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((Position, Marker a) -> (Int, Int))
-> (Position, Marker a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> (Int, Int)
begin (Position -> (Int, Int))
-> ((Position, Marker a) -> Position)
-> (Position, Marker a)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, Marker a) -> Position
forall a b. (a, b) -> a
fst) [(Position, Marker a)]
pipesAfter
pipesBeforeMessageRendered :: [(Position, Doc Annotation)]
pipesBeforeMessageRendered = ([(Position, Marker a)]
pipesBefore [(Position, Marker a)]
-> [(Position, Marker a)] -> [(Position, Marker a)]
forall a. Semigroup a => a -> a -> a
<> [(Position, Marker a)]
pipesBeforeMessageStart) [(Position, Marker a)]
-> ((Position, Marker a) -> (Position, Doc Annotation))
-> [(Position, Doc Annotation)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Marker a -> Doc Annotation)
-> (Position, Marker a) -> (Position, Doc Annotation)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second \Marker a
marker -> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
marker) (if Bool
withUnicode then Doc Annotation
"│" else Doc Annotation
"|")
in
[(Position, Doc Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipesBeforeRendered
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
msg) (Doc Annotation
currentPipe Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> String -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
lineLen Char
lineChar) Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation
pointChar)
Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate (Bool -> Marker a -> Annotation
forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError Marker a
msg) (Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [(Position, Doc Annotation)] -> Doc Annotation
lineStart [(Position, Doc Annotation)]
pipesBeforeMessageRendered Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if [(Position, Marker a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [(Position, Marker a)]
pipesBeforeMessageStart then Doc Annotation
" " else Doc Annotation
" ") (Doc Annotation -> Doc Annotation)
-> Doc Annotation -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ a -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc Annotation) -> a -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Marker a -> a
forall msg. Marker msg -> msg
markerMessage Marker a
msg)
in Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> Doc Annotation -> [(Position, Marker a)] -> t -> Doc Annotation
showMessages Doc Annotation
specialPrefix [(Position, Marker a)]
pipes t
lineLen
replaceLinesWith :: Doc ann -> Doc ann -> Doc ann
replaceLinesWith :: forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
Line = Doc ann
repl
replaceLinesWith Doc ann
_ Doc ann
Fail = Doc ann
forall ann. Doc ann
Fail
replaceLinesWith Doc ann
_ Doc ann
Empty = Doc ann
forall ann. Doc ann
Empty
replaceLinesWith Doc ann
_ (Char Char
c) = Char -> Doc ann
forall ann. Char -> Doc ann
Char Char
c
replaceLinesWith Doc ann
repl (Text Int
_ Text
s) =
let lines :: [Doc ann]
lines = (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s [Text] -> (Text -> Doc ann) -> [Doc ann]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
txt -> Int -> Text -> Doc ann
forall ann. Int -> Text -> Doc ann
Text (Text -> Int
Text.length Text
txt) Text
txt
in [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse Doc ann
repl [Doc ann]
forall {ann}. [Doc ann]
lines)
replaceLinesWith Doc ann
repl (FlatAlt Doc ann
f Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
FlatAlt (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
f) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Cat Doc ann
c Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
Cat (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
c) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Nest Int
n Doc ann
d) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
Nest Int
n (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Union Doc ann
c Doc ann
d) = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
Union (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
c) (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
d)
replaceLinesWith Doc ann
repl (Column Int -> Doc ann
f) = (Int -> Doc ann) -> Doc ann
forall ann. (Int -> Doc ann) -> Doc ann
Column (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f)
replaceLinesWith Doc ann
repl (Nesting Int -> Doc ann
f) = (Int -> Doc ann) -> Doc ann
forall ann. (Int -> Doc ann) -> Doc ann
Nesting (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
f)
replaceLinesWith Doc ann
repl (Annotated ann
ann Doc ann
doc) = ann -> Doc ann -> Doc ann
forall ann. ann -> Doc ann -> Doc ann
Annotated ann
ann (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl Doc ann
doc)
replaceLinesWith Doc ann
repl (WithPageWidth PageWidth -> Doc ann
f) = (PageWidth -> Doc ann) -> Doc ann
forall ann. (PageWidth -> Doc ann) -> Doc ann
WithPageWidth (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith Doc ann
repl (Doc ann -> Doc ann)
-> (PageWidth -> Doc ann) -> PageWidth -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageWidth -> Doc ann
f)
markerColor ::
Bool ->
Marker msg ->
Annotation
markerColor :: forall msg. Bool -> Marker msg -> Annotation
markerColor Bool
isError (This msg
_) = Bool -> Annotation
ThisColor Bool
isError
markerColor Bool
_ (Where msg
_) = Annotation
WhereColor
markerColor Bool
_ (Maybe msg
_) = Annotation
MaybeColor
markerColor Bool
_ Marker msg
Blank = Annotation
CodeStyle
{-# INLINE markerColor #-}
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 = msg
forall a. HasCallStack => a
undefined
{-# INLINE markerMessage #-}
prettyAllHints :: Pretty msg => [Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints :: forall msg.
Pretty msg =>
[Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [] Int
_ Bool
_ = Doc Annotation
forall a. Monoid a => a
mempty
prettyAllHints (Note msg
h : [Note msg]
hs) Int
leftLen Bool
withUnicode =
let prefix :: Doc Annotation
prefix = Doc Annotation
forall ann. Doc ann
hardline Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Bool -> Doc Annotation
pipePrefix Int
leftLen Bool
withUnicode
in Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Annotation -> Doc Annotation -> Doc Annotation
forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
HintColor (Note msg -> Doc Annotation
forall {p} {msg}. IsString p => Note msg -> p
notePrefix Note msg
h Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
replaceLinesWith (Doc Annotation
prefix Doc Annotation -> Doc Annotation -> Doc Annotation
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Annotation
" ") (msg -> Doc Annotation
forall a ann. Pretty a => a -> Doc ann
pretty (msg -> Doc Annotation) -> msg -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ Note msg -> msg
forall {msg}. Note msg -> msg
noteMessage Note msg
h))
Doc Annotation -> Doc Annotation -> Doc Annotation
forall a. Semigroup a => a -> a -> a
<> [Note msg] -> Int -> Bool -> Doc Annotation
forall msg.
Pretty msg =>
[Note msg] -> Int -> Bool -> Doc Annotation
prettyAllHints [Note msg]
hs Int
leftLen Bool
withUnicode
where
notePrefix :: Note msg -> p
notePrefix (Note msg
_) = p
"Note:"
notePrefix (Hint msg
_) = p
"Hint:"
noteMessage :: Note 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
| (i, i) -> i -> Bool
forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (a i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
Array.bounds a i e
a) i
i = e -> Maybe e
forall a. a -> Maybe a
Just (a i e
a a i e -> i -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! i
i)
| Bool
otherwise = Maybe e
forall a. Maybe a
Nothing