Ppr.hs 24.5 KB
Newer Older
1
module GHCi.Haddock.Ppr
Aaron Allen's avatar
Aaron Allen committed
2
  ( pprHaddock
3
4
  ) where

Aaron Allen's avatar
Aaron Allen committed
5
import           Control.Monad
Aaron Allen's avatar
Aaron Allen committed
6
import           Data.Bitraversable
7
import           Data.Foldable
Aaron Allen's avatar
Aaron Allen committed
8
9
import qualified Data.Map.Strict as Map
import           Data.Maybe
10
import           Data.Sequence (Seq ((:<|), (:|>)), (<|), (><), (|>))
Aaron Allen's avatar
Aaron Allen committed
11
import qualified Data.Sequence as Seq
12
13
14
15
16
17
import           Prelude hiding ((<>))
import qualified Prelude as P

import           GHC.Utils.Outputable
import           GHC.Utils.Ppr.Colour
import qualified GHCi.Haddock.Markup as H
Aaron Allen's avatar
Aaron Allen committed
18
import qualified GHCi.Haddock.Parser as H
19
20
import qualified GHCi.Haddock.Types as H

Aaron Allen's avatar
Aaron Allen committed
21
22
23
pprHaddock :: String -> SDoc
pprHaddock = pprDocH . H.toRegular . H._doc . H.parseParas Nothing

Aaron Allen's avatar
Aaron Allen committed
24
25
pprDocH :: H.DocH mod String -> SDoc
pprDocH = builderToSDoc . ($ IgnoreLeadingWS) . H.markup builderMarkup
26
27

-- | A single line of output
Aaron Allen's avatar
Aaron Allen committed
28
29
data Line =
  Line
Aaron Allen's avatar
Aaron Allen committed
30
31
    { lineDoc :: !SDoc
    , lineLen :: !Int -- need line length for building tables
Aaron Allen's avatar
Aaron Allen committed
32
33
34
35
    }

joinLines :: Line -> Line -> Line
joinLines a b =
Aaron Allen's avatar
Aaron Allen committed
36
37
  Line { lineDoc = lineDoc a <> lineDoc b
       , lineLen = lineLen a + lineLen b
Aaron Allen's avatar
Aaron Allen committed
38
       }
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

-- | A grouping of lines. Blocks are separated by a blank line when printed
type Block = Seq Line

-- | The collection of blocks that make up the whole output
type Blocks = Seq Block

-- | A 'Monoid' for building the terminal output from a DocH
data Builder
  = Builder Blocks BreakMode
  | EmptyBuilder

instance Semigroup Builder where
  (<>) = combineBuilders
instance Monoid Builder where
  mempty = EmptyBuilder

-- | Indicates how one 'Builder' should be combined with another
data BreakMode
  = NoBreak
  | NewLine
  | NewBlock
  deriving Show

-- | Turns a 'Builder' into the resulting output 'SDoc'
builderToSDoc :: Builder -> SDoc
builderToSDoc EmptyBuilder = empty
builderToSDoc (Builder blocks _) =
  concatBlocks
Aaron Allen's avatar
Aaron Allen committed
68
    $ fmap (foldl' appendLine empty) (fmap lineDoc <$> blocks)
69
  where
Aaron Allen's avatar
Aaron Allen committed
70
    appendBlock = ($+$) . ($+$ text "")
71
72
73
74
75
76
77
78
79
80
    appendLine = ($+$)
    concatBlocks (first :<| rest) = foldl' appendBlock first rest
    concatBlocks _ = empty

combineBuilders :: Builder -> Builder -> Builder
combineBuilders EmptyBuilder b = b
combineBuilders b EmptyBuilder = b
combineBuilders (Builder xs xBr) (Builder ys yBr) =
  Builder (appendBlocks xBr xs ys) yBr

Aaron Allen's avatar
Aaron Allen committed
81
-- | Combine two groups of blocks according to a 'BreakMode'
82
83
84
85
86
87
88
89
90
91
92
--
-- - 'NoBreak' causes the inner two blocks to be merged by concating the two
--   innermost lines
-- - 'NewLine' Combines the two innermost blocks into a single block
-- - 'NewBlock' simply concatenates the two groups
appendBlocks :: BreakMode -> Blocks -> Blocks -> Blocks
appendBlocks NoBreak xs ys
  | xs'       :|> lstBlock  <- xs
  , lstBlock' :|> lstLine   <- lstBlock
  , fstBlock  :<| ys'       <- ys
  , fstLine   :<| fstBlock' <- fstBlock
Aaron Allen's avatar
Aaron Allen committed
93
  , let joinedLine     = joinLines lstLine fstLine
94
95
96
97
98
99
100
101
102
103
104
105
106
        joinedLstBlock = lstBlock' |> joinedLine
        leftBlocks     = xs' |> (joinedLstBlock >< fstBlock')
  = leftBlocks >< ys'
  | otherwise = xs >< ys
