{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-|
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
    ) where

import qualified GHC.Arr as A
import           Data.List
import qualified Data.List.NonEmpty as N
import qualified Data.Map.Strict as M
import           Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB
import           Errata.Source
import           Errata.Types

-- | Renders errors.
renderErrors :: Source source => source -> [Errata] -> TB.Builder
renderErrors :: source -> [Errata] -> Builder
renderErrors source :: source
source errs :: [Errata]
errs = Builder -> [Builder] -> Builder
unsplit "\n\n" [Builder]
prettified
    where
        sortedErrata :: [Errata]
sortedErrata = (Errata -> (FilePath, Line, Line)) -> [Errata] -> [Errata]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Block -> (FilePath, Line, Line)
blockLocation (Block -> (FilePath, Line, Line))
-> (Errata -> Block) -> Errata -> (FilePath, Line, Line)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errata -> Block
errataBlock) [Errata]
errs
        slines :: Array Line source
slines = let xs :: [source]
xs = source -> [source]
forall s. Source s => s -> [s]
sourceToLines source
source in (Line, Line) -> [source] -> Array Line source
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (0, [source] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [source]
xs Line -> Line -> Line
forall a. Num a => a -> a -> a
- 1) [source]
xs
        prettified :: [Builder]
prettified = (Errata -> Builder) -> [Errata] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Array Line source -> Errata -> Builder
forall source.
Source source =>
Array Line source -> Errata -> Builder
renderErrata Array Line source
slines) [Errata]
sortedErrata

-- | A single pretty error from metadata and source lines.
renderErrata :: Source source => A.Array Int source -> Errata -> TB.Builder
renderErrata :: Array Line source -> Errata -> Builder
renderErrata slines :: Array Line source
slines (Errata {..}) = Builder
errorMessage
    where
        errorMessage :: Builder
errorMessage = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Body -> Builder
TB.fromText (Body -> Builder) -> Body -> Builder
forall a b. (a -> b) -> a -> b
$ Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> "\n") Maybe Body
errataHeader
            , Builder -> [Builder] -> Builder
unsplit "\n\n" ((Block -> Builder) -> [Block] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Array Line source -> Block -> Builder
forall source.
Source source =>
Array Line source -> Block -> Builder
renderBlock Array Line source
slines) (Block
errataBlock Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
errataBlocks))
            , Body -> Builder
TB.fromText (Body -> Builder) -> Body -> Builder
forall a b. (a -> b) -> a -> b
$ Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ("\n\n" Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) Maybe Body
errataBody
            ]

-- | A single pretty block from block data and source lines.
renderBlock :: Source source => A.Array Int source -> Block -> TB.Builder
renderBlock :: Array Line source -> Block -> Builder
renderBlock slines :: Array Line source
slines block :: Block
block@(Block {..}) = Builder
blockMessage
    where
        blockMessage :: Builder
blockMessage = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Body -> Builder
TB.fromText (Body -> Builder) -> Body -> Builder
forall a b. (a -> b) -> a -> b
$ Style -> (FilePath, Line, Line) -> Body
styleLocation Style
blockStyle (FilePath, Line, Line)
blockLocation
            , Body -> Builder
TB.fromText (Body -> Builder) -> Body -> Builder
forall a b. (a -> b) -> a -> b
$ Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ("\n" Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) Maybe Body
blockHeader
            , Builder -> (Builder -> Builder) -> Maybe Builder -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ("\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Array Line source -> Block -> NonEmpty Pointer -> Builder
forall source.
Source source =>
Array Line source -> Block -> NonEmpty Pointer -> Builder
renderSourceLines Array Line source
slines Block
block (NonEmpty Pointer -> Builder)
-> Maybe (NonEmpty Pointer) -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pointer] -> Maybe (NonEmpty Pointer)
forall a. [a] -> Maybe (NonEmpty a)
N.nonEmpty [Pointer]
blockPointers)
            , Body -> Builder
TB.fromText (Body -> Builder) -> Body -> Builder
forall a b. (a -> b) -> a -> b
$ Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ("\n" Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) Maybe Body
blockBody
            ]

-- | The source lines for a block.
renderSourceLines
    :: Source source
    => A.Array Int source
    -> Block
    -> N.NonEmpty Pointer
    -> TB.Builder
