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
16 isExported, getLocalName, ltLexical,
18 -- PRINTERY AND FORCERY
19 Outputable(..), -- class
21 interppSP, interpp'SP,
24 ifPprShowAll, ifnotPprShowAll,
27 isOpLexeme, pprOp, pprNonOp,
28 isConop, isAconop, isAvarid, isAvarop
30 -- and to make the interface self-sufficient...
35 import PprStyle ( PprStyle(..) )
37 import Util ( cmpPString )
40 %************************************************************************
42 \subsection[NamedThing-class]{The @NamedThing@ class}
44 %************************************************************************
47 class NamedThing a where
48 getExportFlag :: a -> ExportFlag
49 isLocallyDefined :: a -> Bool
50 getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-})
51 getOccurrenceName :: a -> FAST_STRING
52 getInformingModules :: a -> [FAST_STRING]
53 getSrcLoc :: a -> SrcLoc
54 getItsUnique :: a -> Unique
55 fromPreludeCore :: a -> Bool
56 -- see also friendly functions that follow...
60 \item[@getExportFlag@:]
66 \item[@isLocallyDefined@:]
67 Whether the thing is defined in this module or not.
69 \item[@getOccurrenceName@:]
70 Gets the name by which a thing is known in this module (e.g., if
71 renamed, or whatever)...
73 \item[@getInformingModules@:]
74 Gets the name of the modules that told me about this @NamedThing@.
79 \item[@fromPreludeCore@:]
80 Tests a quite-delicate property: it is \tr{True} iff the entity is
81 actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
82 it is re-exported by \tr{PreludeCore}. See the @FullName@ type in
83 module \tr{NameTypes}.
85 NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test.
86 This is a bummer for types that are wired into the compiler.
89 Some functions to go with:
92 = case (getExportFlag a) of
96 getLocalName :: (NamedThing a) => a -> FAST_STRING
98 getLocalName = snd . getOrigName
100 #ifdef USE_ATTACK_PRAGMAS
101 {-# SPECIALIZE isExported :: Class -> Bool #-}
102 {-# SPECIALIZE isExported :: Id -> Bool #-}
103 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
104 {-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
108 @ltLexical@ is used for sorting things into lexicographical order, so
109 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
114 = BIND isLocallyDefined a _TO_ a_local ->
115 BIND isLocallyDefined b _TO_ b_local ->
116 BIND getOrigName a _TO_ (a_mod, a_name) ->
117 BIND getOrigName b _TO_ (b_mod, b_name) ->
118 if a_local || b_local then
119 a_name < b_name -- can't compare module names
121 case _CMP_STRING_ a_mod b_mod of
123 EQ_ -> a_name < b_name
127 #ifdef USE_ATTACK_PRAGMAS
128 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
129 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
130 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
134 %************************************************************************
136 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
138 %************************************************************************
140 The export flag @ExportAll@ means `export all there is', so there are
141 times when it is attached to a class or data type which has no
142 ops/constructors (if the class/type was imported abstractly). In
143 fact, @ExportAll@ is attached to everything except to classes/types
144 which are being {\em exported} abstractly, regardless of how they were
149 = ExportAll -- export with all constructors/methods
150 | ExportAbs -- export abstractly
154 %************************************************************************
156 \subsection[Outputable-class]{The @Outputable@ class}
158 %************************************************************************
161 class Outputable a where
162 ppr :: PprStyle -> a -> Pretty
166 -- the ppSep in the ppInterleave puts in the spaces
167 -- Death to ppSep! (WDP 94/11)
169 interppSP :: Outputable a => PprStyle -> [a] -> Pretty
170 interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs)
172 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
174 = ppInterleave sep (map (ppr sty) xs)
176 sep = ppBeside ppComma ppSP
178 #ifdef USE_ATTACK_PRAGMAS
179 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
180 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
182 {-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
183 {-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
184 {-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
185 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
186 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
187 {-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
192 ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil
193 ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil
194 ifPprInterface sty p = case sty of PprInterface -> p ; _ -> ppNil
196 ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
197 ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
200 These functions test strings to see if they fit the lexical categories
201 defined in the Haskell report. Normally applied as in, e.g.,
202 @isConop (getOccurrenceName foo)@... [just for pretty-printing]
205 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
209 | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
210 | otherwise = isUpper c || c == ':'
211 || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
218 | otherwise = c == ':'
224 | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
226 | isLowerISO c = True
235 | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
236 | isSymbolISO c = True
241 isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
242 isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
243 isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
246 And one ``higher-level'' interface to those:
249 isOpLexeme :: NamedThing a => a -> Bool
252 = let str = getOccurrenceName v in isAvarop str || isAconop str
254 -- print `vars`, (op) correctly
255 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
260 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
264 then ppBesides [ppLparen, ppr sty var, ppRparen]
267 #ifdef USE_ATTACK_PRAGMAS
268 {-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
269 {-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
270 {-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
271 {-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
276 instance Outputable Bool where
277 ppr sty True = ppPStr SLIT("True")
278 ppr sty False = ppPStr SLIT("False")
280 instance (Outputable a) => Outputable [a] where
282 ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
284 instance (Outputable a, Outputable b) => Outputable (a, b) where
286 ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
288 -- ToDo: may not be used
289 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
291 ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
292 ppBeside (ppr sty y) ppComma,
293 ppBeside (ppr sty z) ppRparen ]