ghc/compiler/utils/Outputable.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1996
   3 %
   4 \section[Outputable]{Classes for pretty-printing}
   5
   6 Defines classes for pretty-printing and forcing, both forms of
   7 ``output.''
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module Outputable (
  13         -- NAMED-THING-ERY
  14         NamedThing(..),         -- class
  15         ExportFlag(..),
  16         isExported, getLocalName, ltLexical,
  17
  18         -- PRINTERY AND FORCERY
  19         Outputable(..),         -- class
  20
  21         interppSP, interpp'SP,
  22         ifnotPprForUser,
  23         ifPprDebug,
  24         ifPprShowAll, ifnotPprShowAll,
  25         ifPprInterface,
  26
  27         isOpLexeme, pprOp, pprNonOp,
  28         isConop, isAconop, isAvarid, isAvarop
  29
  30         -- and to make the interface self-sufficient...
  31     ) where
  32
  33 import Ubiq{-uitous-}
  34
  35 import PprStyle         ( PprStyle(..) )
  36 import Pretty
  37 import Util             ( cmpPString )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection[NamedThing-class]{The @NamedThing@ class}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 \begin{code}
  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...
  57 \end{code}
  58
  59 \begin{description}
  60 \item[@getExportFlag@:]
  61 Obvious.
  62
  63 \item[@getOrigName@:]
  64 Obvious.
  65
  66 \item[@isLocallyDefined@:]
  67 Whether the thing is defined in this module or not.
  68
  69 \item[@getOccurrenceName@:]
  70 Gets the name by which a thing is known in this module (e.g., if
  71 renamed, or whatever)...
  72
  73 \item[@getInformingModules@:]
  74 Gets the name of the modules that told me about this @NamedThing@.
  75
  76 \item[@getSrcLoc@:]
  77 Obvious.
  78
  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}.
  84
  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.
  87 \end{description}
  88
  89 Some functions to go with:
  90 \begin{code}
  91 isExported a
  92   = case (getExportFlag a) of
  93       NotExported -> False
  94       _           -> True
  95
  96 getLocalName :: (NamedThing a) => a -> FAST_STRING
  97
  98 getLocalName = snd . getOrigName
  99
 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 #-}
 105 #endif
 106 \end{code}
 107
 108 @ltLexical@ is used for sorting things into lexicographical order, so
 109 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 110 comparison.]
 111
 112 \begin{code}
 113 a `ltLexical` b
 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
 120     else
 121        case _CMP_STRING_ a_mod b_mod of
 122          LT_  -> True
 123          EQ_  -> a_name < b_name
 124          GT__ -> False
 125     BEND BEND BEND BEND
 126
 127 #ifdef USE_ATTACK_PRAGMAS
 128 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
 129 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
 130 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
 131 #endif
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 137 %*                                                                      *
 138 %************************************************************************
 139
 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
 145 imported.
 146
 147 \begin{code}
 148 data ExportFlag
 149   = ExportAll           -- export with all constructors/methods
 150   | ExportAbs           -- export abstractly
 151   | NotExported
 152 \end{code}
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection[Outputable-class]{The @Outputable@ class}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 class Outputable a where
 162         ppr :: PprStyle -> a -> Pretty
 163 \end{code}
 164
 165 \begin{code}
 166 -- the ppSep in the ppInterleave puts in the spaces
 167 -- Death to ppSep! (WDP 94/11)
 168
 169 interppSP  :: Outputable a => PprStyle -> [a] -> Pretty
 170 interppSP  sty xs = ppIntersperse ppSP (map (ppr sty) xs)
 171
 172 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
 173 interpp'SP sty xs
 174   = ppInterleave sep (map (ppr sty) xs)
 175   where
 176     sep = ppBeside ppComma ppSP
 177
 178 #ifdef USE_ATTACK_PRAGMAS
 179 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
 180 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
 181
 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 #-}
 188 #endif
 189 \end{code}
 190
 191 \begin{code}
 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
 195
 196 ifnotPprForUser   sty p = case sty of PprForUser -> ppNil ; _ -> p
 197 ifnotPprShowAll   sty p = case sty of PprShowAll -> ppNil ; _ -> p
 198 \end{code}
 199
 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]
 203
 204 \begin{code}
 205 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
 206
 207 isConop cs
 208   | _NULL_ cs   = False
 209   | c == '_'    = isConop (_TAIL_ cs)           -- allow for leading _'s
 210   | otherwise   = isUpper c || c == ':'
 211                   || c == '[' || c == '('       -- [] () and (,,) come is as Conop strings !!!
 212                   || isUpperISO c
 213   where
 214     c = _HEAD_ cs
 215
 216 isAconop cs
 217   | _NULL_ cs   = False
 218   | otherwise   = c == ':'
 219   where
 220     c = _HEAD_ cs
 221
 222 isAvarid cs
 223   | _NULL_ cs    = False
 224   | c == '_'     = isAvarid (_TAIL_ cs) -- allow for leading _'s
 225   | isLower c    = True
 226   | isLowerISO c = True
 227   | otherwise    = False
 228   where
 229     c = _HEAD_ cs
 230
 231 isAvarop cs
 232   | _NULL_ cs                       = False
 233   | isLower c                       = False
 234   | isUpper c                       = False
 235   | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
 236   | isSymbolISO c                   = True
 237   | otherwise                       = False
 238   where
 239     c = _HEAD_ cs
 240
 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
 244 \end{code}
 245
 246 And one ``higher-level'' interface to those:
 247
 248 \begin{code}
 249 isOpLexeme :: NamedThing a => a -> Bool
 250
 251 isOpLexeme v
 252   = let str = getOccurrenceName v in isAvarop str || isAconop str
 253
 254 -- print `vars`, (op) correctly
 255 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 256
 257 pprOp sty var
 258   = if isOpLexeme var
 259     then ppr sty var
 260     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 261
 262 pprNonOp sty var
 263   = if isOpLexeme var
 264     then ppBesides [ppLparen, ppr sty var, ppRparen]
 265     else ppr sty var
 266
 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 #-}
 272 #endif
 273 \end{code}
 274
 275 \begin{code}
 276 instance Outputable Bool where
 277     ppr sty True = ppPStr SLIT("True")
 278     ppr sty False = ppPStr SLIT("False")
 279
 280 instance (Outputable a) => Outputable [a] where
 281     ppr sty xs =
 282       ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
 283
 284 instance (Outputable a, Outputable b) => Outputable (a, b) where
 285     ppr sty (x,y) =
 286       ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
 287
 288 -- ToDo: may not be used
 289 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 290     ppr sty (x,y,z) =
 291       ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
 292               ppBeside (ppr sty y) ppComma,
 293               ppBeside (ppr sty z) ppRparen ]
 294 \end{code}