appendBlocks NewLine xs ys
  | xs'      :|> lstBlock <- xs
  , fstBlock :<| ys'      <- ys
  , let joinedLstBlock = lstBlock >< fstBlock
        leftBlocks     = xs' |> joinedLstBlock
  = leftBlocks >< ys'
  | otherwise = xs >< ys
appendBlocks NewBlock xs ys = xs >< ys

Aaron Allen's avatar
Aaron Allen committed
107
108
109
110
111
112
113
114
data StringOptions
  = IgnoreLeadingWS
  | KeepLeadingWS

-- | Set of instruction for translating 'DocH's into 'Builder's. The
-- 'StringOptions' argument is so we can use different ways of handling leading
-- whitespace for newlines depending on the context.
builderMarkup :: H.DocMarkupH mod String (StringOptions -> Builder)
115
116
117
118
builderMarkup =
  H.Markup
    { H.markupEmpty                = mempty
    , H.markupString               = fromString
Aaron Allen's avatar
Aaron Allen committed
119
    , H.markupParagraph            = \b _ -> setBreakMode NewBlock $ b IgnoreLeadingWS
120
    , H.markupAppend               = mappend
Aaron Allen's avatar
Aaron Allen committed
121
    , H.markupIdentifier           = pprIdentifier
122
    , H.markupIdentifierUnchecked  = mempty
Aaron Allen's avatar
Aaron Allen committed
123
    , H.markupModule               = pprModule
124
    , H.markupWarning              = id
Aaron Allen's avatar
Aaron Allen committed
125
126
127
128
129
130
131
132
    , H.markupEmphasis             = fmap $ mapDocs keyword
    , H.markupBold                 = fmap $ mapDocs keyword
    , H.markupMonospaced           = fmap $ mapDocs (coloured colWhiteFg)
    , H.markupUnorderedList        = pprUnorderedList
    , H.markupOrderedList          = pprOrderedList
    , H.markupDefList              = pprDefList
    , H.markupCodeBlock            = pprCodeBlock
    , H.markupHyperlink            = pprHyperlink
133
134
135
136
137
    , H.markupAName                = fromString
    , H.markupPic                  = mempty
    , H.markupMathInline           = fromString
    , H.markupMathDisplay          = fromString
    , H.markupProperty             = fromString
Aaron Allen's avatar
Aaron Allen committed
138
139
140
    , H.markupExample              = pprExample
    , H.markupHeader               = \(H.Header _ inner) o -> mapDocs keyword (inner o)
    , H.markupTable                = \t _ -> pprTable $ fmap ($ KeepLeadingWS) t
141
142
143
144
145
146
    }

mapLines :: (Line -> Line) -> Builder -> Builder
mapLines _ EmptyBuilder = EmptyBuilder
mapLines f (Builder blocks br) = Builder (fmap (fmap f) blocks) br

Aaron Allen's avatar
Aaron Allen committed
147
148
149
150
151
152
153
mapDocs :: (SDoc -> SDoc) -> Builder -> Builder
mapDocs f = mapLines f' where
  f' (Line d l) = Line (f d) l -- should not change length

setBreakMode :: BreakMode -> Builder -> Builder
setBreakMode _ EmptyBuilder = EmptyBuilder
setBreakMode br (Builder blocks _) = Builder blocks br
154
155

wrap :: String -> Blocks
Aaron Allen's avatar
Aaron Allen committed
156
wrap str = pure . pure $ Line (text str) (length str)
157
158

-- | Convert a string to a builder, respecting newlines
Aaron Allen's avatar
Aaron Allen committed
159
160
161
fromString :: String -> StringOptions -> Builder
fromString "" _ = mempty
fromString xs opts
162
163
  | (s, '\n':rest) <- break (== '\n') xs
  , let bldr = Builder (wrap s) NewLine
Aaron Allen's avatar
Aaron Allen committed
164
165
166
        rBldr = case opts of
                  IgnoreLeadingWS -> fromString (dropWhile (== ' ') rest) opts
                  KeepLeadingWS -> fromString rest opts
167
168
169
170
  = bldr `mappend` rBldr
  | otherwise
  = Builder (wrap xs) NoBreak

Aaron Allen's avatar
Aaron Allen committed
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
pprIdentifier :: String -> StringOptions -> Builder
pprIdentifier str opts = mapDocs (coloured colLightBlueFg)
                       $ fromString str opts

