ghc/lib/hbc/Pretty.hs

   1 module Pretty(text, separate, cseparate, nest, pretty, (~.), (^.), IText(..), Context(..)) where
   2
   3 infixr 8 ~.
   4 infixr 8 ^.
   5
   6 type IText   = Context -> [String]
   7 type Context = (Bool,Int,Int,Int)
   8 -- Bool         laying out in vertical context
   9 -- Int          character left on the line before margin is reached
  10 -- Int          maximum preferred number of significant characters on a line
  11 -- Int          number of characters on last line, excluding leading blanks
  12
  13 text :: String -> IText
  14 text s (v,w,m,m') = [s]
  15
  16 getContext t (v,w,m,m') =
  17         let tn = last t
  18             indent = length tn
  19             sig = if length t == 1
  20                   then m' + indent
  21                   else length (dropWhile (==' ') tn)
  22         in  (False,w-indent,m,sig)
  23
  24 (~.) :: IText -> IText -> IText
  25 d1 ~. d2 = \ c@(v,w,m,m') ->
  26         let t = d1 (False,w,m,m')
  27             cx@(_,w',_,_) = getContext t c
  28             indent = w-w'
  29             tn = last t
  30             (l:ls) = d2 cx
  31         in  init t ++
  32             [tn ++ l] ++
  33             map (space indent++) ls
  34
  35 space :: Int -> String
  36 space n = [' ' | i<-[1..n]]
  37
  38 (^.) :: IText -> IText -> IText
  39 d1 ^. d2 = \ (v,w,m,m') -> d1 (True,w,m,m') ++ d2 (True,w,m,0)
  40
  41 separate :: [IText] -> IText
  42 separate [] _ = [""]
  43 separate ds c@(v,w,m,m') =
  44         let hor = joinText (text " ") ds
  45             ver = foldr1 (^.) ds
  46             t = hor c
  47         in  if lengthLe t 1 && lengthLe (head t) ((w `min` (m-m')) `max` 0)
  48             then t
  49             else ver c
  50
  51 -- Try to put as many things as possible on each line.
  52 -- Inefficient!
  53 cseparate :: [IText] -> IText
  54 cseparate [] _ = [""]
  55 cseparate ds c@(v,w,m,m') =
  56         let csep r a (d:ds) =
  57                 let t = joinText (text " ") (a ++ [d]) c
  58                 in  if lengthLe t 1 then
  59                         if lengthLe (head t) ((w `min` (m-m')) `max` 0) then
  60                             csep r (a ++ [d]) ds
  61                         else
  62                             csep (r++adda a) [d] ds
  63                     else
  64                         csep (r ++ adda a ++ [d]) [] ds
  65             csep r a [] = r ++ adda a
  66             adda [] = []
  67             adda a = [joinText (text " ") a]
  68         in  foldr1 (^.) (csep [] [] ds) c
  69
  70 joinText t ds = foldr1 (\d1 d2 -> d1 ~. t ~. d2) ds
  71
  72 -- Check if the length of a list is less than n, without evaluating it completely.
  73 lengthLe :: [a] -> Int -> Bool
  74 lengthLe []     n = n >= 0
  75 lengthLe (_:_)  0 = False
  76 lengthLe (_:xs) n = lengthLe xs (n-1)
  77
  78 nest :: Int -> IText -> IText
  79 nest n d (v,w,m,m') =
  80         if v then
  81             map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n))
  82         else
  83             d (v,w,m,m')
  84
  85 pretty :: Int->Int->IText->String
  86 pretty w m d = unlines (d (False,w,m,0))