1 module Pretty ( 2 Pretty, 3 PprStyle(..), 4 ppNil, ppStr, ppChar, ppInt, ppInteger, ppDouble, 5 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, 6 ppSemi, ppComma, 7 8 ppCat, ppBeside, ppBesides, ppAbove, ppAboves, 9 ppNest, ppSep, ppHang, ppInterleave, 10 ppShow, ppUnformatted, 11 -- abstract type, to complete the interface... 12 PrettyRep 13 ) where 14 15 import CharSeq 16 17 ppNil :: Pretty 18 ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma :: Pretty 19 ppStr :: [Char] -> Pretty 20 ppChar :: Char -> Pretty 21 ppInt :: Int -> Pretty 22 ppInteger :: Integer -> Pretty 23 ppDouble :: Double -> Pretty 24 ppBeside :: Pretty -> Pretty -> Pretty 25 ppBesides :: [Pretty] -> Pretty 26 ppBesideSP :: Pretty -> Pretty -> Pretty 27 ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP 28 ppAbove :: Pretty -> Pretty -> Pretty 29 ppAboves :: [Pretty] -> Pretty 30 ppInterleave :: Pretty -> [Pretty] -> Pretty 31 ppSep :: [Pretty] -> Pretty 32 ppHang :: Pretty -> Int -> Pretty -> Pretty 33 ppNest :: Int -> Pretty -> Pretty 34 ppShow :: Int -> Pretty -> [Char] 35 ppUnformatted :: Pretty -> [Char] 36 type Pretty = Int -- The width to print in 37 -> Bool -- True => vertical context 38 -> PrettyRep 39 data PrettyRep 40 = MkPrettyRep CSeq -- The text 41 Int -- No of chars in last line 42 Bool -- True if empty object 43 Bool -- Fits on a single line in specified width 44 deriving () 45 ppShow width p 46 = cShow seq 47 where (MkPrettyRep seq ll emp sl) = p width False 48 {- !!! this seems to tickle an nhc bug (works w/ hbc) 49 = case (p width False) of 50 MkPrettyRep seq sl ll -> cShow seq 51 -} 52 53 ppUnformatted p 54 = cShow seq 55 where (MkPrettyRep seq ll emp sl) = p 80 False 56 -- ToDo: ppUnformatted doesn't do anything yet 57 ppNil width is_vert = MkPrettyRep cNil 0 True (width >= 0) 58 -- Doesn't fit if width < 0, otherwise, ppNil 59 -- will make ppBesides always return True. 60 61 ppStr s width is_vert = MkPrettyRep (cStr s) ls False (width >= ls) 62 where ls = length s 63 ppChar c width is_vert = MkPrettyRep (cCh c) 1 False (width >= 1) 64 ppInt n = ppStr (show n) 65 ppInteger n = ppStr (show n) 66 ppDouble n = ppStr (show n) 67 ppSP = ppChar ' ' 68 pp'SP = ppStr ", " 69 ppLbrack = ppChar '[' 70 ppRbrack = ppChar ']' 71 ppLparen = ppChar '(' 72 ppRparen = ppChar ')' 73 ppSemi = ppChar ';' 74 ppComma = ppChar ',' 75 ppInterleave sep ps = ppSep (pi ps) 76 where 77 pi [] = [] 78 pi [x] = [x] 79 pi (x:xs) = (ppBeside x sep) : pi xs 80 ppBeside p1 p2 width is_vert 81 = MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2)) 82 (ll1 + ll2) 83 (emp1 `andL` emp2) 84 ((width >= 0) `andL` (sl1 `andL` sl2)) 85 -- This sequence of andL's ensures that ppBeside 86 -- returns a False for sl as soon as possible. 87 where 88 MkPrettyRep seq1 ll1 emp1 sl1 = p1 width False 89 MkPrettyRep seq2 ll2 emp2 sl2 = p2 (width-ll1) False 90 -- ToDo: if emp{1,2} then we really 91 -- should be passing on "is_vert" to p{2,1}. 92 ppBesides [] = ppNil 93 ppBesides ps = foldr1 ppBeside ps 94 ppBesideSP p1 p2 width is_vert 95 = MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2))) 96 (li + ll2) 97 (emp1 `andL` emp2) 98 ((width >= wi) `andL` (sl1 `andL` sl2)) 99 where 100 MkPrettyRep seq1 ll1 emp1 sl1 = p1 width False 101 MkPrettyRep seq2 ll2 emp2 sl2 = p2 (width-li) False 102 li, wi :: Int 103 li = if emp1 then 0 else ll1+1 104 wi = if emp1 then 0 else 1 105 sp = if emp1 `orL` emp2 then cNil else (cCh ' ') 106 ppCat [] = ppNil 107 ppCat ps = foldr1 ppBesideSP ps 108 ppAbove p1 p2 width is_vert 109 = MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2)) 110 ll2 111 -- ToDo: make ll depend on empties? 112 (emp1 `andL` emp2) 113 False 114 where 115 nl = if emp1 `orL` emp2 then cNil else cNL 116 MkPrettyRep seq1 ll1 emp1 sl1 = p1 width True 117 MkPrettyRep seq2 ll2 emp2 sl2 = p2 width True 118 -- ToDo: ditto about passing is_vert if empties 119 ppAboves [] = ppNil 120 ppAboves ps = foldr1 ppAbove ps 121 ppNest n p width False = p width False 122 ppNest n p width True 123 = MkPrettyRep (cIndent n seq) (ll+n) emp sl 124 where 125 MkPrettyRep seq ll emp sl = p (width-n) True 126 ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could 127 -- be made with a little more effort. 128 -- Eg the output always starts with seq1 129 = if emp1 then 130 p2 width is_vert 131 else 132 if (ll1 <= n) `orL` sl2 then -- very ppBesideSP'ish 133 -- Hang it if p1 shorter than indent or if it doesn't fit 134 MkPrettyRep (seq1 `cAppend` (cCh ' ') `cAppend` (cIndent (ll1+1) seq2)) 135 (ll1 + 1 + ll2) 136 False 137 (sl1 `andL` sl2) 138 else 139 -- Nest it (pretty ppAbove-ish) 140 MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2'))) 141 ll2' -- ToDo: depend on empties 142 False 143 False 144 where 145 MkPrettyRep seq1 ll1 emp1 sl1 = p1 width False 146 MkPrettyRep seq2 ll2 emp2 sl2 = p2 (width-(ll1+1)) False 147 -- ToDo: more "is_vert if empty" stuff 148 149 MkPrettyRep seq2' ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True? 150 ppSep [] width is_vert = ppNil width is_vert 151 ppSep [p] width is_vert = p width is_vert 152 ppSep ps width is_vert 153 = if sl then 154 pr -- Fits on one line 155 else 156 ppAboves ps width is_vert -- Takes several lines 157 where 158 pr@(MkPrettyRep seq ll emp sl) = ppCat ps width is_vert 159 160 {- !!! suspected on same nhc-bug grounds 161 = case (ppBesides ps width is_vert) of 162 pr1@(MkPrettyRep seq1 sl1 ll1) -> 163 if (sl1 && ll1 <= width) then 164 pr1 -- Fits on one line 165 else 166 ppAboves ps width is_vert -- Takes several lines 167 -} 168 andL :: Bool -> Bool -> Bool 169 andL False x = False 170 andL True x = x 171 orL :: Bool -> Bool -> Bool 172 orL True x = True 173 orL False x = x 174 data PprStyle 175 = PprForUser -- Pretty-print in a way that will make sense 176 -- to the ordinary user; must be very close to Haskell 177 -- syntax, etc. 178 -- ToDo: how diff is this from what pprInterface must do? 179 | PprDebug -- Standard debugging output 180 | PprShowAll -- Debugging output which leaves nothing to the imagination 181 | PprInterface -- Interface generation