{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Errata.Internal.Render
( renderErrors
, renderErrata
, renderBlock
, renderSourceLines
) where
import Data.List
import qualified Data.List.NonEmpty as N
import qualified Data.Sequence as S
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.String (IsString)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB
import Errata.Source
import Errata.Types
renderErrors :: Source source => source -> [Errata] -> TB.Builder
renderErrors source errs = unsplit "\n\n" prettified
where
sortedErrata = sortOn (\(Errata {..}) -> blockLocation errataBlock) $ errs
slines = S.fromList (sourceToLines source)
prettified = map (renderErrata slines) sortedErrata
renderErrata :: Source source => S.Seq source -> Errata -> TB.Builder
renderErrata slines (Errata {..}) = errorMessage
where
errorMessage = mconcat
[ TB.fromText $ maybe "" (<> "\n") errataHeader
, unsplit "\n\n" (map (renderBlock slines) (errataBlock : errataBlocks))
, TB.fromText $ maybe "" ("\n\n" <>) errataBody
]
renderBlock :: Source source => S.Seq source -> Block -> TB.Builder
renderBlock slines block@(Block {..}) = blockMessage
where
blockMessage = mconcat
[ TB.fromText $ styleLocation blockStyle blockLocation
, maybe "" ("\n" <>) (renderSourceLines slines block <$> N.nonEmpty blockPointers)
, TB.fromText $ maybe "" ("\n" <>) blockBody
]
renderSourceLines
:: Source source
=> S.Seq source
-> Block
-> N.NonEmpty Pointer
-> TB.Builder
renderSourceLines slines (Block {..}) lspans = unsplit "\n" sourceLines
where
Style {..} = blockStyle
minLine = fst (M.findMin pointersGrouped)
maxLine = fst (M.findMax pointersGrouped)
padding = length (show maxLine)
showLine :: [(Int, Int)] -> Int -> TB.Builder
showLine hs n = TB.fromText . maybe "" id . fmap (styleLine hs . sourceToText) $ S.lookup (n - 1) slines
prefix = mconcat
[ replicateB padding " ", " ", TB.fromText styleLinePrefix, " "
]
omitPrefix = mconcat
[ TB.fromText styleEllipsis, replicateB (padding - 1) " ", " ", TB.fromText styleLinePrefix, " "
]
linePrefix :: Int -> TB.Builder
linePrefix n = mconcat
[ TB.fromText (styleNumber n), replicateB (padding - length (show n)) " ", " "
, TB.fromText styleLinePrefix, " "
]
pointersGrouped = M.fromListWith (<>) $ map (\x -> (pointerLine x, pure x)) (N.toList lspans)
sourceLines = mconcat [replicateB padding " ", " ", TB.fromText styleLinePrefix]
: makeSourceLines 0 [minLine .. maxLine]
hasConnMulti = M.size (M.filter (any pointerConnect) pointersGrouped) > 1
hasConn :: Int -> Bool
hasConn n = maybe False (any pointerConnect) $ M.lookup n pointersGrouped
connAround :: Int -> (Bool, Bool)
connAround n =
let (a, b) = M.split n pointersGrouped
in ((any . any) pointerConnect a, (any . any) pointerConnect b)
makeSourceLines :: Int -> [Int] -> [TB.Builder]
makeSourceLines _ [] = []
makeSourceLines _ (n:ns)
| Just p <- M.lookup n pointersGrouped = makeDecoratedLines p <> makeSourceLines 0 ns
makeSourceLines extra (n:ns)
| extra < 2 =
let mid = if
| snd (connAround n) -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in (linePrefix n <> mid <> showLine [] n) : makeSourceLines (extra + 1) ns
makeSourceLines _ ns =
let (es, ns') = break (`M.member` pointersGrouped) ns
in case (es, ns') of
(_, []) -> []
([], _) -> makeSourceLines 0 ns'
([n], _) ->
let mid = if
| snd (connAround n) -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in (linePrefix n <> mid <> showLine [] n) : makeSourceLines 0 ns'
(_, _) ->
let n = last es
mid = if
| snd (connAround n) -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in (omitPrefix <> mid) : (linePrefix n <> mid <> showLine [] n) : makeSourceLines 0 ns'
makeDecoratedLines :: N.NonEmpty Pointer -> [TB.Builder]
makeDecoratedLines pointers = (linePrefix line <> TB.fromText lineConnector <> sline) : decorationLines
where
lineConnector = if
| hasConnBefore && hasConnUnder -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
hasConnHere = hasConn line
(hasConnBefore, hasConnAfter) = connAround line
hasConnAround = hasConnBefore || hasConnAfter
hasConnOver = hasConnHere || hasConnBefore
hasConnUnder = hasConnHere || hasConnAfter
pointersSorted = N.fromList . sortOn pointerColumns $ N.toList pointers
pointersSorted' = N.reverse pointersSorted
line = pointerLine $ N.head pointers
sline = showLine (map pointerColumns (N.toList pointersSorted)) line
decorationLines = if
| N.length pointersSorted' == 1 -> [underline pointersSorted']
| all (isNothing . pointerLabel) (N.tail pointersSorted') -> [underline pointersSorted']
| otherwise ->
let hasLabels = filter (isJust . pointerLabel) $ N.tail pointersSorted'
in underline pointersSorted'
: connectors hasLabels
: parar (\a (rest, xs) -> connectorAndLabel rest a : xs) [] hasLabels
underline :: N.NonEmpty Pointer -> TB.Builder
underline ps =
let (decor, _) = foldDecorations
(\n isFirst rest -> if
| isFirst && any pointerConnect rest && hasConnAround -> replicateB n styleHorizontal
| isFirst -> replicateB n " "
| any pointerConnect rest -> replicateB n styleHorizontal
| otherwise -> replicateB n " "
)
""
(\n -> replicateB n styleUnderline)
(N.toList ps)
lbl = maybe "" (" " <>) . pointerLabel $ N.head ps
mid = if
| hasConnHere && hasConnBefore && hasConnAfter -> styleUpDownRight <> styleHorizontal
| hasConnHere && hasConnBefore -> styleUpRight <> styleHorizontal
| hasConnHere && hasConnAfter -> styleDownRight <> styleHorizontal
| hasConnBefore && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText mid <> decor <> TB.fromText lbl
connectors :: [Pointer] -> TB.Builder
connectors ps =
let (decor, _) = foldDecorations
(\n _ _ -> replicateB n " ")
(TB.fromText styleVertical)
(\n -> replicateB (n - 1) " ")
ps
mid = if
| hasConnOver && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText mid <> decor
connectorAndLabel :: [Pointer] -> Pointer -> TB.Builder
connectorAndLabel ps p =
let (decor, finalCol) = foldDecorations
(\n _ _ -> replicateB n " ")
(TB.fromText styleVertical)
(\n -> replicateB (n - 1) " ")
ps
lbl = maybe ""
(\x -> mconcat
[ replicateB (pointerColStart p - finalCol) " "
, TB.fromText styleUpRight
, " "
, TB.fromText x
]
)
(pointerLabel p)
mid = if
| hasConnOver && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText mid <> decor <> lbl
foldDecorations
:: (Int -> Bool -> [Pointer] -> TB.Builder)
-> TB.Builder
-> (Int -> TB.Builder)
-> [Pointer]
-> (TB.Builder, Int)
foldDecorations catchUp something reachAfter ps =
let (decor, finalCol, _, _) = foldr
(\(Pointer {..}) (xs, c, rest, isFirst) ->
( mconcat
[ xs
, catchUp (pointerColStart - c) isFirst rest
, something
, reachAfter (pointerColEnd - pointerColStart)
]
, pointerColEnd
, tail rest
, False
)
)
("", 1, reverse ps, True)
ps
in (decor, finalCol)
parar :: (a -> ([a], b) -> b) -> b -> [a] -> b
parar _ b [] = b
parar f b (a:as) = f a (as, parar f b as)
unsplit :: (Semigroup a, IsString a) => a -> [a] -> a
unsplit _ [] = ""
unsplit a (x:xs) = foldl' (\acc y -> acc <> a <> y) x xs
replicateB :: Int -> T.Text -> TB.Builder
replicateB n = TB.fromText . T.replicate n