renderSourceLines :: Array Line source -> Block -> NonEmpty Pointer -> Builder
renderSourceLines slines :: Array Line source
slines (Block {..}) lspans :: NonEmpty Pointer
lspans = Builder -> [Builder] -> Builder
unsplit "\n" [Builder]
sourceLines
    where
        Style {..} = Style
blockStyle

        -- Min and max line numbers, as well padding size before the line prefix.
        minLine :: Line
minLine = (Line, NonEmpty Pointer) -> Line
forall a b. (a, b) -> a
fst (Map Line (NonEmpty Pointer) -> (Line, NonEmpty Pointer)
forall k a. Map k a -> (k, a)
M.findMin Map Line (NonEmpty Pointer)
pointersGrouped)
        maxLine :: Line
maxLine = (Line, NonEmpty Pointer) -> Line
forall a b. (a, b) -> a
fst (Map Line (NonEmpty Pointer) -> (Line, NonEmpty Pointer)
forall k a. Map k a -> (k, a)
M.findMax Map Line (NonEmpty Pointer)
pointersGrouped)
        padding :: Line
padding = FilePath -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length (Line -> FilePath
forall a. Show a => a -> FilePath
show Line
maxLine)

        -- 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 :: [(Column, Column)] -> Line -> TB.Builder
        showLine :: [(Line, Line)] -> Line -> Builder
showLine hs :: [(Line, Line)]
hs n :: Line
n = Body -> Builder
TB.fromText (Body -> Builder)
-> (Maybe source -> Body) -> Maybe source -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" Body -> Body
forall a. a -> a
id (Maybe Body -> Body)
-> (Maybe source -> Maybe Body) -> Maybe source -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (source -> Body) -> Maybe source -> Maybe Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Line, Line)] -> Body -> Body
styleLine [(Line, Line)]
hs (Body -> Body) -> (source -> Body) -> source -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. source -> Body
forall s. Source s => s -> Body
sourceToText) (Maybe source -> Builder) -> Maybe source -> Builder
forall a b. (a -> b) -> a -> b
$ Array Line source -> Line -> Maybe source
forall s. Array Line s -> Line -> Maybe s
indexLines Array Line source
slines (Line
n Line -> Line -> Line
forall a. Num a => a -> a -> a
- 1)

        -- Generic prefix without line number.
        prefix :: Builder
prefix = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Line -> Body -> Builder
replicateB Line
padding " ", " ", Body -> Builder
TB.fromText Body
styleLinePrefix, " "
            ]

        -- Prefix for omitting lines when spanning many lines.
        omitPrefix :: Builder
omitPrefix = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Body -> Builder
TB.fromText Body
styleEllipsis, Line -> Body -> Builder
replicateB (Line
padding Line -> Line -> Line
forall a. Num a => a -> a -> a
- 1) " ", " ", Body -> Builder
TB.fromText Body
styleLinePrefix, " "
            ]

        -- Prefix with a line number.
        linePrefix :: Line -> TB.Builder
        linePrefix :: Line -> Builder
linePrefix n :: Line
n = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Body -> Builder
TB.fromText (Line -> Body
styleNumber Line
n), Line -> Body -> Builder
replicateB (Line
padding Line -> Line -> Line
forall a. Num a => a -> a -> a
- FilePath -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length (Line -> FilePath
forall a. Show a => a -> FilePath
show Line
n)) " ", " "
            , Body -> Builder
TB.fromText Body
styleLinePrefix, " "
            ]

        -- The pointers grouped by line.
        pointersGrouped :: Map Line (NonEmpty Pointer)
pointersGrouped = (NonEmpty Pointer -> NonEmpty Pointer -> NonEmpty Pointer)
-> [(Line, NonEmpty Pointer)] -> Map Line (NonEmpty Pointer)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith NonEmpty Pointer -> NonEmpty Pointer -> NonEmpty Pointer
forall a. Semigroup a => a -> a -> a
(<>) ([(Line, NonEmpty Pointer)] -> Map Line (NonEmpty Pointer))
-> [(Line, NonEmpty Pointer)] -> Map Line (NonEmpty Pointer)
forall a b. (a -> b) -> a -> b
$ (Pointer -> (Line, NonEmpty Pointer))
-> [Pointer] -> [(Line, NonEmpty Pointer)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Pointer
x -> (Pointer -> Line
pointerLine Pointer
x, Pointer -> NonEmpty Pointer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pointer
x)) (NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.toList NonEmpty Pointer
lspans)

        -- The resulting source lines.
        -- Extra prefix for padding.
        sourceLines :: [Builder]
