2 % (c) The GRASP Project, Glasgow University, 1992-1995
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
20 PprStyle(..), -- style-ry (re-exported)
22 interppSP, interpp'SP,
23 --UNUSED: ifPprForUser,
25 ifPprDebug, --UNUSED: ifnotPprDebug,
26 ifPprShowAll, ifnotPprShowAll,
27 ifPprInterface, --UNUSED: ifnotPprInterface,
28 --UNUSED: ifPprForC, ifnotPprForC,
29 --UNUSED: ifPprUnfolding, ifnotPprUnfolding,
31 isOpLexeme, pprOp, pprNonOp,
32 isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
34 -- and to make the interface self-sufficient...
35 Pretty(..), GlobalSwitch,
36 PrettyRep, UniType, Unique, SrcLoc
39 import AbsUniType ( UniType,
40 TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing
41 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
42 IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
43 IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
45 import Id ( Id ) -- for specialising
46 import NameTypes -- for specialising
47 import ProtoName -- for specialising
49 import SrcLoc ( SrcLoc )
50 import Unique ( Unique )
54 %************************************************************************
56 \subsection[NamedThing-class]{The @NamedThing@ class}
58 %************************************************************************
61 class NamedThing a where
62 getExportFlag :: a -> ExportFlag
63 isLocallyDefined :: a -> Bool
64 getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-})
65 getOccurrenceName :: a -> FAST_STRING
66 getInformingModules :: a -> [FAST_STRING]
67 getSrcLoc :: a -> SrcLoc
68 getTheUnique :: a -> Unique
70 getType :: a -> UniType
71 fromPreludeCore :: a -> Bool
72 -- see also friendly functions that follow...
76 \item[@getExportFlag@:]
82 \item[@isLocallyDefined@:]
83 Whether the thing is defined in this module or not.
85 \item[@getOccurrenceName@:]
86 Gets the name by which a thing is known in this module (e.g., if
87 renamed, or whatever)...
89 \item[@getInformingModules@:]
90 Gets the name of the modules that told me about this @NamedThing@.
95 \item[@hasType@ and @getType@:]
96 In pretty-printing @AbsSyntax@, we need to query if a datatype has
97 types attached yet or not. We use @hasType@ to see if there are types
98 available; and @getType@ if we want to grab one... (Ugly but effective)
100 \item[@fromPreludeCore@:]
101 Tests a quite-delicate property: it is \tr{True} iff the entity is
102 actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
103 it is re-exported by \tr{PreludeCore}. See the @FullName@ type in
104 module \tr{NameTypes}.
106 NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test.
107 This is a bummer for types that are wired into the compiler.
110 Some functions to go with:
113 = case (getExportFlag a) of
117 getLocalName :: (NamedThing a) => a -> FAST_STRING
119 getLocalName = snd . getOrigName
121 #ifdef USE_ATTACK_PRAGMAS
122 {-# SPECIALIZE isExported :: Class -> Bool #-}
123 {-# SPECIALIZE isExported :: Id -> Bool #-}
124 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
125 {-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
129 @ltLexical@ is used for sorting things into lexicographical order, so
130 as to canonicalize interfaces. [Regular @(<)@ should be used for fast
135 = BIND isLocallyDefined a _TO_ a_local ->
136 BIND isLocallyDefined b _TO_ b_local ->
137 BIND getOrigName a _TO_ (a_mod, a_name) ->
138 BIND getOrigName b _TO_ (b_mod, b_name) ->
139 if a_local || b_local then
140 a_name < b_name -- can't compare module names
142 case _CMP_STRING_ a_mod b_mod of
144 EQ_ -> a_name < b_name
148 #ifdef USE_ATTACK_PRAGMAS
149 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
150 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
151 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
155 %************************************************************************
157 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
159 %************************************************************************
161 The export flag @ExportAll@ means `export all there is', so there are
162 times when it is attached to a class or data type which has no
163 ops/constructors (if the class/type was imported abstractly). In
164 fact, @ExportAll@ is attached to everything except to classes/types
165 which are being {\em exported} abstractly, regardless of how they were
170 = ExportAll -- export with all constructors/methods
171 | ExportAbs -- export abstractly
175 %************************************************************************
177 \subsection[Outputable-class]{The @Outputable@ class}
179 %************************************************************************
182 class Outputable a where
183 ppr :: PprStyle -> a -> Pretty
187 -- the ppSep in the ppInterleave puts in the spaces
188 -- Death to ppSep! (WDP 94/11)
190 interppSP :: Outputable a => PprStyle -> [a] -> Pretty
191 interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs)
193 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
195 = ppInterleave sep (map (ppr sty) xs)
197 sep = ppBeside ppComma ppSP
199 #ifdef USE_ATTACK_PRAGMAS
200 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
201 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
203 {-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
204 {-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
205 {-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
206 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
207 {-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
208 {-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-}
213 --UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil
214 ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil
215 ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil
216 ifPprInterface sty p = case sty of PprInterface _ -> p ; _ -> ppNil
217 --UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil
218 --UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil
220 ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
221 --UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p
222 ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
223 --UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p
224 --UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p
225 --UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p
228 These functions test strings to see if they fit the lexical categories
229 defined in the Haskell report. Normally applied as in, e.g.,
230 @isConop (getOccurrenceName foo)@... [just for pretty-printing]
233 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
237 | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
238 | otherwise = isUpper c || c == ':'
244 isAconid ('_':cs) = isAconid cs
245 isAconid (c:cs) = isUpper c
250 | otherwise = c == ':'
256 | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
257 | otherwise = isLower c
263 | isLower c = False -- shortcut
264 | isUpper c = False -- ditto
265 | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
270 And one ``higher-level'' interface to those:
273 isOpLexeme :: NamedThing a => a -> Bool
276 = let str = getOccurrenceName v in isAvarop str || isAconop str
278 -- print `vars`, (op) correctly
279 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
284 else ppBesides [ppChar '`', ppr sty var, ppChar '`']
288 then ppBesides [ppLparen, ppr sty var, ppRparen]
291 #ifdef USE_ATTACK_PRAGMAS
292 {-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
293 {-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
294 {-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
295 {-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
300 instance Outputable Bool where
301 ppr sty True = ppPStr SLIT("True")
302 ppr sty False = ppPStr SLIT("False")
304 instance (Outputable a) => Outputable [a] where
306 ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
308 instance (Outputable a, Outputable b) => Outputable (a, b) where
310 ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
312 -- ToDo: may not be used
313 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
315 ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
316 ppBeside (ppr sty y) ppComma,
317 ppBeside (ppr sty z) ppRparen ]