{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# 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 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
renderErrors :: Source source => source -> [Errata] -> TB.Builder
renderErrors :: 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 :: [[Key]]
minPointers = (([IntMap [Pointer]] -> [Key]) -> [[IntMap [Pointer]]] -> [[Key]]
forall a b. (a -> b) -> [a] -> [b]
map (([IntMap [Pointer]] -> [Key]) -> [[IntMap [Pointer]]] -> [[Key]])
-> ((IntMap [Pointer] -> Key) -> [IntMap [Pointer]] -> [Key])
-> (IntMap [Pointer] -> Key)
-> [[IntMap [Pointer]]]
-> [[Key]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap [Pointer] -> Key) -> [IntMap [Pointer]] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map) (Key -> (Key -> Key) -> Maybe Key -> Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Key
1 Key -> Key
forall a. a -> a
id (Maybe Key -> Key)
-> (IntMap [Pointer] -> Maybe Key) -> IntMap [Pointer] -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, [Pointer]) -> Key) -> Maybe (Key, [Pointer]) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, [Pointer]) -> Key
forall a b. (a, b) -> a
fst (Maybe (Key, [Pointer]) -> Maybe Key)
-> (IntMap [Pointer] -> Maybe (Key, [Pointer]))
-> IntMap [Pointer]
-> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [Pointer] -> Maybe (Key, [Pointer])
forall a. IntMap a -> Maybe (Key, a)
I.lookupMin) [[IntMap [Pointer]]]
blockPointersGrouped
maxPointers :: [[Key]]
maxPointers = (([IntMap [Pointer]] -> [Key]) -> [[IntMap [Pointer]]] -> [[Key]]
forall a b. (a -> b) -> [a] -> [b]
map (([IntMap [Pointer]] -> [Key]) -> [[IntMap [Pointer]]] -> [[Key]])
-> ((IntMap [Pointer] -> Key) -> [IntMap [Pointer]] -> [Key])
-> (IntMap [Pointer] -> Key)
-> [[IntMap [Pointer]]]
-> [[Key]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap [Pointer] -> Key) -> [IntMap [Pointer]] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map) (Key -> (Key -> Key) -> Maybe Key -> Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Key
0 Key -> Key
forall a. a -> a
id (Maybe Key -> Key)
-> (IntMap [Pointer] -> Maybe Key) -> IntMap [Pointer] -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, [Pointer]) -> Key) -> Maybe (Key, [Pointer]) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, [Pointer]) -> Key
forall a b. (a, b) -> a
fst (Maybe (Key, [Pointer]) -> Maybe Key)
-> (IntMap [Pointer] -> Maybe (Key, [Pointer]))
-> IntMap [Pointer]
-> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [Pointer] -> Maybe (Key, [Pointer])
forall a. IntMap a -> Maybe (Key, a)
I.lookupMax) [[IntMap [Pointer]]]
blockPointersGrouped
minLine :: Key
minLine = [Key] -> Key
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([[Key]] -> [Key]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key]]
minPointers)
maxLine :: Key
maxLine = [Key] -> Key
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[Key]] -> [Key]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key]]
maxPointers)
srcTable :: IntMap [source]
srcTable = Key -> Key -> [source] -> IntMap [source]
forall a. Monoid a => Key -> Key -> [a] -> IntMap [a]
makeSourceTable Key
minLine Key
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]] -> [Key] -> [Key] -> Builder
forall source.
Source source =>
IntMap [source]
-> Errata -> [IntMap [Pointer]] -> [Key] -> [Key] -> Builder
renderErrata IntMap [source]
srcTable
(Errata -> [IntMap [Pointer]] -> [Key] -> [Key] -> Builder)
-> ZipList Errata
-> ZipList ([IntMap [Pointer]] -> [Key] -> [Key] -> 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]] -> [Key] -> [Key] -> Builder)
-> ZipList [IntMap [Pointer]]
-> ZipList ([Key] -> [Key] -> Builder)
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 ([Key] -> [Key] -> Builder)
-> ZipList [Key] -> ZipList ([Key] -> Builder)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Key]] -> ZipList [Key]
forall a. [a] -> ZipList a
ZipList [[Key]]
minPointers
ZipList ([Key] -> Builder) -> ZipList [Key] -> ZipList Builder
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Key]] -> ZipList [Key]
forall a. [a] -> ZipList a
ZipList [[Key]]
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])
-> [(Key, [Pointer])] -> IntMap [Pointer]
forall a. (a -> a -> a) -> [(Key, a)] -> IntMap a
I.fromListWith [Pointer] -> [Pointer] -> [Pointer]
forall a. Semigroup a => a -> a -> a
(<>) ([(Key, [Pointer])] -> IntMap [Pointer])
-> (Block -> [(Key, [Pointer])]) -> Block -> IntMap [Pointer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pointer -> (Key, [Pointer])) -> [Pointer] -> [(Key, [Pointer])]
forall a b. (a -> b) -> [a] -> [b]
map (\Pointer
p -> (Pointer -> Key
pointerLine Pointer
p, Pointer -> [Pointer]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pointer
p)) ([Pointer] -> [(Key, [Pointer])])
-> (Block -> [Pointer]) -> Block -> [(Key, [Pointer])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Pointer]
blockPointers
makeSourceTable :: Monoid a => Line -> Line -> [a] -> I.IntMap [a]
makeSourceTable :: Key -> Key -> [a] -> IntMap [a]
makeSourceTable Key
minLine Key
maxLine [a]
slines = [(Key, [a])] -> IntMap [a]
forall a. [(Key, a)] -> IntMap a
I.fromDistinctAscList ([(Key, [a])] -> IntMap [a]) -> [(Key, [a])] -> IntMap [a]
forall a b. (a -> b) -> a -> b
$
[Key] -> [[a]] -> [(Key, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
minLine .. Key
maxLine] (Key -> [[a]] -> [[a]]
forall a. Key -> [a] -> [a]
drop (Key
minLine Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) ([a] -> [[a]]
forall a. Monoid a => [a] -> [[a]]
slices [a]
slines))
slices :: Monoid a => [a] -> [[a]]
slices :: [a] -> [[a]]
slices [] = [a] -> [[a]]
forall a. a -> [a]
repeat (a -> [a]
forall a. a -> [a]
repeat a
forall a. Monoid a => a
mempty)
slices [a]
xs = ([a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> a -> [a]
forall a. a -> [a]
repeat a
forall a. Monoid a => a
mempty) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
forall a. Monoid a => [a] -> [[a]]
slices ([a] -> [a]
forall a. [a] -> [a]
tail [a]
xs)
renderErrata
:: Source source
=> I.IntMap [source]
-> Errata
-> [I.IntMap [Pointer]]
-> [Line]
-> [Line]
-> TB.Builder
renderErrata :: IntMap [source]
-> Errata -> [IntMap [Pointer]] -> [Key] -> [Key] -> Builder
renderErrata IntMap [source]
srcTable (Errata {[Block]
Maybe Body
errataBody :: Errata -> Maybe Body
errataHeader :: Errata -> Maybe Body
errataBody :: Maybe Body
errataBlocks :: [Block]
errataHeader :: Maybe Body
errataBlocks :: Errata -> [Block]
..}) [IntMap [Pointer]]
blockPointersGrouped [Key]
minPointers [Key]
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] -> (Key, Key) -> Builder
forall source.
Source source =>
IntMap [source]
-> Block -> IntMap [Pointer] -> (Key, Key) -> Builder
renderBlock IntMap [source]
srcTable
(Block -> IntMap [Pointer] -> (Key, Key) -> Builder)
-> ZipList Block
-> ZipList (IntMap [Pointer] -> (Key, Key) -> 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] -> (Key, Key) -> Builder)
-> ZipList (IntMap [Pointer]) -> ZipList ((Key, Key) -> Builder)
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 ((Key, Key) -> Builder)
-> ZipList (Key, Key) -> ZipList Builder
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Key, Key)] -> ZipList (Key, Key)
forall a. [a] -> ZipList a
ZipList ([Key] -> [Key] -> [(Key, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
minPointers [Key]
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 :: IntMap [source]
-> Block -> IntMap [Pointer] -> (Key, Key) -> Builder
renderBlock IntMap [source]
srcTable block :: Block
block@(Block {[Pointer]
Maybe Body
(FilePath, Key, Key)
Style
blockBody :: Block -> Maybe Body
blockHeader :: Block -> Maybe Body
blockLocation :: Block -> (FilePath, Key, Key)
blockStyle :: Block -> Style
blockBody :: Maybe Body
blockPointers :: [Pointer]
blockHeader :: Maybe Body
blockLocation :: (FilePath, Key, Key)
blockStyle :: Style
blockPointers :: Block -> [Pointer]
..}) IntMap [Pointer]
blockPointersGrouped ~(Key
minBlockLine, Key
maxBlockLine) = Builder
blockMessage
where
slines :: [(Key, source)]
slines = [Key] -> [source] -> [(Key, source)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
minBlockLine .. Key
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
$ Key -> IntMap [source] -> Maybe [source]
forall a. Key -> IntMap a -> Maybe a
I.lookup Key
minBlockLine IntMap [source]
srcTable)
padding :: Key
padding = FilePath -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length (Key -> FilePath
forall a. Show a => a -> FilePath
show Key
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, Key, Key) -> Body
styleLocation Style
blockStyle (FilePath, Key, Key)
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
$ [(Key, source)]
-> Block -> Key -> IntMap [Pointer] -> Maybe Builder
forall source.
Source source =>
[(Key, source)]
-> Block -> Key -> IntMap [Pointer] -> Maybe Builder
renderSourceLines [(Key, source)]
slines Block
block Key
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 :: [(Key, source)]
-> Block -> Key -> IntMap [Pointer] -> Maybe Builder
renderSourceLines [(Key, source)]
_ Block
_ Key
_ (IntMap [Pointer] -> Bool
forall a. IntMap a -> Bool
I.null -> Bool
True) = Maybe Builder
forall a. Maybe a
Nothing
renderSourceLines [(Key, source)]
slines (Block {[Pointer]
Maybe Body
(FilePath, Key, Key)
Style
blockBody :: Maybe Body
blockPointers :: [Pointer]
blockHeader :: Maybe Body
blockLocation :: (FilePath, Key, Key)
blockStyle :: Style
blockBody :: Block -> Maybe Body
blockHeader :: Block -> Maybe Body
blockLocation :: Block -> (FilePath, Key, Key)
blockStyle :: Block -> Style
blockPointers :: Block -> [Pointer]
..}) Key
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]
sourceLines
where
Style {Body
Key -> Body
[(Key, Key)] -> Body -> Body
(FilePath, Key, Key) -> Body
styleUpDownRight :: Style -> Body
styleUpRight :: Style -> Body
styleDownRight :: Style -> Body
styleHorizontal :: Style -> Body
styleVertical :: Style -> Body
styleUnderline :: Style -> Body
styleLinePrefix :: Style -> Body
styleEllipsis :: Style -> Body
styleLine :: Style -> [(Key, Key)] -> Body -> Body
styleNumber :: Style -> Key -> Body
styleUpDownRight :: Body
styleUpRight :: Body
styleDownRight :: Body
styleHorizontal :: Body
styleVertical :: Body
styleUnderline :: Body
styleLinePrefix :: Body
styleEllipsis :: Body
styleLine :: [(Key, Key)] -> Body -> Body
styleNumber :: Key -> Body
styleLocation :: (FilePath, Key, Key) -> Body
styleLocation :: Style -> (FilePath, Key, Key) -> Body
..} = Style
blockStyle
showLine :: [(Column, Column)] -> source -> TB.Builder
showLine :: [(Key, Key)] -> source -> Builder
showLine [(Key, Key)]
hs = Body -> Builder
TB.fromText (Body -> Builder) -> (source -> Body) -> source -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Key)] -> Body -> Body
styleLine [(Key, Key)]
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 :: Builder
prefix = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Key -> Body -> Builder
replicateB Key
padding Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix, Builder
" "
]
omitPrefix :: Builder
omitPrefix = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Body -> Builder
TB.fromText Body
styleEllipsis, Key -> Body -> Builder
replicateB (Key
padding Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix, Builder
" "
]
linePrefix :: Line -> TB.Builder
linePrefix :: Key -> Builder
linePrefix Key
n = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Body -> Builder
TB.fromText (Key -> Body
styleNumber Key
n), Key -> Body -> Builder
replicateB (Key
padding Key -> Key -> Key
forall a. Num a => a -> a -> a
- FilePath -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length (Key -> FilePath
forall a. Show a => a -> FilePath
show Key
n)) Body
" ", Builder
" "
, Body -> Builder
TB.fromText Body
styleLinePrefix, Builder
" "
]
sourceLines :: [Builder]
sourceLines = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Key -> Body -> Builder
replicateB Key
padding Body
" ", Builder
" ", Body -> Builder
TB.fromText Body
styleLinePrefix]
Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
0 [(Key, source)]
slines
hasConnMulti :: Bool
hasConnMulti = IntMap [Pointer] -> Key
forall a. IntMap a -> Key
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) Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1
hasConn :: Line -> Bool
hasConn :: Key -> Bool
hasConn Key
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
$ Key -> IntMap [Pointer] -> Maybe [Pointer]
forall a. Key -> IntMap a -> Maybe a
I.lookup Key
n IntMap [Pointer]
pointersGrouped
connAround :: Line -> (Bool, Bool)
connAround :: Key -> (Bool, Bool)
connAround Key
n =
let (IntMap [Pointer]
a, IntMap [Pointer]
b) = Key -> IntMap [Pointer] -> (IntMap [Pointer], IntMap [Pointer])
forall a. Key -> IntMap a -> (IntMap a, IntMap a)
I.split Key
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)
makeSourceLines :: Line -> [(Line, source)] -> [TB.Builder]
makeSourceLines :: Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
_ [] = []
makeSourceLines Key
_ (pr :: (Key, source)
pr@(Key
n, source
_):[(Key, source)]
ns)
| Just [Pointer]
p <- Key -> IntMap [Pointer] -> Maybe [Pointer]
forall a. Key -> IntMap a -> Maybe a
I.lookup Key
n IntMap [Pointer]
pointersGrouped = [Pointer] -> (Key, source) -> [Builder]
makeDecoratedLines [Pointer]
p (Key, source)
pr [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
0 [(Key, source)]
ns
makeSourceLines Key
extra ((Key
n, source
l):[(Key, source)]
ns)
| Key
extra Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
2 =
let mid :: Builder
mid = if
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Key -> (Bool, Bool)
connAround Key
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 (Key -> Builder
linePrefix Key
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)] -> source -> Builder
showLine [] source
l) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Key -> [(Key, source)] -> [Builder]
makeSourceLines (Key
extra Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) [(Key, source)]
ns
makeSourceLines Key
_ [(Key, source)]
ns =
let ([(Key, source)]
es, [(Key, source)]
ns') = ((Key, source) -> Bool)
-> [(Key, source)] -> ([(Key, source)], [(Key, source)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Key -> IntMap [Pointer] -> Bool
forall a. Key -> IntMap a -> Bool
`I.member` IntMap [Pointer]
pointersGrouped) (Key -> Bool) -> ((Key, source) -> Key) -> (Key, source) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, source) -> Key
forall a b. (a, b) -> a
fst) [(Key, source)]
ns
in case ([(Key, source)]
es, [(Key, source)]
ns') of
([(Key, source)]
_, []) -> []
([], [(Key, source)]
_) -> Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
0 [(Key, source)]
ns'
([(Key
n, source
l)], [(Key, source)]
_) ->
let mid :: Builder
mid = if
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Key -> (Bool, Bool)
connAround Key
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 (Key -> Builder
linePrefix Key
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)] -> source -> Builder
showLine [] source
l) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
0 [(Key, source)]
ns'
([(Key, source)]
_, [(Key, source)]
_) ->
let (Key
n, source
l) = [(Key, source)] -> (Key, source)
forall a. [a] -> a
last [(Key, source)]
es
mid :: Builder
mid = if
| (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Key -> (Bool, Bool)
connAround Key
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 (Builder
omitPrefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: (Key -> Builder
linePrefix Key
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
mid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [(Key, Key)] -> source -> Builder
showLine [] source
l) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: Key -> [(Key, source)] -> [Builder]
makeSourceLines Key
0 [(Key, source)]
ns'
makeDecoratedLines :: [Pointer] -> (Line, source) -> [TB.Builder]
makeDecoratedLines :: [Pointer] -> (Key, source) -> [Builder]
makeDecoratedLines [Pointer]
pointers (Key
num, source
line) =
(Key -> Builder
linePrefix Key
num 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
<> Body
" "
| Bool
hasConnMulti -> Body
" "
| Bool
otherwise -> Body
""
hasConnHere :: Bool
hasConnHere = Key -> Bool
hasConn Key
num
(Bool
hasConnBefore, Bool
hasConnAfter) = Key -> (Bool, Bool)
connAround Key
num
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 -> (Key, Key)) -> [Pointer] -> [Pointer]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Pointer -> (Key, Key)
pointerColumns [Pointer]
pointers
sline :: Builder
sline = [(Key, Key)] -> source -> Builder
showLine ((Pointer -> (Key, Key)) -> [Pointer] -> [(Key, Key)]
forall a b. (a -> b) -> [a] -> [b]
map Pointer -> (Key, Key)
pointerColumns [Pointer]
pointersSorted) source
line
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. [a] -> [a]
init [Pointer]
pointersSorted) of
[Pointer]
_ | [Pointer] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length [Pointer]
pointersSorted Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
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. [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, Key
_) = (Key -> Bool -> [Pointer] -> Builder)
-> (Key -> (Key, Builder)) -> [Pointer] -> (Builder, Key)
foldDecorations
(\Key
n Bool
isFirst [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 -> Key -> Body -> Builder
replicateB Key
n Body
styleHorizontal
| Bool
isFirst -> Key -> Body -> Builder
replicateB Key
n Body
" "
| (Pointer -> Bool) -> [Pointer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pointer -> Bool
pointerConnect [Pointer]
rest -> Key -> Body -> Builder
replicateB Key
n Body
styleHorizontal
| Bool
otherwise -> Key -> Body -> Builder
replicateB Key
n Body
" "
)
(\Key
n -> (Key
n, Key -> Body -> Builder
replicateB Key
n Body
styleUnderline))
[Pointer]
ps
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. [a] -> a
last [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
<> 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
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
connectors :: [Pointer] -> TB.Builder
connectors :: [Pointer] -> Builder
connectors [Pointer]
ps =
let (Builder
decor, Key
_) = (Key -> Bool -> [Pointer] -> Builder)
-> (Key -> (Key, Builder)) -> [Pointer] -> (Builder, Key)
foldDecorations
(\Key
n Bool
_ [Pointer]
_ -> Key -> Body -> Builder
replicateB Key
n Body
" ")
(\Key
_ -> (Key
1, Body -> Builder
TB.fromText Body
styleVertical))
[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
<> 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
mid 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, Key
finalCol) = (Key -> Bool -> [Pointer] -> Builder)
-> (Key -> (Key, Builder)) -> [Pointer] -> (Builder, Key)
foldDecorations
(\Key
n Bool
_ [Pointer]
_ -> Key -> Body -> Builder
replicateB Key
n Body
" ")
(\Key
_ -> (Key
1, Body -> Builder
TB.fromText Body
styleVertical))
([Pointer] -> [Pointer]
forall a. [a] -> [a]
init [Pointer]
ps)
lbl :: Builder
lbl = Builder -> (Body -> Builder) -> Maybe Body -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
""
(\Body
x -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Key -> Body -> Builder
replicateB (Pointer -> Key
pointerColStart ([Pointer] -> Pointer
forall a. [a] -> a
last [Pointer]
ps) Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
finalCol) Body
" "
, Body -> Builder
TB.fromText Body
styleUpRight
, Builder
" "
, Body -> Builder
TB.fromText Body
x
]
)
(Pointer -> Maybe Body
pointerLabel ([Pointer] -> Pointer
forall a. [a] -> a
last [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
<> 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
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
foldDecorations
:: (Column -> Bool -> [Pointer] -> TB.Builder)
-> (Column -> (Int, TB.Builder))
-> [Pointer]
-> (TB.Builder, Column)
foldDecorations :: (Key -> Bool -> [Pointer] -> Builder)
-> (Key -> (Key, Builder)) -> [Pointer] -> (Builder, Key)
foldDecorations Key -> Bool -> [Pointer] -> Builder
catchUp Key -> (Key, Builder)
reachAfter [Pointer]
ps =
let (Builder
decor, Key
finalCol, Bool
_) = (([Pointer], (Builder, Key, Bool))
-> Pointer -> (Builder, Key, Bool))
-> (Builder, Key, Bool) -> [Pointer] -> (Builder, Key, Bool)
forall a b. (([a], b) -> a -> b) -> b -> [a] -> b
paral
(\([Pointer]
rest, (Builder
xs, Key
c, Bool
isFirst)) p :: Pointer
p@(Pointer {Bool
Key
Maybe Body
pointerColEnd :: Pointer -> Key
pointerLabel :: Maybe Body
pointerConnect :: Bool
pointerColEnd :: Key
pointerColStart :: Key
pointerLine :: Key
pointerColStart :: Pointer -> Key
pointerLabel :: Pointer -> Maybe Body
pointerConnect :: Pointer -> Bool
pointerLine :: Pointer -> Key
..}) ->
let (Key
afterLen, Builder
afterText) = Key -> (Key, Builder)
reachAfter (Key
pointerColEnd Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
pointerColStart)
in
( [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Builder
xs
, Key -> Bool -> [Pointer] -> Builder
catchUp (Key
pointerColStart Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
c) Bool
isFirst (Pointer
pPointer -> [Pointer] -> [Pointer]
forall a. a -> [a] -> [a]
:[Pointer]
rest)
, Builder
afterText
]
, Key
pointerColStart Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
afterLen
, Bool
False
)
)
(Builder
"", Key
1, Bool
True)
[Pointer]
ps
in (Builder
decor, Key
finalCol)
paral :: (([a], b) -> a -> b) -> b -> [a] -> b
paral :: (([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
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 (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 :: Key -> Body -> Builder
replicateB Key
n Body
xs = Body -> Builder
TB.fromText (Key -> Body -> Body
T.replicate Key
n Body
xs)
{-# INLINE replicateB #-}