sourceLines = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Line -> Body -> Builder
replicateB Line
padding " ", " ", Body -> Builder
TB.fromText Body
styleLinePrefix]
            Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Line -> [Line] -> [Builder]
makeSourceLines 0 [Line
minLine .. Line
maxLine]

        -- Whether there will be a multiline span.
        hasConnMulti :: Bool
hasConnMulti = Map Line (NonEmpty Pointer) -> Line
forall k a. Map k a -> Line
M.size ((NonEmpty Pointer -> Bool)
-> Map Line (NonEmpty Pointer) -> Map Line (NonEmpty Pointer)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Pointer -> Bool) -> NonEmpty Pointer -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect) Map Line (NonEmpty Pointer)
pointersGrouped) Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
> 1

        -- Whether line /n/ has a connection to somewhere else (including the same line).
        hasConn :: Line -> Bool
        hasConn :: Line -> Bool
hasConn n :: Line
n = Bool
-> (NonEmpty Pointer -> Bool) -> Maybe (NonEmpty Pointer) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Pointer -> Bool) -> NonEmpty Pointer -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect) (Maybe (NonEmpty Pointer) -> Bool)
-> Maybe (NonEmpty Pointer) -> Bool
forall a b. (a -> b) -> a -> b
$ Line -> Map Line (NonEmpty Pointer) -> Maybe (NonEmpty Pointer)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Line
n Map Line (NonEmpty Pointer)
pointersGrouped

        -- Whether line /n/ has a connection to a line before or after it (but not including).
        connAround :: Line -> (Bool, Bool)
        connAround :: Line -> (Bool, Bool)
connAround n :: Line
n =
            let (a :: Map Line (NonEmpty Pointer)
a, b :: Map Line (NonEmpty Pointer)
b) = Line
-> Map Line (NonEmpty Pointer)
-> (Map Line (NonEmpty Pointer), Map Line (NonEmpty Pointer))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split Line
n Map Line (NonEmpty Pointer)
pointersGrouped
            in (((NonEmpty Pointer -> Bool) -> Map Line (NonEmpty Pointer) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NonEmpty Pointer -> Bool) -> Map Line (NonEmpty Pointer) -> Bool)
-> ((Pointer -> Bool) -> NonEmpty Pointer -> Bool)
-> (Pointer -> Bool)
-> Map Line (NonEmpty Pointer)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> Bool) -> NonEmpty Pointer -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any) Pointer -> Bool
pointerConnect Map Line (NonEmpty Pointer)
a, ((NonEmpty Pointer -> Bool) -> Map Line (NonEmpty Pointer) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NonEmpty Pointer -> Bool) -> Map Line (NonEmpty Pointer) -> Bool)
-> ((Pointer -> Bool) -> NonEmpty Pointer -> Bool)
-> (Pointer -> Bool)
-> Map Line (NonEmpty Pointer)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> Bool) -> NonEmpty Pointer -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any) Pointer -> Bool
pointerConnect Map Line (NonEmpty Pointer)
b)

        -- Makes the source lines.
        -- We have an @extra@ parameter to keep track of extra lines when spanning multiple lines.
        makeSourceLines :: Line -> [Line] -> [TB.Builder]

        -- No lines left.
        makeSourceLines :: Line -> [Line] -> [Builder]
makeSourceLines _ [] = []

        -- The next line is a line we have to decorate with pointers.
        makeSourceLines _ (n :: Line
n:ns :: [Line]
ns)
            | Just p :: NonEmpty Pointer
