ghc/compiler/utils/Outputable.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1995
   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         PprStyle(..),           -- style-ry (re-exported)
  21
  22         interppSP, interpp'SP,
  23 --UNUSED: ifPprForUser,
  24         ifnotPprForUser,
  25         ifPprDebug, --UNUSED: ifnotPprDebug,
  26         ifPprShowAll, ifnotPprShowAll,
  27         ifPprInterface, --UNUSED: ifnotPprInterface,
  28 --UNUSED: ifPprForC, ifnotPprForC,
  29 --UNUSED: ifPprUnfolding, ifnotPprUnfolding,
  30
  31         isOpLexeme, pprOp, pprNonOp,
  32         isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
  33
  34         -- and to make the interface self-sufficient...
  35         Pretty(..), GlobalSwitch,
  36         PrettyRep, UniType, Unique, SrcLoc
  37     ) where
  38
  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)
  44                         )
  45 import Id               ( Id ) -- for specialising
  46 import NameTypes        -- for specialising
  47 import ProtoName        -- for specialising
  48 import Pretty
  49 import SrcLoc           ( SrcLoc )
  50 import Unique           ( Unique )
  51 import Util
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[NamedThing-class]{The @NamedThing@ class}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  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
  69     hasType             :: a -> Bool
  70     getType             :: a -> UniType
  71     fromPreludeCore     :: a -> Bool
  72     -- see also friendly functions that follow...
  73 \end{code}
  74
  75 \begin{description}
  76 \item[@getExportFlag@:]
  77 Obvious.
  78
  79 \item[@getOrigName@:]
  80 Obvious.
  81
  82 \item[@isLocallyDefined@:]
  83 Whether the thing is defined in this module or not.
  84
  85 \item[@getOccurrenceName@:]
  86 Gets the name by which a thing is known in this module (e.g., if
  87 renamed, or whatever)...
  88
  89 \item[@getInformingModules@:]
  90 Gets the name of the modules that told me about this @NamedThing@.
  91
  92 \item[@getSrcLoc@:]
  93 Obvious.
  94
  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)
  99
 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}.
 105
 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.
 108 \end{description}
 109
 110 Some functions to go with:
 111 \begin{code}
 112 isExported a
 113   = case (getExportFlag a) of
 114       NotExported -> False
 115       _           -> True
 116
 117 getLocalName :: (NamedThing a) => a -> FAST_STRING
 118
 119 getLocalName = snd . getOrigName
 120
 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 #-}
 126 #endif
 127 \end{code}
 128
 129 @ltLexical@ is used for sorting things into lexicographical order, so
 130 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 131 comparison.]
 132
 133 \begin{code}
 134 a `ltLexical` b
 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
 141     else
 142        case _CMP_STRING_ a_mod b_mod of
 143          LT_  -> True
 144          EQ_  -> a_name < b_name
 145          GT__ -> False
 146     BEND BEND BEND BEND
 147
 148 #ifdef USE_ATTACK_PRAGMAS
 149 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
 150 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
 151 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
 152 #endif
 153 \end{code}
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 158 %*                                                                      *
 159 %************************************************************************
 160
 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
 166 imported.
 167
 168 \begin{code}
 169 data ExportFlag
 170   = ExportAll           -- export with all constructors/methods
 171   | ExportAbs           -- export abstractly
 172   | NotExported
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection[Outputable-class]{The @Outputable@ class}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 class Outputable a where
 183         ppr :: PprStyle -> a -> Pretty
 184 \end{code}
 185
 186 \begin{code}
 187 -- the ppSep in the ppInterleave puts in the spaces
 188 -- Death to ppSep! (WDP 94/11)
 189
 190 interppSP  :: Outputable a => PprStyle -> [a] -> Pretty
 191 interppSP  sty xs = ppIntersperse ppSP (map (ppr sty) xs)
 192
 193 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
 194 interpp'SP sty xs
 195   = ppInterleave sep (map (ppr sty) xs)
 196   where
 197     sep = ppBeside ppComma ppSP
 198
 199 #ifdef USE_ATTACK_PRAGMAS
 200 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
 201 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
 202
 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 #-}
 209 #endif
 210 \end{code}
 211
 212 \begin{code}
 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
 219
 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
 226 \end{code}
 227
 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]
 231
 232 \begin{code}
 233 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
 234
 235 isConop cs
 236   | _NULL_ cs   = False
 237   | c == '_'    = isConop (_TAIL_ cs)   -- allow for leading _'s
 238   | otherwise   = isUpper c || c == ':'
 239   where
 240     c = _HEAD_ cs
 241
 242 {- UNUSED:
 243 isAconid []       = False
 244 isAconid ('_':cs) = isAconid cs
 245 isAconid (c:cs)   = isUpper c
 246 -}
 247
 248 isAconop cs
 249   | _NULL_ cs   = False
 250   | otherwise   = c == ':'
 251   where
 252     c = _HEAD_ cs
 253
 254 isAvarid cs
 255   | _NULL_ cs   = False
 256   | c == '_'    = isAvarid (_TAIL_ cs)  -- allow for leading _'s
 257   | otherwise   = isLower c
 258   where
 259     c = _HEAD_ cs
 260
 261 isAvarop cs
 262   | _NULL_ cs   = False
 263   | isLower c   = False -- shortcut
 264   | isUpper c   = False -- ditto
 265   | otherwise   = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
 266   where
 267     c = _HEAD_ cs
 268 \end{code}
 269
 270 And one ``higher-level'' interface to those:
 271
 272 \begin{code}
 273 isOpLexeme :: NamedThing a => a -> Bool
 274
 275 isOpLexeme v
 276   = let str = getOccurrenceName v in isAvarop str || isAconop str
 277
 278 -- print `vars`, (op) correctly
 279 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 280
 281 pprOp sty var
 282   = if isOpLexeme var
 283     then ppr sty var
 284     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 285
 286 pprNonOp sty var
 287   = if isOpLexeme var
 288     then ppBesides [ppLparen, ppr sty var, ppRparen]
 289     else ppr sty var
 290
 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 #-}
 296 #endif
 297 \end{code}
 298
 299 \begin{code}
 300 instance Outputable Bool where
 301     ppr sty True = ppPStr SLIT("True")
 302     ppr sty False = ppPStr SLIT("False")
 303
 304 instance (Outputable a) => Outputable [a] where
 305     ppr sty xs =
 306       ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
 307
 308 instance (Outputable a, Outputable b) => Outputable (a, b) where
 309     ppr sty (x,y) =
 310       ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
 311
 312 -- ToDo: may not be used
 313 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 314     ppr sty (x,y,z) =
 315       ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
 316               ppBeside (ppr sty y) ppComma,
 317               ppBeside (ppr sty z) ppRparen ]
 318 \end{code}