{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
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
renderErrors :: Source source => source -> [Errata] -> TB.Builder
renderErrors :: forall source. Source source => source -> [Errata] -> Builder
renderErrors source
source [Errata]
errs = Builder
errorMessage
where
blockPointersGrouped :: [[IntMap [Pointer]]]
blockPointersGrouped = (Errata -> [IntMap [Pointer]]) -> [Errata] -> [[IntMap [Pointer]]]
forall a b. (a -> b) -> [a] -> [b]
map ((Block -> IntMap [Pointer]) -> [Block] -> [IntMap [Pointer]]
forall a b. (a -> b) -> [a] -> [b]
map Block -> IntMap [Pointer]
groupBlockPointers ([Block] -> [IntMap [Pointer]])
-> (Errata -> [Block]) -> Errata -> [IntMap [Pointer]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errata -> [Block]
errataBlocks) [Errata]
errs
minPointers :: [[Int]]
minPointers = (([IntMap [Pointer]] -> [Int]) -> [[IntMap [Pointer]]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (([IntMap [Pointer]] -> [Int]) -> [[IntMap [Pointer]]] -> [[Int]])
-> ((IntMap [Pointer] -> Int) -> [IntMap [Pointer]] -> [Int])
-> (IntMap [Pointer] -> Int)
-> [[IntMap [Pointer]]]
-> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap [Pointer] -> Int) -> [IntMap [Pointer]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map) (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 Int -> Int
forall a. a -> a
id (Maybe Int -> Int)
-> (IntMap [Pointer] -> Maybe Int) -> IntMap [Pointer] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [Pointer]) -> Int) -> Maybe (Int, [Pointer]) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [Pointer]) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, [Pointer]) -> Maybe Int)
-> (IntMap [Pointer] -> Maybe (Int, [Pointer]))
-> IntMap [Pointer]
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [Pointer] -> Maybe (Int, [Pointer])
forall a. IntMap a -> Maybe (Int, a)
I.lookupMin) [[IntMap [Pointer]]]
blockPointersGrouped
maxPointers :: [[Int]]
maxPointers = (([IntMap [Pointer]] -> [Int]) -> [[IntMap [Pointer]]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (([IntMap [Pointer]] -> [Int]) -> [[IntMap [Pointer]]] -> [[Int]])
-> ((IntMap [Pointer] -> Int) -> [IntMap [Pointer]] -> [Int])
-> (IntMap [Pointer] -> Int)
-> [[IntMap [Pointer]]]
-> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap [Pointer] -> Int) -> [IntMap [Pointer]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map) (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall a. a -> a
id (Maybe Int -> Int)
-> (IntMap [Pointer] -> Maybe Int) -> IntMap [Pointer] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [Pointer]) -> Int) -> Maybe (Int, [Pointer]) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [Pointer]) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, [Pointer]) -> Maybe Int)
-> (IntMap [Pointer] -> Maybe (Int, [Pointer]))
-> IntMap [Pointer]
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [Pointer] -> Maybe (Int, [Pointer])
forall a. IntMap a -> Maybe (Int, a)
I.lookupMax) [[IntMap [Pointer]]]
blockPointersGrouped
minLine :: Int
minLine = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
minPointers)
maxLine :: Int
maxLine = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
maxPointers)
srcTable :: IntMap [source]
srcTable = Int -> Int -> [source] -> IntMap [source]
forall a. Source a => Int -> Int -> [a] -> IntMap [a]
makeSourceTable Int
minLine Int
maxLine (source -> [source]
forall s. Source s => s -> [s]
sourceToLines source
source)
errataMessages :: [Builder]
errataMessages = ZipList Builder -> [Builder]
forall a. ZipList a -> [a]
getZipList (ZipList Builder -> [Builder]) -> ZipList Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ IntMap [source]
-> Errata -> [IntMap [Pointer]] -> [Int] -> [Int] -> Builder
forall source.
Source source =>
IntMap [source]
-> Errata -> [IntMap [Pointer]] -> [Int] -> [Int] -> Builder
renderErrata IntMap [source]
srcTable
(Errata -> [IntMap [Pointer]] -> [Int] -> [Int] -> Builder)
-> ZipList Errata
-> ZipList ([IntMap [Pointer]] -> [Int] -> [Int] -> Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Errata] -> ZipList Errata
forall a. [a] -> ZipList a
ZipList [Errata]
errs
ZipList ([IntMap [Pointer]] -> [Int] -> [Int] -> Builder)
-> ZipList [IntMap [Pointer]]
-> ZipList ([Int] -> [Int] -> Builder)
forall a b. ZipList (a -> b) -> ZipList a -> ZipList b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[IntMap [Pointer]]] -> ZipList [IntMap [Pointer]]
forall a. [a] -> ZipList a
ZipList [[IntMap [Pointer]]]
blockPointersGrouped
ZipList ([Int] -> [Int] -> Builder)
-> ZipList [Int] -> ZipList ([Int] -> Builder)
forall a b. ZipList (a -> b) -> ZipList a -> ZipList b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Int]] -> ZipList [Int]
forall a. [a] -> ZipList a
ZipList [[Int]]
minPointers
ZipList ([Int] -> Builder) -> ZipList [Int] -> ZipList Builder
forall a b. ZipList (a -> b) -> ZipList a -> ZipList b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Int]] -> ZipList [Int]
forall a. [a] -> ZipList a
ZipList [[Int]]
maxPointers
errorMessage :: Builder
errorMessage = Builder -> [Builder] -> Builder
unsplit Builder
"\n\n" [Builder]
errataMessages
groupBlockPointers :: Block -> I.IntMap [Pointer]
groupBlockPointers :: Block -> IntMap [Pointer]
groupBlockPointers = ([Pointer] -> [Pointer] -> [Pointer])
-> [(Int, [Pointer])] -> IntMap [Pointer]
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
I.fromListWith [Pointer] -> [Pointer] -> [Pointer]
forall a. Semigroup a => a -> a -> a
(<>) ([(Int, [Pointer])] -> IntMap [Pointer])
-> (Block -> [(Int, [Pointer])]) -> Block -> IntMap [Pointer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> (Int, [Pointer])) -> [Pointer] -> [(Int, [Pointer])]
forall a b. (a -> b) -> [a] -> [b]
map (\Pointer
p -> (Pointer -> Int
pointerLine Pointer
p, Pointer -> [Pointer]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pointer
p)) ([Pointer] -> [(Int, [Pointer])])
-> (Block -> [Pointer]) -> Block -> [(Int, [Pointer])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Pointer]
blockPointers
makeSourceTable :: Source a => Line -> Line -> [a] -> I.IntMap [a]
makeSourceTable :: forall a. Source a => Int -> Int -> [a] -> IntMap [a]
makeSourceTable Int
minLine Int
maxLine [a]
slines = [(Int, [a])] -> IntMap [a]
forall a. [(Int, a)] -> IntMap a
I.fromDistinctAscList ([(Int, [a])] -> IntMap [a]) -> [(Int, [a])] -> IntMap [a]
forall a b. (a -> b) -> a -> b
$
[Int] -> [[a]] -> [(Int, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
minLine .. Int
maxLine] (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop (Int
minLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([a] -> [[a]]
forall a. Source a => [a] -> [[a]]
slices [a]
slines))
slices :: Source a => [a] -> [[a]]
slices :: forall a. Source a => [a] -> [[a]]
slices [] = [a] -> [[a]]
forall a. a -> [a]
repeat (a -> [a]
forall a. a -> [a]
repeat a
forall s. Source s => s
emptySource)
slices [a]
xs = ([a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> a -> [a]
forall a. a -> [a]
repeat a
forall s. Source s => s
emptySource) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
forall a. Source a => [a] -> [[a]]
slices ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
xs)
renderErrata
:: Source source
=> I.IntMap [source]
-> Errata
-> [I.IntMap [Pointer]]
-> [Line]
-> [Line]
-> TB.Builder
renderErrata :: forall source.
Source source =>
IntMap [source]
-> Errata -> [IntMap [Pointer]] -> [Int] -> [Int] -> Builder
renderErrata IntMap [source]
srcTable (Errata {[Block]
Maybe Body
errataBlocks :: Errata -> [Block]
errataHeader :: Maybe Body
errataBlocks :: [Block]
errataBody :: Maybe Body
errataBody :: Errata -> Maybe Body
errataHeader :: Errata -> Maybe Body
..}) [IntMap [Pointer]]
blockPointersGrouped [Int]
minPointers [Int]
maxPointers = Builder
errorMessage
where
blockMessages :: [Builder]
blockMessages = ZipList Builder -> [Builder]
forall a. ZipList a -> [a]
getZipList (ZipList Builder -> [Builder]) -> ZipList Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ IntMap [source]
-> Block -> IntMap [Pointer] -> (Int, Int) -> Builder
forall source.
Source source =>
IntMap [source]
-> Block -> IntMap [Pointer] -> (Int, Int) -> Builder
renderBlock IntMap [source]
srcTable
(Block -> IntMap [Pointer] -> (Int, Int) -> Builder)
-> ZipList Block
-> ZipList (IntMap [Pointer] -> (Int, Int) -> Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> ZipList Block
forall a. [a] -> ZipList a
ZipList [Block]
errataBlocks
ZipList (IntMap [Pointer] -> (Int, Int) -> Builder)
-> ZipList (IntMap [Pointer]) -> ZipList ((Int, Int) -> Builder)
forall a b. ZipList (a -> b) -> ZipList a -> ZipList b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [IntMap [Pointer]] -> ZipList (IntMap [Pointer])
forall a. [a] -> ZipList a
ZipList [IntMap [Pointer]]
blockPointersGrouped
ZipList ((Int, Int) -> Builder)
-> ZipList (Int, Int) -> ZipList Builder
forall a b. ZipList (a -> b) -> ZipList a -> ZipList b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Int, Int)] -> ZipList (Int, Int)
forall a. [a] -> ZipList a
ZipList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
minPointers [Int]
maxPointers)
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. a -> a
id Maybe Body
errataHeader
, case [Builder]
blockMessages of
[] -> Builder
""
[Builder]
xs -> case Maybe Body
errataHeader of
Maybe Body
Nothing -> Builder -> [Builder] -> Builder
unsplit Builder
"\n\n" [Builder]
xs
Just Body
_ -> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
unsplit Builder
"\n\n" [Builder]
xs
, 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
"\n" Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) Maybe Body
errataBody
]
renderBlock
:: Source source
=> I.IntMap [source]
-> Block
-> I.IntMap [Pointer]
-> (Line, Line)
-> TB.Builder
renderBlock :: forall source.
Source source =>
IntMap [source]
-> Block -> IntMap [Pointer] -> (Int, Int) -> Builder
renderBlock IntMap [source]
srcTable block :: Block
block@(Block {[Pointer]
Maybe Body
(FilePath, Int, Int)
Style
blockPointers :: Block -> [Pointer]
blockStyle :: Style
blockLocation :: (FilePath, Int, Int)
blockHeader :: Maybe Body
blockPointers :: [Pointer]
blockBody :: Maybe Body
blockBody :: Block -> Maybe Body
blockHeader :: Block -> Maybe Body
blockLocation :: Block -> (FilePath, Int, Int)
blockStyle :: Block -> Style
..}) IntMap [Pointer]
blockPointersGrouped ~(Int
minBlockLine, Int
maxBlockLine) = Builder
blockMessage
where
slines :: [(Int, source)]
slines = [Int] -> [source] -> [(Int, source)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
minBlockLine .. Int
maxBlockLine] ([source] -> ([source] -> [source]) -> Maybe [source] -> [source]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [source] -> [source]
forall a. a -> a
id (Maybe [source] -> [source]) -> Maybe [source] -> [source]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [source] -> Maybe [source]
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
minBlockLine IntMap [source]
srcTable)
padding :: Int
padding = FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
maxBlockLine)
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, Int, Int) -> Body
styleLocation Style
blockStyle (FilePath, Int, Int)
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 Body
"" (Body
"\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 Builder
"" (Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Maybe Builder -> Builder) -> Maybe Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [(Int, source)]
-> Block -> Int -> IntMap [Pointer] -> Maybe Builder
forall source.
Source source =>
[(Int, source)]
-> Block -> Int -> IntMap [Pointer] -> Maybe Builder
renderSourceLines [(Int, source)]
slines Block
block Int
padding IntMap [Pointer]
blockPointersGrouped
, 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
"\n" Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<>) Maybe Body
blockBody
]
renderSourceLines
:: forall source
. Source source
=> [(Line, source)]
-> Block
-> Int
-> I.IntMap [Pointer]
-> Maybe (TB.Builder)
renderSourceLines :: forall source.
Source source =>
[(Int, source)]
-> Block -> Int -> IntMap [Pointer] -> Maybe Builder
renderSourceLines [(Int, source)]
_ Block
_ Int
_ (IntMap [Pointer] -> Bool
forall a. IntMap a -> Bool
I.null -> Bool
True) = Maybe Builder
forall a. Maybe a
Nothing
renderSourceLines [(Int, source)]
slines (Block {[Pointer]
Maybe Body
(FilePath, Int, Int)
Style
blockPointers :: Block -> [Pointer]
blockBody :: Block -> Maybe Body
blockHeader :: Block -> Maybe Body
blockLocation :: Block -> (FilePath, Int, Int)
blockStyle :: Block -> Style
blockStyle :: Style
blockLocation :: (FilePath, Int, Int)
blockHeader :: Maybe Body
blockPointers :: [Pointer]
blockBody :: Maybe Body
..}) Int
padding IntMap [Pointer]
pointersGrouped = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> Builder
unsplit Builder
"\n" [Builder]
decoratedLines
where
Style {Bool
Int
Body
Int -> Body
[(PointerStyle, (Int, Int))] -> Body -> Body
(FilePath, Int, Int) -> Body
styleLocation :: Style -> (FilePath, Int, Int) -> Body
styleLocation :: (FilePath, Int, Int) -> Body
styleNumber :: Int -> Body
styleLine :: [(PointerStyle, (Int, Int))] -> Body -> Body
styleEllipsis :: Body
styleLinePrefix :: Body
styleVertical :: Body
styleHorizontal :: Body
styleDownRight :: Body
styleUpRight :: Body
styleUpDownRight :: Body
styleTabWidth :: Int
styleExtraLinesAfter :: Int
styleExtraLinesBefore :: Int
stylePaddingTop :: Bool
stylePaddingBottom :: Bool
styleEnableDecorations :: Bool
styleEnableLinePrefix :: Bool
styleEnableLinePrefix :: Style -> Bool
styleEnableDecorations :: Style -> Bool
stylePaddingBottom :: Style -> Bool
stylePaddingTop :: Style -> Bool
styleExtraLinesBefore :: Style -> Int
styleExtraLinesAfter :: Style -> Int
styleTabWidth :: Style -> Int
styleUpDownRight :: Style -> Body
styleUpRight :: Style -> Body
styleDownRight :: Style -> Body
styleHorizontal :: Style -> Body
styleVertical :: Style -> Body
styleLinePrefix :: Style -> Body
styleEllipsis :: Style -> Body
styleLine :: Style -> [(PointerStyle, (Int, Int))] -> Body -> Body
styleNumber :: Style -> Int -> Body
..} = Style
blockStyle
showLine :: [(PointerStyle, (Column, Column))] -> source -> TB.Builder
showLine :: [(PointerStyle, (Int, Int))] -> source -> Builder
showLine [(PointerStyle, (Int, Int))]
hs = Body -> Builder
TB.fromText (Body -> Builder) -> (source -> Body) -> source -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Body -> Body -> Body -> Body
Body -> Body -> Body -> Body
T.replace Body
"\t" (Int -> Body -> Body
T.replicate Int
styleTabWidth Body
" ") (Body -> Body) -> (source -> Body) -> source -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PointerStyle, (Int, Int))] -> Body -> Body
styleLine [(PointerStyle, (Int, Int))]
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
prefix :: TB.Builder
prefix :: Builder
prefix = if Bool
styleEnableLinePrefix
then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Int -> Body -> Builder
replicateB Int
padding Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix, Builder
" "]
else Builder
""
linePrefix :: Line -> TB.Builder
linePrefix :: Int -> Builder
linePrefix Int
n = if Bool
styleEnableLinePrefix
then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Body -> Builder
TB.fromText (Int -> Body
styleNumber Int
n), Int -> Body -> Builder
replicateB (Int
padding Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix, Builder
" "]
else Builder
""
decoratedLines :: [TB.Builder]
decoratedLines :: [Builder]
decoratedLines = [Builder
paddingLine | Bool
stylePaddingTop] [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
0 [(Int, source)]
slines[Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> [Builder
paddingLine | Bool
stylePaddingBottom]
where
paddingLine :: Builder
paddingLine = if Bool
styleEnableLinePrefix
then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Int -> Body -> Builder
replicateB Int
padding Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix]
else Builder
""
hasConnMulti :: Bool
hasConnMulti :: Bool
hasConnMulti = IntMap [Pointer] -> Int
forall a. IntMap a -> Int
I.size (([Pointer] -> Bool) -> IntMap [Pointer] -> IntMap [Pointer]
forall a. (a -> Bool) -> IntMap a -> IntMap a
I.filter ((Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect) IntMap [Pointer]
pointersGrouped) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
hasConn :: Line -> Bool
hasConn :: Int -> Bool
hasConn Int
n = Bool -> ([Pointer] -> Bool) -> Maybe [Pointer] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect) (Maybe [Pointer] -> Bool) -> Maybe [Pointer] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [Pointer] -> Maybe [Pointer]
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
n IntMap [Pointer]
pointersGrouped
connAround :: Line -> (Bool, Bool)
connAround :: Int -> (Bool, Bool)
connAround Int
n =
let (IntMap [Pointer]
a, IntMap [Pointer]
b) = Int -> IntMap [Pointer] -> (IntMap [Pointer], IntMap [Pointer])
forall a. Int -> IntMap a -> (IntMap a, IntMap a)
I.split Int
n IntMap [Pointer]
pointersGrouped
in ((([Pointer] -> Bool) -> IntMap [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (([Pointer] -> Bool) -> IntMap [Pointer] -> Bool)
-> ((Pointer -> Bool) -> [Pointer] -> Bool)
-> (Pointer -> Bool)
-> IntMap [Pointer]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any) Pointer -> Bool
pointerConnect IntMap [Pointer]
a, (([Pointer] -> Bool) -> IntMap [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (([Pointer] -> Bool) -> IntMap [Pointer] -> Bool)
-> ((Pointer -> Bool) -> [Pointer] -> Bool)
-> (Pointer -> Bool)
-> IntMap [Pointer]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any) Pointer -> Bool
pointerConnect IntMap [Pointer]
b)
makeDecoratedLines :: Line -> [(Line, source)] -> [TB.Builder]
makeDecoratedLines :: Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
_ [] = []
makeDecoratedLines Int
_ (pr :: (Int, source)
pr@(Int
n, source
_):[(Int, source)]
ls)
| Just [Pointer]
p <- Int -> IntMap [Pointer] -> Maybe [Pointer]
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
n IntMap [Pointer]
pointersGrouped = [Pointer] -> (Int, source) -> [Builder]
decorateLine [Pointer]
p (Int, source)
pr [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
0 [(Int, source)]
ls
makeDecoratedLines Int
extra ((Int
n, source
l):[(Int, source)]
ls)
| Int
extra Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
styleExtraLinesAfter =
let mid :: Builder
mid = if
| Bool -> Bool
not Bool
styleEnableDecorations -> Builder
""
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Int -> (Bool, Bool)
connAround Int
n) -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" "
| Bool
hasConnMulti -> Builder
" "
| Bool
otherwise -> Builder
""
in (Int -> Builder
linePrefix Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(PointerStyle, (Int, Int))] -> source -> Builder
showLine [] source
l) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Int -> [(Int, source)] -> [Builder]
makeDecoratedLines (Int
extra Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Int, source)]
ls
makeDecoratedLines Int
_ [(Int, source)]
ls =
let ([(Int, source)]
es, [(Int, source)]
ls') = ((Int, source) -> Bool)
-> [(Int, source)] -> ([(Int, source)], [(Int, source)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Int -> IntMap [Pointer] -> Bool
forall a. Int -> IntMap a -> Bool
`I.member` IntMap [Pointer]
pointersGrouped) (Int -> Bool) -> ((Int, source) -> Int) -> (Int, source) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, source) -> Int
forall a b. (a, b) -> a
fst) [(Int, source)]
ls
in case ([(Int, source)]
es, [(Int, source)]
ls') of
([(Int, source)]
_, []) -> []
([], [(Int, source)]
_) -> Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
0 [(Int, source)]
ls'
([(Int, source)]
_, [(Int, source)]
_) ->
let es' :: [(Int, source)]
es' = [(Int, source)] -> [(Int, source)]
forall a. [a] -> [a]
reverse ([(Int, source)] -> [(Int, source)])
-> ([(Int, source)] -> [(Int, source)])
-> [(Int, source)]
-> [(Int, source)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(Int, source)] -> [(Int, source)]
forall a. Int -> [a] -> [a]
take Int
styleExtraLinesBefore ([(Int, source)] -> [(Int, source)])
-> ([(Int, source)] -> [(Int, source)])
-> [(Int, source)]
-> [(Int, source)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, source)] -> [(Int, source)]
forall a. [a] -> [a]
reverse ([(Int, source)] -> [(Int, source)])
-> [(Int, source)] -> [(Int, source)]
forall a b. (a -> b) -> a -> b
$ [(Int, source)]
es
extras :: [Builder]
extras = (((Int, source) -> Builder) -> [(Int, source)] -> [Builder])
-> [(Int, source)] -> ((Int, source) -> Builder) -> [Builder]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, source) -> Builder) -> [(Int, source)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, source)]
es' (((Int, source) -> Builder) -> [Builder])
-> ((Int, source) -> Builder) -> [Builder]
forall a b. (a -> b) -> a -> b
$ \(Int
n, source
l) ->
let gutter :: Builder
gutter = if
| Bool -> Bool
not Bool
styleEnableDecorations -> Builder
""
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Int -> (Bool, Bool)
connAround Int
n) -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" "
| Bool
hasConnMulti -> Builder
" "
| Bool
otherwise -> Builder
""
in Int -> Builder
linePrefix Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
gutter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(PointerStyle, (Int, Int))] -> source -> Builder
showLine [] source
l
in case [(Int, source)] -> [(Int, source)] -> Ordering
forall a b. [a] -> [b] -> Ordering
compareLength [(Int, source)]
es' [(Int, source)]
es of
Ordering
LT -> let
omitPrefix :: Builder
omitPrefix = if Bool
styleEnableLinePrefix
then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Body -> Builder
TB.fromText Body
styleEllipsis, Int -> Body -> Builder
replicateB (Int
padding Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix]
else Builder
""
omitGutter :: Builder
omitGutter = if
| Bool -> Bool
not Bool
styleEnableDecorations -> Builder
""
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Bool, Bool) -> Bool)
-> ((Int, source) -> (Bool, Bool)) -> (Int, source) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Bool, Bool)
connAround (Int -> (Bool, Bool))
-> ((Int, source) -> Int) -> (Int, source) -> (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, source) -> Int
forall a b. (a, b) -> a
fst ((Int, source) -> Bool) -> (Int, source) -> Bool
forall a b. (a -> b) -> a -> b
$ [(Int, source)] -> (Int, source)
forall a. HasCallStack => [a] -> a
head [(Int, source)]
ls -> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
styleVertical
| Bool
otherwise -> Builder
""
in (Builder
omitPrefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
omitGutter) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
extras [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
0 [(Int, source)]
ls'
Ordering
_ -> [Builder]
extras [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, source)] -> [Builder]
makeDecoratedLines Int
0 [(Int, source)]
ls'
decorateLine :: [Pointer] -> (Line, source) -> [TB.Builder]
decorateLine :: [Pointer] -> (Int, source) -> [Builder]
decorateLine [Pointer]
pointers (Int
n, source
l) = (Int -> Builder
linePrefix Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
gutter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
stylizedLine) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
decorationLines
where
gutter :: Builder
gutter = if
| Bool -> Bool
not Bool
styleEnableDecorations -> Builder
""
| Bool
hasConnBefore Bool -> Bool -> Bool
&& Bool
hasConnUnder -> Body -> Builder
TB.fromText Body
styleVertical Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" "
| Bool
hasConnMulti -> Builder
" "
| Bool
otherwise -> Builder
""
hasConnHere :: Bool
hasConnHere = Int -> Bool
hasConn Int
n
(Bool
hasConnBefore, Bool
hasConnAfter) = Int -> (Bool, Bool)
connAround Int
n
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
pointersSorted :: [Pointer]
pointersSorted = (Pointer -> (Int, Int)) -> [Pointer] -> [Pointer]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Pointer -> (Int, Int)
pointerColumns [Pointer]
pointers
sourceLine :: Body
sourceLine = source -> Body
forall s. Source s => s -> Body
sourceToText source
l
stylizedLine :: Builder
stylizedLine = [(PointerStyle, (Int, Int))] -> source -> Builder
showLine ((Pointer -> (PointerStyle, (Int, Int)))
-> [Pointer] -> [(PointerStyle, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (Pointer -> PointerStyle
pointerStyle (Pointer -> PointerStyle)
-> (Pointer -> (Int, Int)) -> Pointer -> (PointerStyle, (Int, Int))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Pointer -> (Int, Int)
pointerColumns) [Pointer]
pointersSorted) source
l
decorationLines :: [Builder]
decorationLines = case (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]
forall a. HasCallStack => [a] -> [a]
init [Pointer]
pointersSorted) of
[Pointer]
_ | Bool -> Bool
not Bool
styleEnableDecorations -> []
[Pointer]
_ | [Pointer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pointer]
pointersSorted Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> [[Pointer] -> Builder
underline [Pointer]
pointersSorted]
[] -> [[Pointer] -> Builder
underline [Pointer]
pointersSorted]
[Pointer]
hasLabels -> [Pointer] -> Builder
underline [Pointer]
pointersSorted
Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Pointer] -> Builder
connectors [Pointer]
hasLabels
Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (([Pointer] -> Builder) -> [[Pointer]] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map [Pointer] -> Builder
connectorAndLabel ([[Pointer]] -> [Builder])
-> ([[Pointer]] -> [[Pointer]]) -> [[Pointer]] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pointer]] -> [[Pointer]]
forall a. [a] -> [a]
reverse ([[Pointer]] -> [[Pointer]])
-> ([[Pointer]] -> [[Pointer]]) -> [[Pointer]] -> [[Pointer]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pointer]] -> [[Pointer]]
forall a. HasCallStack => [a] -> [a]
tail ([[Pointer]] -> [Builder]) -> [[Pointer]] -> [Builder]
forall a b. (a -> b) -> a -> b
$ [Pointer] -> [[Pointer]]
forall a. [a] -> [[a]]
inits [Pointer]
hasLabels)
underline :: [Pointer] -> TB.Builder
underline :: [Pointer] -> Builder
underline [Pointer]
ps =
let (Builder
decor, Int
_) = (Int -> Bool -> [Pointer] -> Body -> Builder)
-> (Int -> Pointer -> Body -> (Int, Builder))
-> [Pointer]
-> Body
-> (Builder, Int)
foldDecorations
(\Int
k Bool
isFirst [Pointer]
rest Body
text -> 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 -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
styleHorizontal
| Bool
isFirst -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
" "
| (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect [Pointer]
rest -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
styleHorizontal
| Bool
otherwise -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
" "
)
(\Int
k Pointer
p Body
text ->
let x :: Body
x = PointerStyle -> Body
styleUnderline (Pointer -> PointerStyle
pointerStyle Pointer
p)
in (Int
k, Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
x)
)
[Pointer]
ps
Body
sourceLine
lbl :: Body
lbl = Body -> (Body -> Body) -> Maybe Body -> Body
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Body
"" (Body
" " 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
$ [Pointer] -> Pointer
forall a. HasCallStack => [a] -> a
last [Pointer]
ps
decorGutter :: Body
decorGutter = 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
<> Body
" "
| Bool
hasConnMulti -> Body
" "
| Bool
otherwise -> Body
""
in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
decorGutter 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
connectors :: [Pointer] -> TB.Builder
connectors :: [Pointer] -> Builder
connectors [Pointer]
ps =
let (Builder
decor, Int
_) = (Int -> Bool -> [Pointer] -> Body -> Builder)
-> (Int -> Pointer -> Body -> (Int, Builder))
-> [Pointer]
-> Body
-> (Builder, Int)
foldDecorations
(\Int
k Bool
_ [Pointer]
_ Body
text -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
" ")
(\Int
_ Pointer
p Body
_ ->
let x :: Body
x = PointerStyle -> Body
styleConnector (Pointer -> PointerStyle
pointerStyle Pointer
p)
in (Int
1, Body -> Builder
TB.fromText Body
x)
)
[Pointer]
ps
Body
sourceLine
decorGutter :: Body
decorGutter = if
| Bool
hasConnOver Bool -> Bool -> Bool
&& Bool
hasConnAfter -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> Body
" "
| Bool
hasConnMulti -> Body
" "
| Bool
otherwise -> Body
""
in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
decorGutter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
decor
connectorAndLabel :: [Pointer] -> TB.Builder
connectorAndLabel :: [Pointer] -> Builder
connectorAndLabel [Pointer]
ps =
let (Builder
decor, Int
finalCol) = (Int -> Bool -> [Pointer] -> Body -> Builder)
-> (Int -> Pointer -> Body -> (Int, Builder))
-> [Pointer]
-> Body
-> (Builder, Int)
foldDecorations
(\Int
k Bool
_ [Pointer]
_ Body
text -> Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
k Int
styleTabWidth Body
text Body
" ")
(\Int
_ Pointer
p Body
_ ->
let x :: Body
x = PointerStyle -> Body
styleConnector (Pointer -> PointerStyle
pointerStyle Pointer
p)
in (Int
1, Body -> Builder
TB.fromText Body
x)
)
([Pointer] -> [Pointer]
forall a. HasCallStack => [a] -> [a]
init [Pointer]
ps)
Body
sourceLine
pointer :: Pointer
pointer = [Pointer] -> Pointer
forall a. HasCallStack => [a] -> a
last [Pointer]
ps
hook :: Body
hook = PointerStyle -> Body
styleHook (Pointer -> PointerStyle
pointerStyle Pointer
pointer)
lbl :: Builder
lbl = Builder -> (Body -> Builder) -> Maybe Body -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
""
(\Body
x -> if
| PointerStyle -> Bool
styleEnableHook (Pointer -> PointerStyle
pointerStyle Pointer
pointer) -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Int -> Body -> Builder
replicateB (Pointer -> Int
pointerColStart Pointer
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
finalCol) Body
" "
, Body -> Builder
TB.fromText Body
hook
, Builder
" "
, Body -> Builder
TB.fromText Body
x
]
| Bool
otherwise -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Int -> Body -> Builder
replicateB (Pointer -> Int
pointerColStart Pointer
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
finalCol) Body
" "
, Body -> Builder
TB.fromText Body
x
]
)
(Pointer -> Maybe Body
pointerLabel Pointer
pointer)
decorGutter :: Body
decorGutter = if
| Bool
hasConnOver Bool -> Bool -> Bool
&& Bool
hasConnAfter -> Body
styleVertical Body -> Body -> Body
forall a. Semigroup a => a -> a -> a
<> Body
" "
| Bool
hasConnMulti -> Body
" "
| Bool
otherwise -> Body
""
in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Body -> Builder
TB.fromText Body
decorGutter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
decor Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lbl
foldDecorations
:: (Int -> Bool -> [Pointer] -> T.Text -> TB.Builder)
-> (Int -> Pointer -> T.Text -> (Int, TB.Builder))
-> [Pointer]
-> T.Text
-> (TB.Builder, Column)
foldDecorations :: (Int -> Bool -> [Pointer] -> Body -> Builder)
-> (Int -> Pointer -> Body -> (Int, Builder))
-> [Pointer]
-> Body
-> (Builder, Int)
foldDecorations Int -> Bool -> [Pointer] -> Body -> Builder
catchUp Int -> Pointer -> Body -> (Int, Builder)
underlinePointer [Pointer]
ps Body
line =
let (Builder
decor, Int
finalCol, Bool
_, Body
_) = (([Pointer], (Builder, Int, Bool, Body))
-> Pointer -> (Builder, Int, Bool, Body))
-> (Builder, Int, Bool, Body)
-> [Pointer]
-> (Builder, Int, Bool, Body)
forall a b. (([a], b) -> a -> b) -> b -> [a] -> b
paral
(\([Pointer]
rest, (Builder
xs, Int
c, Bool
isFirst, Body
remainingLine)) p :: Pointer
p@(Pointer {Bool
Int
Maybe Body
PointerStyle
pointerLine :: Pointer -> Int
pointerConnect :: Pointer -> Bool
pointerStyle :: Pointer -> PointerStyle
pointerLabel :: Pointer -> Maybe Body
pointerColStart :: Pointer -> Int
pointerLine :: Int
pointerColStart :: Int
pointerColEnd :: Int
pointerConnect :: Bool
pointerLabel :: Maybe Body
pointerStyle :: PointerStyle
pointerColEnd :: Pointer -> Int
..}) ->
let (Body
textBefore, Body
textUnderAndRest) = Int -> Body -> (Body, Body)
T.splitAt (Int
pointerColStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c) Body
remainingLine
(Body
textUnder, Body
textRest) = Int -> Body -> (Body, Body)
T.splitAt (Int
pointerColEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pointerColStart) Body
textUnderAndRest
(Int
afterLen, Builder
afterText) = Int -> Pointer -> Body -> (Int, Builder)
underlinePointer (Int
pointerColEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pointerColStart) Pointer
p Body
textUnder
in
( [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Builder
xs
, Int -> Bool -> [Pointer] -> Body -> Builder
catchUp (Int
pointerColStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c) Bool
isFirst (Pointer
pPointer -> [Pointer] -> [Pointer]
forall a. a -> [a] -> [a]
:[Pointer]
rest) Body
textBefore
, Builder
afterText
]
, Int
pointerColStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
afterLen
, Bool
False
, Body
textRest
)
)
(Builder
"", Int
1, Bool
True, Body
line)
[Pointer]
ps
in (Builder
decor, Int
finalCol)
paral :: (([a], b) -> a -> b) -> b -> [a] -> b
paral :: forall a b. (([a], b) -> a -> b) -> b -> [a] -> b
paral ([a], b) -> a -> b
_ b
b [] = b
b
paral ([a], b) -> a -> b
f b
b (a
a:[a]
as) =
let !b' :: b
b' = ([a], b) -> a -> b
f ([a]
as, b
b) a
a
in (([a], b) -> a -> b) -> b -> [a] -> b
forall a b. (([a], b) -> a -> b) -> b -> [a] -> b
paral ([a], b) -> a -> b
f b
b' [a]
as
compareLength :: [a] -> [b] -> Ordering
compareLength :: forall a b. [a] -> [b] -> Ordering
compareLength [] [] = Ordering
EQ
compareLength (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Ordering
forall a b. [a] -> [b] -> Ordering
compareLength [a]
xs [b]
ys
compareLength [] [b]
_ = Ordering
LT
compareLength [a]
_ [] = Ordering
GT
unsplit :: TB.Builder -> [TB.Builder] -> TB.Builder
unsplit :: Builder -> [Builder] -> Builder
unsplit Builder
_ [] = Builder
""
unsplit Builder
a (Builder
x:[Builder]
xs) = (Builder -> Builder -> Builder) -> Builder -> [Builder] -> Builder
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Builder
acc 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 #-}
replicateB :: Int -> T.Text -> TB.Builder
replicateB :: Int -> Body -> Builder
replicateB Int
n Body
xs = Body -> Builder
TB.fromText (Int -> Body -> Body
T.replicate Int
n Body
xs)
{-# INLINE replicateB #-}
replaceWithWidth :: Int -> Int -> T.Text -> T.Text -> TB.Builder
replaceWithWidth :: Int -> Int -> Body -> Body -> Builder
replaceWithWidth Int
len Int
tab Body
ref Body
xs = (Builder -> Char -> Builder) -> Builder -> Body -> Builder
forall a. (a -> Char -> a) -> a -> Body -> a
T.foldl' (\Builder
acc Char
c -> Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Body -> Builder
replicateB (Char -> Int
width Char
c) Body
xs) Builder
"" Body
ref Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Body -> Builder
replicateB (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Body -> Int
T.length Body
ref) Body
xs
where
width :: Char -> Int
width Char
'\t' = Int
tab
width Char
c = Char -> Int
charWidth Char
c
{-# INLINE replaceWithWidth #-}
#if defined(usewcwidth)
foreign import ccall unsafe "wchar.h wcwidth" wcwidth :: CWchar -> CInt
charWidth :: Char -> Int
charWidth = max 0 . fromEnum . wcwidth . toEnum . fromEnum
#else
charWidth :: Char -> Int
charWidth :: Char -> Int
charWidth Char
c = if
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x0300' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x0300' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x036F' -> Int
0
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x0370' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x10FC' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1100' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x115F' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1160' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x11A2' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x11A3' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x11A7' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x11A8' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x11F9' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x11FA' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x11FF' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1200' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2328' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x2329' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x232A' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x232B' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2E31' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x2E80' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x303E' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\x303F' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x3041' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x3247' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x3248' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x324F' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x3250' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x4DBF' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x4DC0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x4DFF' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x4E00' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xA4C6' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xA4D0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xA95F' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xA960' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xA97C' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xA980' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xABF9' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xAC00' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xD7FB' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xD800' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDFFF' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xE000' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xF8FF' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xF900' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFAFF' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFB00' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFDFD' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFE00' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFE0F' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFE10' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFE19' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFE20' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFE26' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFE30' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFE6B' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFE70' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFEFF' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFF01' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFF60' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xFF61' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x16A38' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1B000' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x1B001' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1D000' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x1F1FF' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1F200' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x1F251' -> Int
2
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x1F300' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x1F773' -> Int
1
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x20000' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x3FFFD' -> Int
2
| Bool
otherwise -> Int
1
#endif