p <- Line -> Map Line (NonEmpty Pointer) -> Maybe (NonEmpty Pointer)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Line
n Map Line (NonEmpty Pointer)
pointersGrouped = NonEmpty Pointer -> [Builder]
makeDecoratedLines NonEmpty Pointer
p [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Line -> [Line] -> [Builder]
makeSourceLines 0 [Line]
ns

        -- The next line is an extra line, within a limit (currently 2, may be configurable later).
        makeSourceLines extra :: Line
extra (n :: Line
n:ns :: [Line]
ns)
            | Line
extra Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
< 2 =
                let mid :: Builder
mid = if
                        | (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Line -> (Bool, Bool)
connAround Line
n) -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> " "
                        | Bool
hasConnMulti       -> "  "
                        | Bool
otherwise          -> ""
                in (Line -> Builder
linePrefix Line
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Line, Line)] -> Line -> Builder
showLine [] Line
n) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Line -> [Line] -> [Builder]
makeSourceLines (Line
extra Line -> Line -> Line
forall a. Num a => a -> a -> a
+ 1) [Line]
ns

        -- We reached the extra line limit, so now there's some logic to figure out what's next.
        makeSourceLines _ ns :: [Line]
ns =
            let (es :: [Line]
es, ns' :: [Line]
ns') = (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Line -> Map Line (NonEmpty Pointer) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Line (NonEmpty Pointer)
pointersGrouped) [Line]
ns
            in case ([Line]
es, [Line]
ns') of
                -- There were no lines left to decorate anyways.
                (_, []) -> []

                -- There are lines left to decorate, and it came right after.
                ([], _) -> Line -> [Line] -> [Builder]
makeSourceLines 0 [Line]
ns'

                -- There is a single extra line, so we can use that as the before-line.
                -- No need for omission, because it came right before.
                ([n :: Line
n], _) ->
                    let mid :: Builder
mid = if
                            | (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Line -> (Bool, Bool)
connAround Line
n) -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> " "
                            | Bool
hasConnMulti       -> "  "
                            | Bool
otherwise          -> ""
                    in (Line -> Builder
linePrefix Line
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Line, Line)] -> Line -> Builder
showLine [] Line
n) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Line -> [Line] -> [Builder]
makeSourceLines 0 [Line]
ns'

                -- There are more than one line in between, so we omit all but the last.
                -- We use the last one as the before-line.
                (_, _) ->
                    let n :: Line
n = [Line] -> Line
forall a. [a] -> a
last [Line]
es
                        mid :: Builder
mid = if
                            | (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Line -> (Bool, Bool)
connAround Line
n) -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> " "
                            | Bool
hasConnMulti       -> "  "
                            | Bool
otherwise          -> ""
                    in (Builder
omitPrefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (Line -> Builder
linePrefix Line
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Line, Line)] -> Line -> Builder
showLine [] Line
n) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Line -> [Line] -> [Builder]
makeSourceLines 0 [Line]
ns'

        -- Decorate a line that has pointers.
        -- The pointers we get are assumed to be all on the same line.
        makeDecoratedLines :: N.NonEmpty Pointer -> [TB.Builder]
        makeDecoratedLines :: NonEmpty Pointer -> [Builder]
makeDecoratedLines pointers :: NonEmpty Pointer
pointers = (Line -> Builder
linePrefix Line
line Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
lineConnector Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sline) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
decorationLines
            where
                lineConnector :: Body
lineConnector = if
                    | Bool
hasConnBefore Bool -> Bool -> Bool
&& Bool
hasConnUnder -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> " "
                    | Bool
hasConnMulti                  -> "  "
                    | Bool
otherwise                     -> ""

                -- Shortcuts to where this line connects to.
                hasConnHere :: Bool
hasConnHere = Line -> Bool
hasConn Line
line
                (hasConnBefore :: Bool
hasConnBefore, hasConnAfter :: Bool
hasConnAfter) = Line -> (Bool, Bool)
connAround Line
line
                hasConnAround :: Bool
hasConnAround = Bool
hasConnBefore Bool -> Bool -> Bool
|| Bool
hasConnAfter
                hasConnOver :: Bool
hasConnOver = Bool
hasConnHere Bool -> Bool -> Bool
|| Bool
hasConnBefore
                hasConnUnder :: Bool
hasConnUnder = Bool
hasConnHere Bool -> Bool -> Bool
|| Bool
hasConnAfter

                -- The sorted pointers by column.
                -- There's a reverse for when we create decorations.
                pointersSorted :: NonEmpty Pointer