pprModule :: String -> StringOptions -> Builder
pprModule str _ = mapDocs (coloured colLightGreenFg) $ Builder (wrap str) NoBreak

pprHyperlink :: H.Hyperlink (StringOptions -> Builder) -> StringOptions -> Builder
pprHyperlink (H.Hyperlink url mbBldr) opt =
  mconcat
  [ case mbBldr of
      Just bldr -> bldr opt `mappend` Builder (wrap " ") NoBreak
      Nothing -> mempty
  , Builder (wrap $ "(" ++ url ++ ")") NoBreak
  ]

pprUnorderedList :: [StringOptions -> Builder] -> StringOptions -> Builder
pprUnorderedList items
  = setBreakMode NewBlock . foldMap unorderedListItem
  . sequence items

192
unorderedListItem :: Builder -> Builder
Aaron Allen's avatar
Aaron Allen committed
193
194
195
196
197
198
unorderedListItem = listItem "•"

pprOrderedList :: [StringOptions -> Builder] -> StringOptions -> Builder
pprOrderedList items
  = setBreakMode NewBlock . foldMap orderedListItem . zip [1..]
  . sequence items
199
200
201

orderedListItem :: (Int, Builder) -> Builder
orderedListItem (i, builder) = listItem label builder
Aaron Allen's avatar
Aaron Allen committed
202
203
  where label = show i ++ "."

Aaron Allen's avatar
Aaron Allen committed
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
pprDefList :: [(StringOptions -> Builder, StringOptions -> Builder)]
           -> StringOptions -> Builder
pprDefList defs
  = setBreakMode NewBlock . foldMap definition
  . traverse bisequence defs

definition :: (Builder, Builder) -> Builder
definition (definiendum, definiens) =
  setBreakMode NewLine $
    setBreakMode NewLine definiendum
      `mappend` mapLines indent definiens

pprCodeBlock :: (StringOptions -> Builder) -> StringOptions -> Builder
pprCodeBlock builder _
  = setBreakMode NewBlock . mapDocs (coloured colWhiteFg) $ builder KeepLeadingWS

Aaron Allen's avatar
Aaron Allen committed
220
221
indent :: Line -> Line
indent (Line d l) = Line (nest 2 d) (l + 2)
222
223
224

-- | Prefix the first line of the first block with a given label. All other
-- lines are indented.
Aaron Allen's avatar
Aaron Allen committed
225
listItem :: String -> Builder -> Builder
226
227
228
229
230
231
232
233
234
235
listItem _ EmptyBuilder = EmptyBuilder
listItem label (Builder blocks _) = Builder itemBlock NewLine
  where
    itemBlock
      | fstBlock :<| blocks'   <- blocks
      , fstLine  :<| fstBlock' <- fstBlock
      , let labeledFstBlock = addLabel fstLine <| fmap indent fstBlock'
            tailBlocks      = fmap (fmap indent) blocks'
      = labeledFstBlock <| tailBlocks
      | otherwise = blocks
Aaron Allen's avatar
Aaron Allen committed
236
    addLabel (Line d l) = Line (text label <+> d) (l + length label + 1)
237

Aaron Allen's avatar
Aaron Allen committed
238
239
pprExample :: [H.Example] -> StringOptions -> Builder
pprExample exs _ = setBreakMode NewBlock $ foldMap exampleBuilder exs
240
241
242

exampleBuilder :: H.Example -> Builder
exampleBuilder (H.Example expr res) =
Aaron Allen's avatar
Aaron Allen committed
243
244
  let sdoc = text "λ>" <+> text expr
      exprBldr = Builder (pure . pure . Line sdoc $! length expr + 3) NewLine
Aaron Allen's avatar
Aaron Allen committed
245
      resBldr  = foldMap (setBreakMode NewLine . flip fromString IgnoreLeadingWS) res
Aaron Allen's avatar
Aaron Allen committed
246
247
248
249
250
251
   in mapDocs (coloured colWhiteFg) $ exprBldr `mappend` resBldr

--------------------------------------------------------------------------------
-- Tables
--------------------------------------------------------------------------------

Aaron Allen's avatar
Aaron Allen committed
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
{-
Note [Rendering Tables]
~~~~~~~~~~~~~~~~~~~~~~~
Tables present the greatest complexity for pretty printing haddocks, the main
reason being that table cells can span multiple rows or columns. 'TableCell's
that span across rows only appear in the row where they first occur, so that
the next 'TableRow' won't have a cell in that column position. To account for
this, the implementation used here keeps track of a list of the row spanning
cells extending from previous rows along with their column index. This way if
the index of the column being looked at matches a spanning cell, we utilize
that cell rather than looking at the next cell in the row.
-}

