2 % (c) The GRASP Project, Glasgow University, 1992-1996
4 \section[Outputable]{Classes for pretty-printing}
6 Defines classes for pretty-printing and forcing, both forms of
10 #include "HsVersions.h"
14 NamedThing(..), -- class
17 getItsUnique, getOrigName, getOccName, getExportFlag,
18 getSrcLoc, isLocallyDefined, isPreludeDefined, isExported,
19 getLocalName, getOrigNameRdr, ltLexical,
21 -- PRINTERY AND FORCERY
22 Outputable(..), -- class
24 interppSP, interpp'SP,
27 ifPprShowAll, ifnotPprShowAll,
30 isOpLexeme, pprOp, pprNonOp,
31 isConop, isAconop, isAvarid, isAvarop
36 import Name ( nameUnique, nameOrigName, nameOccName,
37 nameExportFlag, nameSrcLoc,
38 isLocallyDefinedName, isPreludeDefinedName
40 import PprStyle ( PprStyle(..) )
42 import Util ( cmpPString )
45 %************************************************************************
47 \subsection[NamedThing-class]{The @NamedThing@ class}
49 %************************************************************************
52 class NamedThing a where
55 getItsUnique :: NamedThing a => a -> Unique
56 getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
57 getOccName :: NamedThing a => a -> RdrName
58 getExportFlag :: NamedThing a => a -> ExportFlag
59 getSrcLoc :: NamedThing a => a -> SrcLoc
60 isLocallyDefined :: NamedThing a => a -> Bool
61 isPreludeDefined :: NamedThing a => a -> Bool
63 getItsUnique = nameUnique . getName
64 getOrigName = nameOrigName . getName
65 getOccName = nameOccName . getName
66 getExportFlag = nameExportFlag . getName
67 getSrcLoc = nameSrcLoc . getName
68 isLocallyDefined = isLocallyDefinedName . getName
69 isPreludeDefined = isPreludeDefinedName . getName
72 = case (getExportFlag a) of
76 getLocalName :: (NamedThing a) => a -> FAST_STRING
77 getLocalName = snd . getOrigName
79 getOrigNameRdr :: (NamedThing a) => a -> RdrName
80 getOrigNameRdr n | isPreludeDefined n = Unqual str
81 | otherwise = Qual mod str
83 (mod,str) = getOrigName n
85 #ifdef USE_ATTACK_PRAGMAS
86 {-# SPECIALIZE isExported :: Class -> Bool #-}
87 {-# SPECIALIZE isExported :: Id -> Bool #-}
88 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
92 @ltLexical@ is used for sorting things into lexicographical order, so
93 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
98 = BIND isLocallyDefined a _TO_ a_local ->
99 BIND isLocallyDefined b _TO_ b_local ->
100 BIND getOrigName a _TO_ (a_mod, a_name) ->
101 BIND getOrigName b _TO_ (b_mod, b_name) ->
102 if a_local || b_local then
103 a_name < b_name -- can't compare module names
105 case _CMP_STRING_ a_mod b_mod of
107 EQ_ -> a_name < b_name
111 #ifdef USE_ATTACK_PRAGMAS
112 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
113 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
114 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
118 %************************************************************************
120 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
122 %************************************************************************
124 The export flag @ExportAll@ means `export all there is', so there are
125 times when it is attached to a class or data type which has no
126 ops/constructors (if the class/type was imported abstractly). In
127 fact, @ExportAll@ is attached to everything except to classes/types
128 which are being {\em exported} abstractly, regardless of how they were
133 = ExportAll -- export with all constructors/methods
134 | ExportAbs -- export abstractly
138 %************************************************************************
140 \subsection[Outputable-class]{The @Outputable@ class}
142 %************************************************************************
145 class Outputable a where
146 ppr :: PprStyle -> a -> Pretty
150 -- the ppSep in the ppInterleave puts in the spaces
151 -- Death to ppSep! (WDP 94/11)
153 interppSP :: Outputable a => PprStyle -> [a] -> Pretty
154 interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs)
156 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
158 = ppInterleave sep (map (ppr sty) xs)
160 sep = ppBeside ppComma ppSP
162 #ifdef USE_ATTACK_PRAGMAS
163 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
164 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
166 {-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
167 {-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
168 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
169 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
170 {-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
175 ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil
176 ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil
177 ifPprInterface sty p = case sty of PprInterface -> p ; _ -> ppNil
179 ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
180 ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
183 These functions test strings to see if they fit the lexical categories
184 defined in the Haskell report.
185 Normally applied as in e.g. @isConop (getLocalName foo)@
188 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
192 | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
193 | otherwise = isUpper c || c == ':'
194 || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
201 | otherwise = c == ':'
207 | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
209 | isLowerISO c = True
218 | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
219 | isSymbolISO c = True
224 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
225 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
226 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
229 And one ``higher-level'' interface to those:
232 isOpLexeme :: NamedThing a => a -> Bool
235 = let str = snd (getOrigName v) in isAvarop str || isAconop str
237 -- print `vars`, (op) correctly
238 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
243 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
247 then ppBesides [ppLparen, ppr sty var, ppRparen]
250 #ifdef USE_ATTACK_PRAGMAS
251 {-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
252 {-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
253 {-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
254 {-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
259 instance Outputable Bool where
260 ppr sty True = ppPStr SLIT("True")
261 ppr sty False = ppPStr SLIT("False")
263 instance (Outputable a) => Outputable [a] where
265 ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
267 instance (Outputable a, Outputable b) => Outputable (a, b) where
269 ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
271 -- ToDo: may not be used
272 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
274 ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
275 ppBeside (ppr sty y) ppComma,
276 ppBeside (ppr sty z) ppRparen ]