src/Literate/Box.hs

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