src/Literate/Box.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 {- |
   4  Module      :  Text.PrettyPrint.Boxes
   5  Copyright   :  (c) Brent Yorgey 2009
   6  License     :  BSD-style (see LICENSE)
   7  Maintainer  :  David.Feuer@gmail.com
   8  Stability   :  experimental
   9  Portability :  portable
  10
  11  A pretty-printing library for laying out text in two dimensions,
  12  using a simple box model.
  13 -}
  14 module Literate.Box where
  15
  16 import Control.Arrow (first, (***))
  17 import Data.Foldable (toList)
  18 import Data.List (foldl', intersperse)
  19 import Data.String (IsString (..))
  20 import Prelude hiding (Word, (<>))
  21
  22 -- Use the build from GHC.Exts because GHC has some rules that make it faster.
  23 import GHC.Exts (build)
  24
  25 {- | The basic data type.  A box has a specified size and some sort of
  26    contents.
  27 -}
  28 data Box = Box
  29   { rows :: Int
  30   , cols :: Int
  31   , content :: Content
  32   }
  33   deriving (Show)
  34
  35 -- | Contents of a box.
  36 data Content
  37   = -- | No content.
  38     Blank
  39   | -- | A raw string.
  40     Text String
  41   | -- | A row of sub-boxes.
  42     Row [Box]
  43   | -- | A column of sub-boxes.
  44     Col [Box]
  45   | -- | A sub-box with a specified alignment.
  46     SubBox Alignment Alignment Box
  47   deriving (Show)
  48
  49 instance IsString Box where
  50   fromString t = Box 1 (length t) (Text t)
  51
  52 -- | Data type for specifying the alignment of boxes.
  53 data Alignment
  54   = -- | Align at the top/left.
  55     AlignTopLeft
  56   | -- | Centered, biased to the top/left.
  57     AlignTopLeftCenter
  58   | -- | Centered, biased to the bottom/right.
  59     AlignBottomRightCenter
  60   | -- | Align at the bottom/right.
  61     AlignBottomRight
  62   deriving (Eq, Read, Show)
  63
  64 {- | The null box, which has no content and no size.  It is quite
  65    useless.
  66 -}
  67 nullBox :: Box
  68 nullBox = emptyBox 0 0
  69
  70 {- | @emptyBox r c@ is an empty box with @r@ rows and @c@ columns.
  71    Useful for effecting more fine-grained positioning of other
  72    boxes, by inserting empty boxes of the desired size in between
  73    them.
  74 -}
  75 emptyBox :: Int -> Int -> Box
  76 emptyBox r c = Box r c Blank
  77
  78 -- | A @1x1@ box containing a single character.
  79 char :: Char -> Box
  80 char c = Box 1 1 (Text [c])
  81
  82 {- | Paste two boxes together horizontally, using a default (top)
  83    alignment.
  84 -}
  85 (<>) :: Box -> Box -> Box
  86 l <> r = hcat AlignTopLeft [l, r]
  87
  88 {- | Paste two boxes together horizontally with a single intervening
  89    column of space, using a default (top) alignment.
  90 -}
  91 (<+>) :: Box -> Box -> Box
  92 l <+> r = hcat AlignTopLeft [l, emptyBox 0 1, r]
  93
  94 {- | Paste two boxes together vertically, using a default (left)
  95    alignment.
  96 -}
  97 (//) :: Box -> Box -> Box
  98 t // b = vcat AlignTopLeft [t, b]
  99
 100 {- | Paste two boxes together vertically with a single intervening row
 101    of space, using a default (left) alignment.
 102 -}
 103 (/+/) :: Box -> Box -> Box
 104 t /+/ b = vcat AlignTopLeft [t, emptyBox 1 0, b]
 105
 106 -- | Glue a list of boxes together horizontally, with the given alignment.
 107 hcat :: Foldable f => Alignment -> f Box -> Box
 108 hcat a bs = Box h w (Row $ map (alignVert a h) bsl)
 109  where
 110   (w, h) = sumMax cols 0 rows bsl
 111   bsl = toList bs
 112
 113 {- | @hsep sep a bs@ lays out @bs@ horizontally with alignment @a@,
 114    with @sep@ amount of space in between each.
 115 -}
 116 hsep :: Foldable f => Int -> Alignment -> f Box -> Box
 117 hsep sep a bs = punctuateH a (emptyBox 0 sep) bs
 118
 119 -- | Glue a list of boxes together vertically, with the given alignment.
 120 vcat :: Foldable f => Alignment -> f Box -> Box
 121 vcat a bs = Box h w (Col $ map (alignHoriz a w) bsl)
 122  where
 123   (h, w) = sumMax rows 0 cols bsl
 124   bsl = toList bs
 125
 126 -- Calculate a sum and a maximum over a list in one pass. If the list is
 127 -- empty, the maximum is reported as the given default. This would
 128 -- normally be done using the foldl library, but we don't want that
 129 -- dependency.
 130 sumMax :: (Num n, Ord b, Foldable f) => (a -> n) -> b -> (a -> b) -> f a -> (n, b)
 131 sumMax f defaultMax g as = foldr go (,) as 0 defaultMax
 132  where
 133   go a r n b = (r $! f a + n) $! g a `max` b
 134
 135 {- | @vsep sep a bs@ lays out @bs@ vertically with alignment @a@,
 136    with @sep@ amount of space in between each.
 137 -}
 138 vsep :: Foldable f => Int -> Alignment -> f Box -> Box
 139 vsep sep a bs = punctuateV a (emptyBox sep 0) (toList bs)
 140
 141 {- | @punctuateH a p bs@ horizontally lays out the boxes @bs@ with a
 142    copy of @p@ interspersed between each.
 143 -}
 144 punctuateH :: Foldable f => Alignment -> Box -> f Box -> Box
 145 punctuateH a p bs = hcat a (intersperse p (toList bs))
 146
 147 -- | A vertical version of 'punctuateH'.
 148 punctuateV :: Foldable f => Alignment -> Box -> f Box -> Box
 149 punctuateV a p bs = vcat a (intersperse p (toList bs))
 150
 151 --------------------------------------------------------------------------------
 152 --  Paragraph flowing  ---------------------------------------------------------
 153 --------------------------------------------------------------------------------
 154
 155 {- | @para algn w t@ is a box of width @w@, containing text @t@,
 156    aligned according to @algn@, flowed to fit within the given
 157    width.
 158 >>> para AlignTopLeft 10 "12 34 56 78 9 10 11 12"
 159 Box {rows = 3, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 3, cols = 10, content = Col
 160 [Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 8, content = Text "12 34 56"})}
 161 ,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 10, content = Text "78 9 10 11"})}
 162 ,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 2, content = Text "12"})}]})}
 163 -}
 164 para :: Alignment -> Int -> String -> Box
 165 para a n t = (\ss -> mkParaBox a (length ss) ss) $ flow n t
 166
 167 {- | @columns w h t@ is a list of boxes, each of width @w@ and height
 168    at most @h@, containing text @t@ flowed into as many columns as
 169    necessary.
 170 >>> error $ render $ hcat AlignTopLeft $ columns AlignTopLeft 10 5 "1 2 3 4 5 6 7 8 9 10 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29"
 171 1 2 3 4 5 21 22 23
 172 6 7 8 9 1024 25 26
 173 12 13 14  27 28 29
 174 15 16 17
 175 18 19 20
 176 -}
 177 columns :: Alignment -> Int -> Int -> String -> [Box]
 178 columns a w h t = map (mkParaBox a h) . chunksOf h $ flow w t
 179
 180 {- | @'chunksOf' n@ splits a list into length-n pieces.  The last
 181    piece will be shorter if @n@ does not evenly divide the length of
 182    the list.  If @n <= 0@, @'chunksOf' n l@ returns an infinite list
 183    of empty lists.  For example:
 184
 185    Note that @'chunksOf' n []@ is @[]@, not @[[]]@.  This is
 186    intentional, and is consistent with a recursive definition of
 187    'chunksOf'; it satisfies the property that
 188
 189    @chunksOf n xs ++ chunksOf n ys == chunksOf n (xs ++ ys)@
 190
 191    whenever @n@ evenly divides the length of @xs@.
 192 -}
 193 chunksOf :: Int -> [e] -> [[e]]
 194 chunksOf i ls = map (take i) (build (splitter ls))
 195  where
 196   splitter :: [e] -> ([e] -> a -> a) -> a -> a
 197   splitter [] _ n = n
 198   splitter l c n = l `c` splitter (drop i l) c n
 199
 200 {- | @mkParaBox a n s@ makes a box of height @n@ with the text @s@
 201    aligned according to @a@.
 202 -}
 203 mkParaBox :: Alignment -> Int -> [String] -> Box
 204 mkParaBox a n = alignVert AlignTopLeft n . vcat a . map fromString
 205
 206 {- | Flow the given text into the given width.
 207 >>> flow 10 "1234567890abc abcdefghijkl"
 208 ["1234567890","abcdefghij"]
 209
 210 >>> flow 10 "1234567890abcdefghij"
 211 ["1234567890"]
 212 -}
 213 flow :: Int -> String -> [String]
 214 flow n t =
 215   (take n <$>) . getLines $
 216   foldl' addWordP (emptyPara n) (fromString <$> words t)
 217
 218 -- * Type 'Para'
 219 data Para = Para
 220   { paraWidth :: Int
 221   , unPara :: ParaContent
 222   }
 223 data ParaContent = ParaContent
 224   { paraLines :: [Line]
 225   , paraLastLine :: Line
 226   }
 227
 228 emptyPara :: Int -> Para
 229 emptyPara pw = Para pw (ParaContent [] (Line 0 []))
 230
 231 getLines :: Para -> [String]
 232 getLines (Para _ (ParaContent ls l))
 233   | lineLen l == 0 = process ls
 234   | otherwise = process (l : ls)
 235  where
 236   process = map (unwords . reverse . map unWord . unLine) . reverse
 237 -- ** Type 'Line'
 238 data Line = Line
 239   { lineLen :: Int
 240   , unLine :: [Word]
 241   }
 242
 243 mkLine :: [Word] -> Line
 244 mkLine ws = Line (sum (map ((+ 1) . wordLen) ws) - 1) ws
 245
 246 startLine :: Word -> Line
 247 startLine = mkLine . (: [])
 248
 249 -- ** Type 'Word
 250 data Word = Word
 251   { wordLen :: Int
 252   , unWord :: String
 253   }
 254
 255 instance IsString Word where
 256   fromString w = Word (length w) w
 257
 258 addWordP :: Para -> Word -> Para
 259 addWordP (Para pw (ParaContent fl l)) w
 260   | wordFits pw w l = Para pw (ParaContent fl (addWordL w l))
 261   | otherwise = Para pw (ParaContent (l : fl) (startLine w))
 262
 263 addWordL :: Word -> Line -> Line
 264 addWordL w (Line len ws) = Line (len + wordLen w + 1) (w : ws)
 265
 266 wordFits :: Int -> Word -> Line -> Bool
 267 wordFits pw w l = lineLen l == 0 || lineLen l + wordLen w + 1 <= pw
 268
 269 --------------------------------------------------------------------------------
 270 --  Alignment  -----------------------------------------------------------------
 271 --------------------------------------------------------------------------------
 272
 273 {- | @alignHoriz algn n bx@ creates a box of width @n@, with the
 274    contents and height of @bx@, horizontally aligned according to
 275    @algn@.
 276 -}
 277 alignHoriz :: Alignment -> Int -> Box -> Box
 278 alignHoriz a c b = align a AlignTopLeft (rows b) c b
 279
 280 {- | @alignVert algn n bx@ creates a box of height @n@, with the
 281    contents and width of @bx@, vertically aligned according to
 282    @algn@.
 283 >>> error $ render $ alignVert AlignTopLeft 4 "123"
 284 123
 285
 286
 287
 288
 289 >>> error $ render $ alignVert AlignBottomRight 4 "123"
 290
 291
 292
 293 123
 294
 295 -}
 296 -- | >>> error $ render $ alignVert AlignBottomRightCenter 4 "123"
 297 --
 298 --
 299 -- 123
 300 --
 301 --
 302 --
 303 -- 123
 304 --
 305 -- | >>> error $ render $ alignVert AlignTopLeftCenter 4 "123"
 306 --
 307 -- 123
 308 --
 309 --
 310
 311 alignVert :: Alignment -> Int -> Box -> Box
 312 alignVert a r b = align AlignTopLeft a r (cols b) b
 313
 314 {- | @align ah av r c bx@ creates an @r@ x @c@ box with the contents
 315    of @bx@, aligned horizontally according to @ah@ and vertically
 316    according to @av@.
 317 -}
 318 align :: Alignment -> Alignment -> Int -> Int -> Box -> Box
 319 align ah av r c = Box r c . SubBox ah av
 320
 321 {- | Move a box \"up\" by putting it in a larger box with extra rows,
 322    aligned to the top.  See the disclaimer for 'moveLeft'.
 323 -}
 324 moveUp :: Int -> Box -> Box
 325 moveUp n b = alignVert AlignTopLeft (rows b + n) b
 326
 327 {- | Move a box down by putting it in a larger box with extra rows,
 328    aligned to the bottom.  See the disclaimer for 'moveLeft'.
 329 -}
 330 moveDown :: Int -> Box -> Box
 331 moveDown n b = alignVert AlignBottomRight (rows b + n) b
 332
 333 {- | Move a box left by putting it in a larger box with extra columns,
 334    aligned left.  Note that the name of this function is
 335    something of a white lie, as this will only result in the box
 336    being moved left by the specified amount if it is already in a
 337    larger right-aligned context.
 338
 339 >>> error $ render $ moveLeft 4 "123"
 340 123
 341
 342 >>> error $ render $ alignHoriz AlignBottomRight 20 $ moveLeft 15 "123"
 343   123
 344
 345 >>> error $ render $ alignHoriz AlignTopLeft 10 $ moveLeft 15 "123"
 346 123
 347
 348 -}
 349 moveLeft :: Int -> Box -> Box
 350 moveLeft n b = alignHoriz AlignTopLeft (cols b + n) b
 351
 352 {- | Move a box right by putting it in a larger box with extra
 353    columns, aligned right.  See the disclaimer for 'moveLeft'.
 354
 355 >>> error $ render $ moveRight 4 "123"
 356     123
 357 -}
 358 moveRight :: Int -> Box -> Box
 359 moveRight n b = alignHoriz AlignBottomRight (cols b + n) b
 360
 361 --------------------------------------------------------------------------------
 362 --  Implementation  ------------------------------------------------------------
 363 --------------------------------------------------------------------------------
 364
 365 {- | Render a 'Box' as a String, suitable for writing to the screen or
 366    a file.
 367 -}
 368 render :: Box -> String
 369 render = unlines . renderBox
 370
 371 -- XXX make QC properties for takeExactly
 372
 373 {- | \"Padded take\": @takeExactly a n xs@ is the same as @take n xs@, if @n
 374    <= length xs@; otherwise it is @xs@ followed by enough copies of
 375    @a@ to make the length equal to @n@.
 376 -}
 377 takeExactly :: a -> Int -> [a] -> [a]
 378 takeExactly _ n _ | n <= 0 = []
 379 takeExactly pad n [] = replicate n pad
 380 takeExactly pad n (x : xs) = x : takeExactly pad (n - 1) xs
 381
 382 {- | @takeExactlyAligned @ is like 'takeExactly', but with alignment.  That is, we
 383    imagine a copy of @xs@ extended infinitely on both sides with
 384    copies of @a@, and a window of size @n@ placed so that @xs@ has
 385    the specified alignment within the window; @takeExactlyAligned algn a n xs@
 386    returns the contents of this window.
 387 >>> takeExactlyAligned AlignTopLeft ' ' 10 "12345"
 388 "12345     "
 389
 390 >>> takeExactlyAligned AlignBottomRight ' ' 10 "12345"
 391 "     12345"
 392
 393 >>> takeExactlyAligned AlignTopLeftCenter ' ' 10 "12345"
 394 "  12345   "
 395
 396 >>> takeExactlyAligned AlignBottomRightCenter ' ' 10 "12345"
 397 "   12345  "
 398 -}
 399 takeExactlyAligned :: Alignment -> a -> Int -> [a] -> [a]
 400 takeExactlyAligned ali pad len l =
 401   reverse (takeExactly pad (leftLen ali len) (reverse leftList))
 402     ++ takeExactly pad (rightLen ali len) rightList
 403  where
 404   (leftList, rightList) = splitAt (leftLen ali (length l)) l
 405
 406   rightLen AlignTopLeft n = n
 407   rightLen AlignTopLeftCenter n = n `div` 2
 408   rightLen AlignBottomRight _ = 0
 409   rightLen AlignBottomRightCenter n = (n + 1) `div` 2
 410
 411   leftLen a n = n - rightLen a n
 412
 413 -- | Generate a string of spaces.
 414 blanks :: Int -> String
 415 blanks = flip replicate ' '
 416
 417 -- | Render a box as a list of lines.
 418 renderBox :: Box -> [String]
 419 renderBox (Box r c Blank) = resizeBox r c [""]
 420 renderBox (Box r c (Text t)) = resizeBox r c [t]
 421 renderBox (Box r c (Row bs)) =
 422   resizeBox r c $ merge $ (\b -> renderBox b{rows=r}) <$> bs
 423  where
 424   merge = foldr (zipWith (++)) (repeat [])
 425 renderBox (Box r c (Col bs)) =
 426   resizeBox r c $ concatMap (\b -> renderBox b{cols=c}) bs
 427 renderBox (Box r c (SubBox ha va b)) =
 428   takeExactlyAligned va (blanks c) r $
 429   takeExactlyAligned ha ' ' c <$> renderBox b
 430
 431 {- | Resize a rendered list of lines.
 432 >>> resizeBox 5 4 ["1 2 3 4 5 6 7 8 9", "10 11 12 13 14 15 16 17 18 19"]
 433 ["1 2 ","10 1","    ","    ","    "]
 434 -}
 435 resizeBox :: Int -> Int -> [String] -> [String]
 436 resizeBox rowLen colLen ls =
 437   takeExactly (blanks colLen) rowLen $
 438   takeExactly ' ' colLen <$> ls
 439
 440 -- | A convenience function for rendering a box to stdout.
 441 printBox :: Box -> IO ()
 442 printBox = putStr . render
 443
 444 {- >>> error $ render $ ("123" // "4") <+> ("toto" <+> "foo" // "titi") <+> "bar"
 445 123 toto foo bar
 446 4   titi
 447
 448 -}
 449
 450 {-
 451 -- | Align boxes along their tops.
 452 top :: Alignment
 453 top = AlignFirst
 454
 455 -- | Align boxes along their bottoms.
 456 bottom :: Alignment
 457 bottom = AlignBottomRight
 458
 459 -- | Align boxes to the left.
 460 left :: Alignment
 461 left = AlignFirst
 462
 463 -- | Align boxes to the right.
 464 right :: Alignment
 465 right = AlignBottomRight
 466
 467 {- | Align boxes centered, but biased to the left/top in case of
 468    unequal parities.
 469 -}
 470 center1 :: Alignment
 471 center1 = AlignTopLeftCenter
 472
 473 {- | Align boxes centered, but biased to the right/bottom in case of
 474    unequal parities.
 475 -}
 476 center2 :: Alignment
 477 center2 = AlignBottomRightCenter
 478 -}