1 -- this is from ghc/syslib-ghc originally, 2 -- but i made some changes, marked by ??????? 3 4 5 6 7 module Pretty ( 8 9 10 Pretty, 11 12 ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger, 13 ppFloat, ppDouble, 14 15 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, 16 ppSemi, ppComma, ppEquals, 17 ppBracket, ppParens, ppQuote, 18 19 ppBesideSP, -- this wasn't exported originally, why ??????????? 20 21 ppCat, ppBeside, ppBesides, ppAbove, ppAboves, 22 ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, 23 ppShow, speakNth, 24 25 26 27 -- abstract type, to complete the interface... 28 PrettyRep(..), Delay 29 ) where 30 31 32 import Ratio 33 34 35 import CharSeq 36 37 ppNil :: Pretty 38 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty 39 40 ppStr :: [Char] -> Pretty 41 ppPStr :: String -> Pretty 42 ppChar :: Char -> Pretty 43 ppInt :: Int -> Pretty 44 ppInteger :: Integer -> Pretty 45 ppDouble :: Double -> Pretty 46 ppFloat :: Float -> Pretty 47 ppRational :: Rational -> Pretty 48 49 ppBracket :: Pretty -> Pretty -- put brackets around it 50 ppParens :: Pretty -> Pretty -- put parens around it 51 52 ppBeside :: Pretty -> Pretty -> Pretty 53 ppBesides :: [Pretty] -> Pretty 54 ppBesideSP :: Pretty -> Pretty -> Pretty 55 ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP 56 57 ppAbove :: Pretty -> Pretty -> Pretty 58 ppAboves :: [Pretty] -> Pretty 59 60 ppInterleave :: Pretty -> [Pretty] -> Pretty 61 ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep 62 ppSep :: [Pretty] -> Pretty 63 ppHang :: Pretty -> Int -> Pretty -> Pretty 64 ppNest :: Int -> Pretty -> Pretty 65 66 ppShow :: Int -> Pretty -> [Char] 67 68 69 70 type Pretty = Int -- The width to print in 71 -> Bool -- True => vertical context 72 -> PrettyRep 73 74 data PrettyRep 75 = MkPrettyRep CSeq -- The text 76 (Delay Int) -- No of chars in last line 77 Bool -- True if empty object 78 Bool -- Fits on a single line in specified width 79 80 data Delay a = MkDelay a 81 82 forceDel (MkDelay _) r = r 83 84 forceBool True r = r 85 forceBool False r = r 86 87 forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r)) 88 89 ppShow width p 90 = case (p width False) of 91 MkPrettyRep seq ll emp sl -> cShow seq 92 93 94 95 ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0) 96 -- Doesn't fit if width < 0, otherwise, ppNil 97 -- will make ppBesides always return True. 98 99 ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) 100 where ls = length s 101 ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls) 102 where ls = length s 103 ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1) 104 105 ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) 106 where s = show n; ls = length s 107 108 ppInteger n = ppStr (show n) 109 ppDouble n = ppStr (show n) 110 ppFloat n = ppStr (show n) 111 112 ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n) 113 114 ppSP = ppChar ' ' 115 pp'SP = ppStr ", " 116 ppLbrack = ppChar '[' 117 ppRbrack = ppChar ']' 118 ppLparen = ppChar '(' 119 ppRparen = ppChar ')' 120 ppSemi = ppChar ';' 121 ppComma = ppChar ',' 122 ppEquals = ppChar '=' 123 124 ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack) 125 ppParens p = ppBeside ppLparen (ppBeside p ppRparen) 126 ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\'')) 127 128 ppInterleave sep ps = ppSep (pi ps) 129 where 130 pi [] = [] 131 pi [x] = [x] 132 pi (x:xs) = (ppBeside x sep) : pi xs 133 134 ppIntersperse sep ps = ppBesides (pi ps) 135 where 136 pi [] = [] 137 pi [x] = [x] 138 pi (x:xs) = (ppBeside x sep) : pi xs 139 140 ppBeside p1 p2 width is_vert 141 = case (p1 width False) of 142 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> 143 MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2)) 144 (MkDelay (ll1 + ll2)) 145 (emp1 && emp2) 146 ((width >= 0) && (sl1 && sl2)) 147 -- This sequence of (&&)'s ensures that ppBeside 148 -- returns a False for sl as soon as possible. 149 where -- NB: for case alt 150 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 151 MkDelay ll2 = x_ll2 152 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False 153 -- ToDo: if emp{1,2} then we really 154 -- should be passing on "is_vert" to p{2,1}. 155 156 ppBesides [] = ppNil 157 ppBesides ps = foldr1 ppBeside ps 158 159 ppBesideSP p1 p2 width is_vert 160 = case (p1 width False) of 161 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> 162 MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2))) 163 (MkDelay (li + ll2)) 164 (emp1 && emp2) 165 ((width >= wi) && (sl1 && sl2)) 166 where -- NB: for case alt 167 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 168 MkDelay ll2 = x_ll2 169 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False 170 li, wi :: Int 171 li = if emp1 then 0 else ll1+1 172 wi = if emp1 then 0 else 1 173 sp = if emp1 || emp2 then cNil else (cCh ' ') 174 175 ppCat [] = ppNil 176 ppCat ps = foldr1 ppBesideSP ps 177 178 ppAbove p1 p2 width is_vert 179 = case (p1 width True) of 180 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> 181 MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2)) 182 (MkDelay ll2) 183 -- ToDo: make ll depend on empties? 184 (emp1 && emp2) 185 False 186 where -- NB: for case alt 187 nl = if emp1 || emp2 then cNil else cNL 188 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 189 MkDelay ll2 = x_ll2 -- Don't "optimise" this away! 190 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True 191 -- ToDo: ditto about passing is_vert if empties 192 193 ppAboves [] = ppNil 194 ppAboves ps = foldr1 ppAbove ps 195 196 ppNest n p width False = p width False 197 ppNest n p width True 198 = case (p (width-n) True) of 199 MkPrettyRep seq (MkDelay ll) emp sl -> 200 MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl 201 202 ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could 203 -- be made with a little more effort. 204 -- Eg the output always starts with seq1 205 = case (p1 width False) of 206 MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> 207 if emp1 then 208 p2 width is_vert 209 else 210 if (ll1 <= n) || sl2 then -- very ppBesideSP'ish 211 -- Hang it if p1 shorter than indent or if it doesn't fit 212 MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2))) 213 (MkDelay (ll1 + 1 + ll2)) 214 False 215 (sl1 && sl2) 216 else 217 -- Nest it (pretty ppAbove-ish) 218 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2'))) 219 (MkDelay ll2') -- ToDo: depend on empties 220 False 221 False 222 where -- NB: for case alt 223 seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 224 MkDelay ll2 = x_ll2 225 MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False 226 -- ToDo: more "is_vert if empty" stuff 227 228 seq2' = forceInfo x_ll2' emp2' sl2' x_seq2' 229 MkDelay ll2' = x_ll2' -- Don't "optimise" this away! 230 MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True? 231 232 ppSep [] width is_vert = ppNil width is_vert 233 ppSep [p] width is_vert = p width is_vert 234 235 236 {- 237 -- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable 238 -- ppSep [a, ppSep[b, ppSep [c, ... ]]] 239 240 ppSep ps width is_vert 241 = case (ppCat ps width is_vert) of 242 MkPrettyRep seq x_ll emp sl -> 243 if sl then -- Fits on one line 244 MkPrettyRep seq x_ll emp sl 245 else 246 ppAboves ps width is_vert -- Takes several lines 247 -} 248 249 -- a different attempt: 250 ppSep ps @ (p : q : qs) width is_vert = 251 let (as, bs) = splitAt (length ps `div` 2) ps 252 in 253 case (ppSep as width False, ppSep bs width False) of 254 ( MkPrettyRep seq1 x_ll1 emp1 sl1 , MkPrettyRep seq2 x_ll2 emp2 sl2 ) -> 255 if {- sl1 && -} sl2 && (ll1 + ll2 < width) 256 then MkPrettyRep 257 (seq1 `cAppend` (cCh ' ' `cAppend` (cIndent (ll1 + 1) seq2))) 258 (MkDelay (ll1 + 1 + ll2)) 259 (emp1 && emp2) 260 sl1 261 else MkPrettyRep 262 (seq1 `cAppend` (cNL `cAppend` seq2)) 263 x_ll2 264 (emp1 && emp2) 265 False 266 where MkDelay ll1 = x_ll1; MkDelay ll2 = x_ll2 267 268 269 270 271 speakNth :: Int -> Pretty 272 273 speakNth 1 = ppStr "first" 274 speakNth 2 = ppStr "second" 275 speakNth 3 = ppStr "third" 276 speakNth 4 = ppStr "fourth" 277 speakNth 5 = ppStr "fifth" 278 speakNth 6 = ppStr "sixth" 279 speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ] 280 where 281 st_nd_rd_th | n_rem_10 == 1 = "st" 282 | n_rem_10 == 2 = "nd" 283 | n_rem_10 == 3 = "rd" 284 | otherwise = "th" 285 286 n_rem_10 = n `rem` 10 287 288 289 290 -- from Lennart 291 fromRationalX :: (RealFloat a) => Rational -> a 292 293 fromRationalX = error "Pretty.fromRationalX" 294 {- 295 fromRationalX r = 296 let 297 h = ceiling (huge `asTypeOf` x) 298 b = toInteger (floatRadix x) 299 x = fromRat 0 r 300 fromRat e0 r' = 301 let d = denominator r' 302 n = numerator r' 303 in if d > h then 304 let e = integerLogBase b (d `div` h) + 1 305 in fromRat (e0-e) (n % (d `div` (b^e))) 306 else if abs n > h then 307 let e = integerLogBase b (abs n `div` h) + 1 308 in fromRat (e0+e) ((n `div` (b^e)) % d) 309 else 310 scaleFloat e0 (fromRational r') 311 in x 312 -} 313 314 -- Compute the discrete log of i in base b. 315 -- Simplest way would be just divide i by b until it's smaller then b, but that would 316 -- be very slow! We are just slightly more clever. 317 integerLogBase :: Integer -> Integer -> Int 318 integerLogBase b i = 319 if i < b then 320 0 321 else 322 -- Try squaring the base first to cut down the number of divisions. 323 let l = 2 * integerLogBase (b*b) i 324 325 doDiv :: Integer -> Int -> Int 326 doDiv j k = if j < b then k else doDiv (j `div` b) (k+1) 327 in 328 doDiv (i `div` (b^l)) l 329 330 331 ------------ 332 333 -- Compute smallest and largest floating point values. 334 {- 335 tiny :: (RealFloat a) => a 336 tiny = 337 let (l, _) = floatRange x 338 x = encodeFloat 1 (l-1) 339 in x 340 -} 341 342 huge :: (RealFloat a) => a 343 huge = 344 undefined 345 {- 346 let (_, u) = floatRange x 347 d = floatDigits x 348 x = encodeFloat (floatRadix x ^ d - 1) (u - d) 349 in x 350 -}