errata-0.4.0.0: src/Errata/Internal/Render.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Module : Errata.Internal.Render
Copyright : (c) 2020- comp
License : MIT
Maintainer : onecomputer00@gmail.com
Stability : stable
Portability : portable
Functions for rendering the errors. You should not need to import this, as these functions are lower-level.
This module is internal, and may break across non-breaking versions.
-}
module Errata.Internal.Render
( renderErrors
, renderErrata
, renderBlock
, renderSourceLines
, groupBlockPointers
, slices
, makeSourceTable
) where
import Control.Applicative (ZipList (..))
import Control.Arrow ((&&&))
import qualified Data.IntMap as I
import Data.List (foldl', inits, sortOn)
import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB
import Errata.Source
import Errata.Types
#if defined(usewcwidth)
import Foreign.C
#endif
-- | Renders a collection of 'Errata'.
renderErrors :: Source source => source -> [Errata] -> TB.Builder
renderErrors source errs = errorMessage
where
-- The pointers grouped by line, for each Errata.
blockPointersGrouped = map (map groupBlockPointers . errataBlocks) errs
-- Min and max line numbers as defined by the pointers of each block, for each Errata.
minPointers = (map . map) (maybe 1 id . fmap fst . I.lookupMin) blockPointersGrouped
maxPointers = (map . map) (maybe 0 id . fmap fst . I.lookupMax) blockPointersGrouped
minLine = minimum (concat minPointers)
maxLine = maximum (concat maxPointers)
{- Optimization: we use a Patricia tree (IntMap) indexed by start line
into respective tail slices of the list of source lines @slines@.
If we were to use the list @slines@ as-is:
O(n) seeking per source block, O(n) traversal
Since, we would be linearly traversing to the start of each source block every
time with no caching for future source blocks at (or close to) the same starting
line as previous source blocks.
If we were to use an IntMap of source lines by itself:
Seeking becomes free, at the expense of O(n log n) traversal per source block
Since, we are performing an O(log n) average case Patricia lookup per line.
Whereas if we use a hybrid IntMap + association list approach:
O(n + log n) worst case, O(log n) average case, seeking per source block, O(n) traversal
Worse case is unevaluated slices, as this would force @slices@ evaluation, which is
an O(n) list traversal, on top of an O(log n) Patricia lookup. Partially-evaluated leafs will
have slightly better asymptotics, and fully-evaluated leafs will be O(log n) average case,
which is just the cost of a Patricia lookup.
For sufficiently large block counts with scattered pointers per block, which we assume
holds for real-world use cases, the traversal savings on repeat lookups will quickly favor
hybrid association list + IntMap asymptotics.
-}
srcTable = makeSourceTable minLine maxLine (sourceToLines source)
errataMessages = getZipList $ renderErrata srcTable
<$> ZipList errs
<*> ZipList blockPointersGrouped
<*> ZipList minPointers
<*> ZipList maxPointers
errorMessage = unsplit "\n\n" errataMessages
-- | Group the pointers of a block by the line they appear on.
groupBlockPointers :: Block -> I.IntMap [Pointer]
groupBlockPointers = I.fromListWith (<>) . map (\p -> (pointerLine p, pure p)) . blockPointers
-- | Create a source table from the given line span and source lines.
makeSourceTable :: Source a => Line -> Line -> [a] -> I.IntMap [a]
makeSourceTable minLine maxLine slines = I.fromDistinctAscList $
zip [minLine .. maxLine] (drop (minLine - 1) (slices slines))
{- | Turns a list into a list of tail slices of the original list, with each element at index @i@ dropping
the first @i@ elements of the original list and tailing an 'emptySource'.
This allows for correct behavior on out-of-source-bounds pointers.
-}
slices :: Source a => [a] -> [[a]]
slices [] = repeat (repeat emptySource)
slices xs = (xs <> repeat emptySource) : slices (tail xs)
-- | Renders a single 'Errata'.
renderErrata
:: Source source
=> I.IntMap [source] -- ^ The source table.
-> Errata -- ^ The 'Errata' to render.
-> [I.IntMap [Pointer]] -- ^ The pointers of each block grouped by line.
-> [Line] -- ^ The mininum line of each block.
-> [Line] -- ^ The maxinum line of each block.
-> TB.Builder
renderErrata srcTable (Errata {..}) blockPointersGrouped minPointers maxPointers = errorMessage
where
blockMessages = getZipList $ renderBlock srcTable
<$> ZipList errataBlocks
<*> ZipList blockPointersGrouped
<*> ZipList (zip minPointers maxPointers)
errorMessage = mconcat
[ TB.fromText $ maybe "" id errataHeader
, case blockMessages of
[] -> ""
xs -> case errataHeader of
Nothing -> unsplit "\n\n" xs
Just _ -> "\n" <> unsplit "\n\n" xs
, TB.fromText $ maybe "" ("\n" <>) errataBody
]
-- | Renders a single block.
renderBlock
:: Source source
=> I.IntMap [source] -- ^ The source table.
-> Block -- ^ The block to render.
-> I.IntMap [Pointer] -- ^ The pointers of this block grouped by line.
-> (Line, Line) -- ^ The mininum and maximum lines of this block.
-> TB.Builder
renderBlock srcTable block@(Block {..}) blockPointersGrouped ~(minBlockLine, maxBlockLine) = blockMessage
where
slines = zip [minBlockLine .. maxBlockLine] (maybe [] id $ I.lookup minBlockLine srcTable)
-- Padding size before the line prefix.
padding = length (show maxBlockLine)
blockMessage = mconcat
[ TB.fromText $ styleLocation blockStyle blockLocation
, TB.fromText $ maybe "" ("\n" <>) blockHeader
, maybe "" ("\n" <>) $ renderSourceLines slines block padding blockPointersGrouped
, TB.fromText $ maybe "" ("\n" <>) blockBody
]
-- | Renders the source lines for a block.
renderSourceLines
:: forall source
. Source source
=> [(Line, source)] -- ^ The source lines, from the minimum line to the maximum line for the block.
-> Block -- ^ The block to render.
-> Int -- ^ The length of the actual number of the maximum line.
-> I.IntMap [Pointer] -- ^ The pointers of this block grouped by line.
-> Maybe (TB.Builder)
renderSourceLines _ _ _ (I.null -> True) = Nothing
renderSourceLines slines (Block {..}) padding pointersGrouped = Just $ unsplit "\n" decoratedLines
where
{- Terminology used in this code:
↓↓ gutter
│ ← padding line
1 │ line 1 foo bar do
│ ┌────────^───────^^
│ │ │ ← connector
│ │ hook → └ hi ← label
2 │ │ line 2
3 │ │ line 3
│ ├──────^
4 │ │ line 4 ← extra line
5 │ │ line 5 ← extra line
. │ │ ← omission
7 │ │ line 7 ← extra line
8 │ │ line 8 baz end
│ └──────^─────^^^ ← underline
↑↑↑↑ ↑↑↑↑↑
prefix catch up
-}
Style {..} = blockStyle
-- Shows a line in accordance to the style.
-- We might get a line that's out-of-bounds, usually the EOF line, so we can default to empty.
showLine :: [(PointerStyle, (Column, Column))] -> source -> TB.Builder
showLine hs = TB.fromText . T.replace "\t" (T.replicate styleTabWidth " ") . styleLine hs . sourceToText
-- Generic prefix without line number, used for non-source lines i.e. decorations.
prefix :: TB.Builder
prefix = if styleEnableLinePrefix
then mconcat [replicateB padding " ", " ", TB.fromText styleLinePrefix, " "]
else ""
-- Prefix with a line number, used for source lines.
linePrefix :: Line -> TB.Builder
linePrefix n = if styleEnableLinePrefix
then mconcat [TB.fromText (styleNumber n), replicateB (padding - length (show n)) " ", " ", TB.fromText styleLinePrefix, " "]
else ""
-- The resulting source lines with decorations; extra prefix included for padding.
decoratedLines :: [TB.Builder]
decoratedLines = [paddingLine | stylePaddingTop] <> makeDecoratedLines 0 slines<> [paddingLine | stylePaddingBottom]
where
paddingLine = if styleEnableLinePrefix
then mconcat [replicateB padding " ", " ", TB.fromText styleLinePrefix]
else ""
-- Whether there will be a multiline span in the block.
hasConnMulti :: Bool
hasConnMulti = I.size (I.filter (any pointerConnect) pointersGrouped) > 1
-- Whether line /n/ has a connection to somewhere else (including the same line).
hasConn :: Line -> Bool
hasConn n = maybe False (any pointerConnect) $ I.lookup n pointersGrouped
-- Whether line /n/ has a connection to a line before or after it (but not including).
connAround :: Line -> (Bool, Bool)
connAround n =
let (a, b) = I.split n pointersGrouped
in ((any . any) pointerConnect a, (any . any) pointerConnect b)
-- Decorates all the pointed-to source lines, along with extra lines.
-- We have an @extra@ parameter to keep track of extra lines when spanning multiple lines.
makeDecoratedLines :: Line -> [(Line, source)] -> [TB.Builder]
-- No lines left.
makeDecoratedLines _ [] = []
-- The next line is a line we have to decorate with pointers.
makeDecoratedLines _ (pr@(n, _):ls)
| Just p <- I.lookup n pointersGrouped = decorateLine p pr <> makeDecoratedLines 0 ls
-- The next line is an extra line, within a limit.
makeDecoratedLines extra ((n, l):ls)
| extra < styleExtraLinesAfter =
let mid = if
| not styleEnableDecorations -> ""
| snd (connAround n) -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in (linePrefix n <> mid <> showLine [] l) : makeDecoratedLines (extra + 1) ls
-- We reached the extra line limit, so now there's some logic to figure out what's next.
makeDecoratedLines _ ls =
let (es, ls') = break ((`I.member` pointersGrouped) . fst) ls
in case (es, ls') of
-- There were no lines left to decorate anyways.
(_, []) -> []
-- There are lines left to decorate, and it came right after.
([], _) -> makeDecoratedLines 0 ls'
-- There are more than one line in between, so we take as much as is configured.
(_, _) ->
let es' = reverse . take styleExtraLinesBefore . reverse $ es
extras = flip map es' $ \(n, l) ->
let gutter = if
| not styleEnableDecorations -> ""
| snd (connAround n) -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in linePrefix n <> gutter <> showLine [] l
in case compareLength es' es of
-- We only add the omission line if it doesn't take all of the lines.
LT -> let
-- Prefix and gutter for omitting lines when spanning many lines.
omitPrefix = if styleEnableLinePrefix
then mconcat [TB.fromText styleEllipsis, replicateB (padding - 1) " ", " ", TB.fromText styleLinePrefix]
else ""
omitGutter = if
| not styleEnableDecorations -> ""
| snd . connAround . fst $ head ls -> " " <> TB.fromText styleVertical
| otherwise -> ""
in (omitPrefix <> omitGutter) : extras <> makeDecoratedLines 0 ls'
_ -> extras <> makeDecoratedLines 0 ls'
-- Decorate a line that has pointers.
-- The pointers we get are assumed to be all on the same line.
decorateLine :: [Pointer] -> (Line, source) -> [TB.Builder]
decorateLine pointers (n, l) = (linePrefix n <> gutter <> stylizedLine) : decorationLines
where
gutter = if
| not styleEnableDecorations -> ""
| hasConnBefore && hasConnUnder -> TB.fromText styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
-- Shortcuts to where this line connects to.
hasConnHere = hasConn n
(hasConnBefore, hasConnAfter) = connAround n
hasConnAround = hasConnBefore || hasConnAfter
hasConnOver = hasConnHere || hasConnBefore
hasConnUnder = hasConnHere || hasConnAfter
-- The sorted pointers by column.
pointersSorted = sortOn pointerColumns pointers
-- The actual source line.
sourceLine = sourceToText l
-- The source line stylized.
stylizedLine = showLine (map (pointerStyle &&& pointerColumns) pointersSorted) l
-- The resulting decoration lines.
decorationLines = case filter (isJust . pointerLabel) (init pointersSorted) of
_ | not styleEnableDecorations -> []
-- There's only one pointer, so no need for more than just an underline and label.
_ | length pointersSorted == 1 -> [underline pointersSorted]
-- There's no labels at all, so we just need the underline.
[] -> [underline pointersSorted]
-- Otherwise, we have three steps to do:
-- The underline directly underneath.
-- An extra connector for the labels other than the rightmost one.
-- The remaining connectors and the labels.
hasLabels -> underline pointersSorted
: connectors hasLabels
: (map connectorAndLabel . reverse . tail $ inits hasLabels)
-- Create an underline directly under the source. The last pointer can have a label on this line.
underline :: [Pointer] -> TB.Builder
underline ps =
let (decor, _) = foldDecorations
(\k isFirst rest text -> if
| isFirst && any pointerConnect rest && hasConnAround -> replaceWithWidth k styleTabWidth text styleHorizontal
| isFirst -> replaceWithWidth k styleTabWidth text " "
| any pointerConnect rest -> replaceWithWidth k styleTabWidth text styleHorizontal
| otherwise -> replaceWithWidth k styleTabWidth text " "
)
(\k p text ->
let x = styleUnderline (pointerStyle p)
in (k, replaceWithWidth k styleTabWidth text x)
)
ps
sourceLine
lbl = maybe "" (" " <>) . pointerLabel $ last ps
decorGutter = if
| hasConnHere && hasConnBefore && hasConnAfter -> styleUpDownRight <> styleHorizontal
| hasConnHere && hasConnBefore -> styleUpRight <> styleHorizontal
| hasConnHere && hasConnAfter -> styleDownRight <> styleHorizontal
| hasConnBefore && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText decorGutter <> decor <> TB.fromText lbl
-- Create connectors underneath. No labels are rendered here.
connectors :: [Pointer] -> TB.Builder
connectors ps =
let (decor, _) = foldDecorations
(\k _ _ text -> replaceWithWidth k styleTabWidth text " ")
(\_ p _ ->
let x = styleConnector (pointerStyle p)
in (1, TB.fromText x)
)
ps
sourceLine
decorGutter = if
| hasConnOver && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText decorGutter <> decor
-- Create connectors and labels underneath. The last pointer can have a label on this line.
connectorAndLabel :: [Pointer] -> TB.Builder
connectorAndLabel ps =
let (decor, finalCol) = foldDecorations
(\k _ _ text -> replaceWithWidth k styleTabWidth text " ")
(\_ p _ ->
let x = styleConnector (pointerStyle p)
in (1, TB.fromText x)
)
(init ps)
sourceLine
pointer = last ps
hook = styleHook (pointerStyle pointer)
lbl = maybe ""
(\x -> if
| styleEnableHook (pointerStyle pointer) -> mconcat
[ replicateB (pointerColStart pointer - finalCol) " "
, TB.fromText hook
, " "
, TB.fromText x
]
| otherwise -> mconcat
[ replicateB (pointerColStart pointer - finalCol) " "
, TB.fromText x
]
)
(pointerLabel pointer)
decorGutter = if
| hasConnOver && hasConnAfter -> styleVertical <> " "
| hasConnMulti -> " "
| otherwise -> ""
in prefix <> TB.fromText decorGutter <> decor <> lbl
-- | Makes a line of decorations below the source.
foldDecorations
:: (Int -> Bool -> [Pointer] -> T.Text -> TB.Builder)
{- ^ Catch up from the previous pointer to this pointer.
@catchUp distance isFirst pointers text@ should return text of at least length @distance@.
-}
-> (Int -> Pointer -> T.Text -> (Int, TB.Builder))
{- ^ Add text underneath the pointer before the next pointer.
@underlinePointer pointerLen pointer text@ should return the text and its length.
-}
-> [Pointer]
-> T.Text
-> (TB.Builder, Column)
foldDecorations catchUp underlinePointer ps line =
let (decor, finalCol, _, _) = paral
(\(rest, (xs, c, isFirst, remainingLine)) p@(Pointer {..}) ->
let (textBefore, textUnderAndRest) = T.splitAt (pointerColStart - c) remainingLine
(textUnder, textRest) = T.splitAt (pointerColEnd - pointerColStart) textUnderAndRest
(afterLen, afterText) = underlinePointer (pointerColEnd - pointerColStart) p textUnder
in
( mconcat
[ xs
, catchUp (pointerColStart - c) isFirst (p:rest) textBefore
, afterText
]
, pointerColStart + afterLen
, False
, textRest
)
)
("", 1, True, line)
ps
in (decor, finalCol)
-- | Paramorphism on lists (strictly, from the left).
paral :: (([a], b) -> a -> b) -> b -> [a] -> b
paral _ b [] = b
paral f b (a:as) =
let !b' = f (as, b) a
in paral f b' as
-- | Compares length of two lists without traversing them completely.
compareLength :: [a] -> [b] -> Ordering
compareLength [] [] = EQ
compareLength (_:xs) (_:ys) = compareLength xs ys
compareLength [] _ = LT
compareLength _ [] = GT
-- | Puts text between each item.
unsplit :: TB.Builder -> [TB.Builder] -> TB.Builder
unsplit _ [] = ""
unsplit a (x:xs) = foldl' (\acc y -> acc <> a <> y) x xs
{-# INLINE unsplit #-}
-- | Replicates text into a builder.
replicateB :: Int -> T.Text -> TB.Builder
replicateB n xs = TB.fromText (T.replicate n xs)
{-# INLINE replicateB #-}
{- | Replaces each character in the text with the appropriate instances of the given text based on character width.
The result will also be right-padded with the given text to the given length.
For tabs, the tab width given is used to make it equivalent to that many spaces.
-}
replaceWithWidth :: Int -> Int -> T.Text -> T.Text -> TB.Builder
replaceWithWidth len tab ref xs = T.foldl' (\acc c -> acc <> replicateB (width c) xs) "" ref <> replicateB (len - T.length ref) xs
where
width '\t' = tab
width c = charWidth c
{-# INLINE replaceWithWidth #-}
#if defined(usewcwidth)
foreign import ccall unsafe "wchar.h wcwidth" wcwidth :: CWchar -> CInt
{-| Get the designated render width of a character, based on the native wcwidth.
Where wcwidth would return -1, 0 is returned instead.
The result will depend on the current locale and Unicode version.
-}
charWidth :: Char -> Int
charWidth = max 0 . fromEnum . wcwidth . toEnum . fromEnum
#else
{-| Get the designated render width of a character: 0 for a combining character, 1 for a regular character,
2 for a wide character. (Wide characters are rendered as exactly double width in apps and fonts that support it.)
(From Pandoc.)
-}
charWidth :: Char -> Int
charWidth c = if
| c < '\x0300' -> 1
-- Combining
| c >= '\x0300' && c <= '\x036F' -> 0
| c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
-- Ambiguous
| c >= '\x3248' && c <= '\x324F' -> 1
| c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
-- Ambiguous
| c >= '\xE000' && c <= '\xF8FF' -> 1
| c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
-- Ambiguous
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
#endif