type ColWidth = Int
type ColIdx = Int
type ColSpan = Int
type RowSpan = Int

-- | Identifies a cell that spans multiple rows/columns by the index of the
-- starting column, index of the ending column, and the number of rows spanned.
type CellSpan = (ColIdx, ColIdx, RowSpan)

-- | Used to collect the position and width of a cell to aide in calculating
-- the overall width of each column.
data CellSize =
  CellSize
    { endCol :: !ColIdx
    , startCol :: !ColIdx
    , cellWidth :: !Int
    } deriving Show
Aaron Allen's avatar
Aaron Allen committed
282

Aaron Allen's avatar
Aaron Allen committed
283
pprTable :: H.Table Builder -> Builder
Aaron Allen's avatar
Aaron Allen committed
284
pprTable tbl@(H.Table header body) =
Aaron Allen's avatar
Aaron Allen committed
285
  Builder (Seq.singleton . Seq.fromList $ (`Line` tableWidth) <$> lns) NewBlock
Aaron Allen's avatar
Aaron Allen committed
286
  where
Aaron Allen's avatar
Aaron Allen committed
287
288
    colWidths = columnWidths tbl
    lns =
Aaron Allen's avatar
Aaron Allen committed
289
      doRows
Aaron Allen's avatar
Aaron Allen committed
290
        ( (Just <$> header) `zip` reverse (True : replicate (length header - 1) False)
Aaron Allen's avatar
Aaron Allen committed
291
292
       ++ (Just <$> body) `zip` repeat False
        )
Aaron Allen's avatar
Aaron Allen committed
293
294

    doRows rows = resultLines []
Aaron Allen's avatar
Aaron Allen committed
295
      where
Aaron Allen's avatar
Aaron Allen committed
296
        (_, resultLines) =
Aaron Allen's avatar
Aaron Allen committed
297
          foldl' go ([], id)