pointersSorted = [Pointer] -> NonEmpty Pointer
forall a. [a] -> NonEmpty a
N.fromList ([Pointer] -> NonEmpty Pointer)
-> ([Pointer] -> [Pointer]) -> [Pointer] -> NonEmpty Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> (Line, Line)) -> [Pointer] -> [Pointer]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Pointer -> (Line, Line)
pointerColumns ([Pointer] -> NonEmpty Pointer) -> [Pointer] -> NonEmpty Pointer
forall a b. (a -> b) -> a -> b
$ NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.toList NonEmpty Pointer
pointers
                pointersSorted' :: NonEmpty Pointer
pointersSorted' = NonEmpty Pointer -> NonEmpty Pointer
forall a. NonEmpty a -> NonEmpty a
N.reverse NonEmpty Pointer
pointersSorted

                -- The line we're on.
                line :: Line
line = Pointer -> Line
pointerLine (Pointer -> Line) -> Pointer -> Line
forall a b. (a -> b) -> a -> b
$ NonEmpty Pointer -> Pointer
forall a. NonEmpty a -> a
N.head NonEmpty Pointer
pointers
                sline :: Builder
sline = [(Line, Line)] -> Line -> Builder
showLine ((Pointer -> (Line, Line)) -> [Pointer] -> [(Line, Line)]
forall a b. (a -> b) -> [a] -> [b]
map Pointer -> (Line, Line)
pointerColumns (NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.toList NonEmpty Pointer
pointersSorted)) Line
line

                -- The resulting decoration lines.
                decorationLines :: [Builder]
decorationLines = if
                    -- There's only one pointer, so no need for more than just an underline and label.
                    | NonEmpty Pointer -> Line
forall a. NonEmpty a -> Line
N.length NonEmpty Pointer
pointersSorted' Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== 1                           -> [NonEmpty Pointer -> Builder
underline NonEmpty Pointer
pointersSorted']

                    -- There's no labels at all, so we just need the underline.
                    | (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Body -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Body -> Bool) -> (Pointer -> Maybe Body) -> Pointer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Maybe Body
pointerLabel) (NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.tail NonEmpty Pointer
pointersSorted') -> [NonEmpty Pointer -> Builder
underline NonEmpty Pointer
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.
                    | Bool
otherwise ->
                        let hasLabels :: [Pointer]
hasLabels = (Pointer -> Bool) -> [Pointer] -> [Pointer]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Body -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Body -> Bool) -> (Pointer -> Maybe Body) -> Pointer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Maybe Body
pointerLabel) ([Pointer] -> [Pointer]) -> [Pointer] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.tail NonEmpty Pointer
pointersSorted'
                        in NonEmpty Pointer -> Builder
underline NonEmpty Pointer
pointersSorted'
                            Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Pointer] -> Builder
connectors [Pointer]
hasLabels
                            Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (Pointer -> ([Pointer], [Builder]) -> [Builder])
-> [Builder] -> [Pointer] -> [Builder]
forall a b. (a -> ([a], b) -> b) -> b -> [a] -> b
parar (\a :: Pointer
a (rest :: [Pointer]
rest, xs :: [Builder]
xs) -> [Pointer] -> Pointer -> Builder
connectorAndLabel [Pointer]
rest Pointer
a Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
xs) [] [Pointer]
hasLabels

                -- Create an underline directly under the source.
                underline :: N.NonEmpty Pointer -> TB.Builder
                underline :: NonEmpty Pointer -> Builder
underline ps :: NonEmpty Pointer
ps =
                    let (decor :: Builder
decor, _) = (Line -> Bool -> [Pointer] -> Builder)
-> Builder -> (Line -> Builder) -> [Pointer] -> (Builder, Line)
foldDecorations
                            (\n :: Line
n isFirst :: Bool
isFirst rest :: [Pointer]
rest -> if
                                | Bool
isFirst Bool -> Bool -> Bool
&& (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect [Pointer]
rest Bool -> Bool -> Bool
&& Bool
hasConnAround -> Line -> Body -> Builder
replicateB Line
n Body
styleHorizontal
                                | Bool
isFirst                                             -> Line -> Body -> Builder
replicateB Line
n " "
                                | (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect [Pointer]
rest                             -> Line -> Body -> Builder
replicateB Line
n Body
styleHorizontal
                                | Bool
otherwise                                           -> Line -> Body -> Builder
replicateB Line
n " "
                            )
                            ""
                            (\n :: Line
n -> Line -> Body -> Builder
replicateB Line
n Body
styleUnderline)
                            (NonEmpty Pointer -> [Pointer]
forall a. NonEmpty a -> [a]
N.toList NonEmpty Pointer
ps)
                        lbl :: Body
lbl = Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (" " Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) (Maybe Body -> Body) -> (Pointer -> Maybe Body) -> Pointer -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Maybe Body
pointerLabel (Pointer -> Body) -> Pointer -> Body
forall a b. (a -> b) -> a -> b
$ NonEmpty Pointer -> Pointer
forall a. NonEmpty a -> a
N.head NonEmpty Pointer
ps
                        mid :: Body
mid = if
                            | Bool
hasConnHere Bool -> Bool -> Bool
&& Bool
hasConnBefore Bool -> Bool -> Bool
&& Bool
hasConnAfter -> Body
styleUpDownRight Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> Body
styleHorizontal
                            | Bool
hasConnHere Bool -> Bool -> Bool
&& Bool
hasConnBefore                 -> Body
styleUpRight Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> Body
styleHorizontal
                            | Bool
hasConnHere Bool -> Bool -> Bool
&& Bool
hasConnAfter                  -> Body
styleDownRight Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> Body
styleHorizontal
                            | Bool
hasConnBefore Bool -> Bool -> Bool
&& Bool
hasConnAfter                -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> " "
                            | Bool
hasConnMulti                                 -> "  "
                            | Bool
otherwise -> ""
                    in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
decor Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
lbl

                -- Create connectors underneath.
                -- It's assumed all these pointers have labels.
                connectors :: [Pointer] -> TB.Builder
                connectors :: [Pointer] -> Builder
connectors ps :: [Pointer]
ps =
                    let (decor :: Builder
decor, _) = (Line -> Bool -> [Pointer] -> Builder)
-> Builder -> (Line -> Builder) -> [Pointer] -> (Builder, Line)
foldDecorations
                            (\n :: Line
n _ _ -> Line -> Body -> Builder
replicateB Line
n " ")
                            (Body -> Builder
TB.fromText Body
styleVertical)
                            (\n :: Line
n -> Line -> Body -> Builder
replicateB (Line
n Line -> Line -> Line
forall a. Num a => a -> a -> a
- 1) " ")
                            [Pointer]
ps
                        mid :: Body
mid = if
                            | Bool
hasConnOver Bool -> Bool -> Bool
&& Bool
hasConnAfter -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> " "
                            | Bool
hasConnMulti                -> "  "
                            | Bool
otherwise                   -> ""
                    in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
decor

                -- Create connectors and labels underneath.
                -- It's assumed all these pointers have labels.
                -- The single pointer passed in is the label to make at the end of the decorations.
                connectorAndLabel :: [Pointer] -> Pointer -> TB.Builder
                connectorAndLabel :: [Pointer] -> Pointer -> Builder
connectorAndLabel ps :: [Pointer]
ps p :: Pointer
p =
                    let (decor :: Builder
decor, finalCol :: Line
finalCol) = (Line -> Bool -> [Pointer] -> Builder)
-> Builder -> (Line -> Builder) -> [Pointer] -> (Builder, Line)
foldDecorations
                            (\n :: Line
n _ _ -> Line -> Body -> Builder
replicateB Line
n " ")
                            (Body -> Builder
TB.fromText Body
styleVertical)
                            (\n :: Line
n -> Line -> Body -> Builder
replicateB (Line
n Line -> Line -> Line
forall a. Num a => a -> a -> a
- 1) " ")
                            [Pointer]
ps
                        lbl :: Builder
lbl = Builder -> (Body -> Builder) -> Maybe Body -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ""
                            (\x :: Body
x -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
                                [ Line -> Body -> Builder
replicateB (Pointer -> Line
pointerColStart Pointer
p Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
finalCol) " "
                                , Body -> Builder
TB.fromText Body
styleUpRight
                                , " "
                                , Body -> Builder
TB.fromText Body
x
                                ]
                            )
                            (Pointer -> Maybe Body
pointerLabel Pointer
p)
                        mid :: Body
mid = if
                            | Bool
hasConnOver Bool -> Bool -> Bool
&& Bool
hasConnAfter -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> " "
                            | Bool
hasConnMulti                -> "  "
                            | Bool
otherwise                   -> ""
                    in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
decor Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lbl

-- | Makes a line of decorations below the source.
foldDecorations
    :: (Column -> Bool -> [Pointer] -> TB.Builder) -- ^ Catch up from the previous pointer to this pointer.
    -> TB.Builder                                  -- ^ Something in the middle.
    -> (Column -> TB.Builder)                      -- ^ Reach the next pointer.
    -> [Pointer]
    -> (TB.Builder, Column)
foldDecorations :: (Line -> Bool -> [Pointer] -> Builder)
-> Builder -> (Line -> Builder) -> [Pointer] -> (Builder, Line)
foldDecorations catchUp :: Line -> Bool -> [Pointer] -> Builder
catchUp something :: Builder
something reachAfter :: Line -> Builder
reachAfter ps :: [Pointer]
ps =
    let (decor :: Builder
decor, finalCol :: Line
finalCol, _, _) = (Pointer
 -> (Builder, Line, [Pointer], Bool)
 -> (Builder, Line, [Pointer], Bool))
-> (Builder, Line, [Pointer], Bool)
-> [Pointer]
-> (Builder, Line, [Pointer], Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\(Pointer {..}) (xs :: Builder
xs, c :: Line
c, rest :: [Pointer]
rest, isFirst :: Bool
isFirst) ->
                ( [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
                    [ Builder
xs
                    , Line -> Bool -> [Pointer] -> Builder
catchUp (Line
pointerColStart Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
c) Bool
isFirst [Pointer]
rest
                    , Builder
something
                    , Line -> Builder
reachAfter (Line
pointerColEnd Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
pointerColStart)
                    ]
                , Line
pointerColEnd
                , [Pointer] -> [Pointer]
forall a. [a] -> [a]
tail [Pointer]
rest
                , Bool
False
                )
            )
            ("", 1, [Pointer] -> [Pointer]
forall a. [a] -> [a]
reverse [Pointer]
ps, Bool
True)
            [Pointer]
ps
    in (Builder
decor, Line
finalCol)

-- | Paramorphism on lists (lazily, from the right).
parar :: (a -> ([a], b) -> b) -> b -> [a] -> b
parar :: (a -> ([a], b) -> b) -> b -> [a] -> b
parar _ b :: b
b []     = b
b
parar f :: a -> ([a], b) -> b
f b :: b
b (a :: a
a:as :: [a]
as) = a -> ([a], b) -> b
f a
a ([a]
as, (a -> ([a], b) -> b) -> b -> [a] -> b
forall a b. (a -> ([a], b) -> b) -> b -> [a] -> b
parar a -> ([a], b) -> b
f b
b [a]
as)

-- | Puts text between each item.
unsplit :: TB.Builder -> [TB.Builder] -> TB.Builder
unsplit :: Builder -> [Builder] -> Builder
unsplit _ [] = ""
unsplit a :: Builder
a (x :: Builder
x:xs :: [Builder]
xs) = (Builder -> Builder -> Builder) -> Builder -> [Builder] -> Builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\acc :: Builder
acc y :: Builder
y -> Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
y) Builder
x [Builder]
xs
{-# INLINE unsplit #-}

-- | Replicates text into a builder.
replicateB :: Int -> T.Text -> TB.Builder
replicateB :: Line -> Body -> Builder
replicateB n :: Line
n xs :: Body
xs = Body -> Builder
TB.fromText (Line -> Body -> Body
T.replicate Line
n Body
xs)
{-# INLINE replicateB #-}

-- | Index safely into an array.
indexLines :: A.Array Int s -> Int -> Maybe s
indexLines :: Array Line s -> Line -> Maybe s
indexLines slines :: Array Line s
slines i :: Line
i = if (Line, Line) -> Line -> Bool
forall a. Ix a => (a, a) -> a -> Bool
A.inRange (Array Line s -> (Line, Line)
forall i e. Array i e -> (i, i)
A.bounds Array Line s
slines) Line
i
    then s -> Maybe s
forall a. a -> Maybe a
Just (Array Line s -> Line -> s
forall i e. Array i e -> Line -> e
A.unsafeAt Array Line s
slines Line
i)
    else Maybe s
forall a. Maybe a
Nothing
{-# INLINE indexLines #-}