Aaron Allen's avatar
Aaron Allen committed
298
299
300
301
302
303
304
305
306
            $ zip ((Nothing, False) : rows) (rows ++ [(Nothing, False)])

        go :: ([(CellSpan, Builder)], [SDoc] -> [SDoc])
           -> ((Maybe (H.TableRow Builder), Bool), (Maybe (H.TableRow Builder), Bool))
           -> ([(CellSpan, Builder)], [SDoc] -> [SDoc])
        go (spans, ls) ((mbPrevR, isHeader), (mbNextR, _)) =
          let (spans', divSDoc) =
                pprDivider isHeader colWidths mbPrevR mbNextR spans
              (spans'', newLines)
Aaron Allen's avatar
Aaron Allen committed
307
                | Just r <- mbNextR
Aaron Allen's avatar
Aaron Allen committed
308
309
310
                = pprRow colWidths r spans'
                | otherwise = (spans', [])
           in (spans'', ls . ((divSDoc : newLines) ++))
Aaron Allen's avatar
Aaron Allen committed
311
312
313

    tableWidth = sum colWidths + length colWidths + 1

Aaron Allen's avatar
Aaron Allen committed
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
-- | Calculate the width of each column in the table.
columnWidths :: H.Table Builder -> [ColWidth]
columnWidths (H.Table header body) = colLength (header ++ body)
  where
    colLength :: [H.TableRow Builder] -> [ColWidth]
    colLength = scanColWidths 0 1 . snd . foldl' folder ([], [])

    folder :: ([(ColIdx, (RowSpan, ColSpan))], [[CellSize]])
           -> H.TableRow Builder
           -> ([(ColIdx, (RowSpan, ColSpan))], [[CellSize]])
    folder (spans, csizes) row = (: csizes) <$> measureRow spans row

    -- Produce a list of cell sizes for a row
    measureRow :: [(ColIdx, (RowSpan, ColSpan))] -> H.TableRow Builder
               -> ([(ColIdx, (RowSpan, ColSpan))], [CellSize])
    measureRow spanCells (H.TableRow cs) = go 0 spanCells cs where
      go :: ColIdx
         -> [(ColIdx, (RowSpan, ColSpan))]
         -> [H.TableCell Builder]
         -> ([(ColIdx, (RowSpan, ColSpan))], [CellSize])
      go ci ((si, (rowSpan, colSpan)) : spans) cells
        | ci == si
        , let (spans', cells') = go (ci + colSpan) spans cells
              spans'' | rowSpan > 1 = (si, (rowSpan - 1, colSpan)) : spans'
                      | otherwise = spans'
        = (spans'', cells')
      go ci spans (tc : tailCells) =
        let c = CellSize
                  { endCol = ci + H.tableCellColspan tc
                  , startCol = ci
                  , cellWidth =
                      case H.tableCellContents tc of
                        EmptyBuilder -> 0
                        Builder blocks _ ->
                          foldl' max 0 . fmap lineLen $ join blocks
                  }
            (spans', cells') = go (ci + H.tableCellColspan tc) spans tailCells
            spans'' | H.tableCellRowspan tc > 1
                    = (ci, (H.tableCellRowspan tc - 1, H.tableCellColspan tc)) : spans'
                    | otherwise = spans'
         in (spans'', c : cells')
      go _ _ _ = ([], [])

    -- Consume the rows of cell sizes from left to right to find the column
    -- width for each column.
    scanColWidths :: ColWidth -> ColIdx -> [[CellSize]] -> [ColWidth]
    scanColWidths _ _ [] = []
    scanColWidths prevColWidth i rows = findMaxColumn
                                      . fmap (filter (not . null))
                                      . unzip $ map popColumn rows
      where
        -- Given the column widths for each row, determine the max width, then
        -- recurse over the remaining columns.
        findMaxColumn :: ([Maybe ColWidth], [[CellSize]]) -> [ColWidth]
        findMaxColumn (widths, next) =
          let colWidth = foldl' max 0 (catMaybes widths)
           in colWidth : scanColWidths colWidth (i + 1) next

        -- Finds the width of the i'th column in a row if there is a cell
        -- starting at that column index. Also returns the remaing cells in the
        -- row, having subtracted the previous column width if the cell started
        -- at a previous column.
        popColumn :: [CellSize] -> (Maybe ColWidth, [CellSize])
        popColumn [] = (Nothing, [])
        popColumn (c:cs)
          | endCol c == i
          , let w | startCol c == i - 1 = cellWidth c
                  | otherwise = cellWidth c - prevColWidth - 1 -- minus 1 for the border
          = (Just w, cs)
          | otherwise =
            let newWidth | startCol c == i - 1 = cellWidth c
                         | otherwise = cellWidth c - prevColWidth - 1
                c' = c { cellWidth = newWidth }
             in (Nothing, c' : cs)
Aaron Allen's avatar
Aaron Allen committed
388

Aaron Allen's avatar
Aaron Allen committed
389
390
-- | Render the cell contents within a row
pprRow :: [ColWidth]
Aaron Allen's avatar
Aaron Allen committed
391
       -> H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
392
393
       -> [(CellSpan, Builder)]
       -> ([(CellSpan, Builder)], [SDoc])
Aaron Allen's avatar
Aaron Allen committed
394
395
pprRow colWidths row ss =
  let (resCells, resSpans, lineSDocs) =
Aaron Allen's avatar
Aaron Allen committed
396
        foldr (\_ (cells, spans, lns) ->
Aaron Allen's avatar
Aaron Allen committed
397
                let (cells', spans', line) = go 0 cells spans colWidths
Aaron Allen's avatar
Aaron Allen committed
398
                 in (cells', spans', (tblFrame (char '│') <> line) : lns)
Aaron Allen's avatar
Aaron Allen committed
399
400
401
402
403
404
              )
              (H.tableRowCells row, ss, [])
              [1 .. rowLines]
   in (nextSpans 0 resCells resSpans, reverse lineSDocs)

  where
Aaron Allen's avatar
Aaron Allen committed
405
    go :: ColIdx
Aaron Allen's avatar
Aaron Allen committed
406
       -> [H.TableCell Builder]
Aaron Allen's avatar
Aaron Allen committed
407
408
409
       -> [(CellSpan, Builder)]
       -> [ColWidth]
       -> ([H.TableCell Builder], [(CellSpan, Builder)], SDoc)
Aaron Allen's avatar
Aaron Allen committed
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
    go i cells (((si, se, sd), b) : spans) ws
      | i == si
      , let (widths, nxtWidths) = splitAt (se - si) ws
            width = sum widths + length widths - 1
            (mbLn, b') = popLine b
            ln = pad width mbLn
            (cells', spans', sdoc) = go se cells spans nxtWidths
      = ( cells'
        , ((si, se, sd), b') : spans'
        , ln <> (tblFrame (char '│') <> sdoc)
        )
    go i (c : cells) spans ws =
      let colSpan = H.tableCellColspan c
          (widths, nxtWidths) = splitAt colSpan ws
          width = sum widths + length widths - 1
          (mbLine, bldr) = popLine (H.tableCellContents c)
          ln = pad width mbLine
          c' = c { H.tableCellContents = bldr }
          (cells', spans', sdoc) = go (i + colSpan) cells spans nxtWidths
       in ( c' : cells'
          , spans'
          , ln <> (tblFrame (char '│') <> sdoc)
          )
    go _ _ _ _ = ([], [], empty)

Aaron Allen's avatar
Aaron Allen committed
435
    pad :: ColWidth -> Maybe Line -> SDoc
Aaron Allen's avatar
Aaron Allen committed
436
437
438
439
440
441
    pad width (Just (Line d l)) = d <> spaces
      where spaces = text $ replicate (width - l) ' '
    pad width _ = text $ replicate width ' '

    rowLines = numRowLines row ss

Aaron Allen's avatar
Aaron Allen committed
442
    -- determine the cell span info to be passed to the next row
Aaron Allen's avatar
Aaron Allen committed
443
444
445
446
447
448
449
450
451
452
453
454
455
456
    nextSpans i cells (((si, se, sd), b) : spans)
      | i == si
      , let spans' = nextSpans se cells spans
      = ((si, se, sd - 1), b) : spans'
    nextSpans i (c : cells) spans =
      let rowSpan = H.tableCellRowspan c
          colSpan = H.tableCellColspan c
          spans' = nextSpans (i + colSpan) cells spans
          newSpans | rowSpan > 1
                   = ((i, i + colSpan, rowSpan - 1), H.tableCellContents c) : spans'
                   | otherwise = spans'
       in newSpans
    nextSpans _ _ _ = []

Aaron Allen's avatar
Aaron Allen committed
457
-- | Determines how many lines are in a row
Aaron Allen's avatar
Aaron Allen committed
458
numRowLines :: H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
459
            -> [(CellSpan, Builder)]
Aaron Allen's avatar
Aaron Allen committed
460
461
462
463
464
465
466
467
468
            -> Int
numRowLines (H.TableRow cells) spans =
  let spanBldr = snd <$> filter (\((_, _, sd), _) -> sd == 1) spans
      cellBldr =
        H.tableCellContents <$> filter (\c -> H.tableCellRowspan c == 1) cells
      bldrLines EmptyBuilder = 0
      bldrLines (Builder blocks _) = length (join blocks) + length blocks - 1 -- account for empty lines between blocks
   in foldl' max 0 (bldrLines <$> spanBldr ++ cellBldr)

Aaron Allen's avatar
Aaron Allen committed
469
470
471
-- | Removes the first line from the first block of a builder and returns it
-- along with the new builder. If the first block is empty, it is removed and
-- a blank line is returned.
Aaron Allen's avatar
Aaron Allen committed
472
473
474
popLine :: Builder -> (Maybe Line, Builder)
popLine EmptyBuilder = (Nothing, EmptyBuilder)
popLine (Builder blocks br)
Aaron Allen's avatar
Aaron Allen committed
475
476
  | fstBlock :<| blocks'   <- blocks
  , fstLine  :<| fstBlock' <- fstBlock
Aaron Allen's avatar
Aaron Allen committed
477
478
479
480
481
482
  = (Just fstLine, Builder (fstBlock' <| blocks') br)
  | fstBlock :<| blocks' <- blocks
  , null fstBlock
  = (Just (Line (text "") 0), Builder blocks' br)
  | otherwise = (Nothing, EmptyBuilder)

Aaron Allen's avatar
Aaron Allen committed
483
-- | Forms the border along the top of the table
Aaron Allen's avatar
Aaron Allen committed
484
topBorder :: H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
485
486
          -> [ColWidth]
          -> SDoc
Aaron Allen's avatar
Aaron Allen committed
487
topBorder (H.TableRow cs) = go 0 cs where
Aaron Allen's avatar
Aaron Allen committed
488
  go :: ColIdx -> [H.TableCell Builder] -> [ColWidth] -> SDoc
Aaron Allen's avatar
Aaron Allen committed
489
490
491
492
493
494
495
  go !i (c : cells) widths =
    let colSpan = H.tableCellColspan c
        (ws, widths') = splitAt colSpan widths
        width = sum ws + length ws - 1
        frame = tblFrame . text $ replicate width '─'
        divider | i == 0 = tblFrame $ char '┌'
                | otherwise = tblFrame $ char '┬'
Aaron Allen's avatar
Aaron Allen committed
496
497
498
        rest = go (i + 1) cells widths'
     in divider <> frame <> rest
  go _ _ _ = tblFrame $ char '┐'
Aaron Allen's avatar
Aaron Allen committed
499

Aaron Allen's avatar
Aaron Allen committed
500
-- | Forms the border along the bottom of the table
Aaron Allen's avatar
Aaron Allen committed
501
bottomBorder :: H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
502
503
             -> [ColWidth]
             -> [(CellSpan, Builder)]
Aaron Allen's avatar
Aaron Allen committed
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
             -> SDoc
bottomBorder (H.TableRow cs) = go 0 cs where
  go i cells widths (((si, se, _), _) : spans)
    | i == si
    , let (ws, widths') = splitAt (se - si) widths
          width = sum ws + length ws - 1
          divider | i == 0 = tblFrame $ char '└'
                  | otherwise = tblFrame $ char '┴'
          frame = tblFrame . text $ replicate width '─'
          rest = go se cells widths' spans
    = divider <> frame <> rest
  go i (c : cells) widths spans =
    let colSpan = H.tableCellColspan c
        (ws, widths') = splitAt colSpan widths
        width = sum ws + length ws - 1
        divider | i == 0 = tblFrame $ char '└'
                | otherwise = tblFrame $ char '┴'
        frame = tblFrame . text $ replicate width '─'
        rest = go (i + colSpan) cells widths' spans
     in divider <> frame <> rest
  go _ _ _ _ = tblFrame $ char '┘'

Aaron Allen's avatar
Aaron Allen committed
526
527
528
529
530
531
532
533
-- | Renders the table frame characters dividing the rows of cells or forming
-- the top and bottom of the table.
pprDivider :: Bool -- True <=> divides header from body
           -> [ColWidth]
           -> Maybe (H.TableRow Builder) -- previous row
           -> Maybe (H.TableRow Builder) -- next row
           -> [(CellSpan, Builder)]
           -> ([(CellSpan, Builder)], SDoc)
Aaron Allen's avatar
Aaron Allen committed
534
pprDivider isHeader colWidths (Just prevRow) (Just nextRow) spans =
Aaron Allen's avatar
Aaron Allen committed
535
  let dividers = buildDividers prevRow nextRow spans
Aaron Allen's avatar
Aaron Allen committed
536
537
   in pprDivider' isHeader colWidths dividers
pprDivider _ colWidths Nothing (Just nextRow) _ =
Aaron Allen's avatar
Aaron Allen committed
538
  ([], topBorder nextRow colWidths)
Aaron Allen's avatar
Aaron Allen committed
539
540
541
542
543
pprDivider _ colWidths (Just prevRow) Nothing spans =
  ([], bottomBorder prevRow colWidths spans)
pprDivider _ _ Nothing Nothing _ = ([], empty)

pprDivider' :: Bool -- True <=> divides header from body
Aaron Allen's avatar
Aaron Allen committed
544
545
546
            -> [ColWidth]
            -> [Divider]
            -> ([(CellSpan, Builder)], SDoc)
Aaron Allen's avatar
Aaron Allen committed
547
548
549
pprDivider' isHeader = go False where
  go True _ [] = ([], tblFrame $ if isHeader then char '╡' else char '┤')
  go False _ [] = ([], tblFrame $ char '│')
Aaron Allen's avatar
Aaron Allen committed
550
551
  go splitOnLeft widths (divider:divs) =
    case divider of
Aaron Allen's avatar
Aaron Allen committed
552
      DivAbove n ->
Aaron Allen's avatar
Aaron Allen committed
553
        let (width, widths') = getCellWidth widths n
Aaron Allen's avatar
Aaron Allen committed
554
555
556
557
558
            d | isHeader = char '╧'
              | otherwise = char '┴'
            (spans, rest) = go True widths' divs
         in (spans, buildFrame d width <> rest)
      DivBelow n ->
Aaron Allen's avatar
Aaron Allen committed
559
        let (width, widths') = getCellWidth widths n
Aaron Allen's avatar
Aaron Allen committed
560
561
562
563
564
            d | isHeader = char '╤'
              | otherwise = char '┬'
            (spans, rest) = go True widths' divs
         in (spans, buildFrame d width <> rest)
      DivBoth n ->
Aaron Allen's avatar
Aaron Allen committed
565
        let (width, widths') = getCellWidth widths n
Aaron Allen's avatar
Aaron Allen committed
566
567
568
569
570
            d | splitOnLeft = if isHeader then char '╪' else char '┼'
              | otherwise = if isHeader then char '╞' else char '├'
            (spans, rest) = go True widths' divs
         in (spans, buildFrame d width <> rest)
      DivNeither ((si, se, sd), b) ->
Aaron Allen's avatar
Aaron Allen committed
571
        let (width, widths') = getCellWidth widths (se - si)
Aaron Allen's avatar
Aaron Allen committed
572
573
574
575
576
577
578
579
            d | splitOnLeft = tblFrame $ char '┤'
              | otherwise = tblFrame $ char '│'
            (mbLn, b') = popLine b
            ln = pad width mbLn
            (spans, rest) = go False widths' divs
         in ( ((si, se, sd), b') : spans
            , d <> ln <> rest
            )
Aaron Allen's avatar
Aaron Allen committed
580
581
  getCellWidth ws n = let (w, ws') = splitAt n ws
                       in (sum w + length w - 1, ws')
Aaron Allen's avatar
Aaron Allen committed
582
583
584
585
586
587
588
589
  buildFrame d w = tblFrame
                 $ d <> text (replicate w $ if isHeader then '═' else '─')

  pad :: Int -> Maybe Line -> SDoc
  pad width (Just (Line d l)) = d <> spaces
    where spaces = text $ replicate (width - l) ' '
  pad width _ = text $ replicate width ' '

Aaron Allen's avatar
Aaron Allen committed
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
-- | Used when rendering horizontal dividers in the table
data Divider
  = DivAbove ColSpan -- ^ Cell division in previous row
  | DivBelow ColSpan -- ^ Cell division in next row
  | DivBoth ColSpan -- ^ Cell division in both rows
  | DivNeither (CellSpan, Builder) -- ^ A cell spans across the divider

buildDividers :: H.TableRow Builder
              -> H.TableRow Builder
              -> [(CellSpan, Builder)]
              -> [Divider]
buildDividers prevRow nextRow spans =
  let above = dividerTop prevRow spans
      below = dividerBottom nextRow spans
      neither = dividerNeither spans
      am = Map.fromList [ (i, DivAbove a) | (i, a) <- above ]
      bm = Map.fromList [ (i, DivBelow b) | (i, b) <- below ]
      nm = Map.fromList [ (si, DivNeither n) | n@((si,_,_),_) <- neither ]
      combine (DivAbove a) (DivBelow b) = DivBoth $ min a b
      combine x _ = x
      abm = Map.unionWith combine am bm

   in Map.elems $ Map.union nm abm
Aaron Allen's avatar
Aaron Allen committed
613
614

dividerTop :: H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
615
616
617
618
619
           -> [(CellSpan, Builder)]
           -> [(ColIdx, ColSpan)]
dividerTop (H.TableRow cells) = go 0 (filter notSpan cells) where
  notSpan c = H.tableCellRowspan c == 1 -- span cells are covered already
  go i cs (((si, se, sd), _) : spans)
Aaron Allen's avatar
Aaron Allen committed
620
    | i == si
Aaron Allen's avatar
Aaron Allen committed
621
    , let rest = go se cs spans
Aaron Allen's avatar
Aaron Allen committed
622
    = if sd == 0 then (si, se - si) : rest else rest
Aaron Allen's avatar
Aaron Allen committed
623
  go i (c : cs) spans =
Aaron Allen's avatar
Aaron Allen committed
624
625
626
    let colSpan = H.tableCellColspan c
        rowSpan = H.tableCellRowspan c
        endI = i + colSpan
Aaron Allen's avatar
Aaron Allen committed
627
        rest = go endI cs spans
Aaron Allen's avatar
Aaron Allen committed
628
629
630
631
632
633
     in if rowSpan > 1
           then rest
           else (i, colSpan) : rest
  go _ _ _ = []

dividerBottom :: H.TableRow Builder
Aaron Allen's avatar
Aaron Allen committed
634
635
              -> [(CellSpan, Builder)]
              -> [(ColIdx, ColSpan)]
Aaron Allen's avatar
Aaron Allen committed
636
dividerBottom (H.TableRow cells) = go 0 cells where
Aaron Allen's avatar
Aaron Allen committed
637
  go i cs (((si, se, sd), _) : spans)
Aaron Allen's avatar
Aaron Allen committed
638
639
    | i == si
    , sd > 0
Aaron Allen's avatar
Aaron Allen committed
640
641
    = go se cs spans
  go i (c : cs) spans =
Aaron Allen's avatar
Aaron Allen committed
642
643
    let colSpan = H.tableCellColspan c
        endI = i + colSpan
Aaron Allen's avatar
Aaron Allen committed
644
        rest = go endI cs spans
Aaron Allen's avatar
Aaron Allen committed
645
646
647
     in (i, colSpan) : rest
  go _ _ _ = []

Aaron Allen's avatar
Aaron Allen committed
648
649
dividerNeither :: [(CellSpan, Builder)]
               -> [(CellSpan, Builder)]
Aaron Allen's avatar
Aaron Allen committed
650
651
652
dividerNeither = filter neitherSpan where
  neitherSpan ((_, _, sd), _) = sd > 0

Aaron Allen's avatar
Aaron Allen committed
653
-- | Styling for table frame characters
Aaron Allen's avatar
Aaron Allen committed
654
655
656
tblFrame :: SDoc -> SDoc
tblFrame = coloured colCyanFg