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
  17         getItsUnique, getOrigName, getOccName, getExportFlag,
  18         getSrcLoc, isLocallyDefined, isPreludeDefined, isExported,
  19         getLocalName, getOrigNameRdr, ltLexical,
  20
  21         -- PRINTERY AND FORCERY
  22         Outputable(..),         -- class
  23
  24         interppSP, interpp'SP,
  25         ifnotPprForUser,
  26         ifPprDebug,
  27         ifPprShowAll, ifnotPprShowAll,
  28         ifPprInterface,
  29
  30         isOpLexeme, pprOp, pprNonOp,
  31         isConop, isAconop, isAvarid, isAvarop
  32     ) where
  33
  34 import Ubiq{-uitous-}
  35
  36 import Name             ( nameUnique, nameOrigName, nameOccName,
  37                           nameExportFlag, nameSrcLoc,
  38                           isLocallyDefinedName, isPreludeDefinedName
  39                         )
  40 import PprStyle         ( PprStyle(..) )
  41 import Pretty
  42 import Util             ( cmpPString )
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection[NamedThing-class]{The @NamedThing@ class}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 class NamedThing a where
  53     getName :: a -> Name
  54
  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
  62
  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
  70
  71 isExported a
  72   = case (getExportFlag a) of
  73       NotExported -> False
  74       _           -> True
  75
  76 getLocalName :: (NamedThing a) => a -> FAST_STRING
  77 getLocalName = snd . getOrigName
  78
  79 getOrigNameRdr :: (NamedThing a) => a -> RdrName
  80 getOrigNameRdr n | isPreludeDefined n = Unqual str
  81                  | otherwise          = Qual mod str
  82   where
  83     (mod,str) = getOrigName n
  84
  85 #ifdef USE_ATTACK_PRAGMAS
  86 {-# SPECIALIZE isExported :: Class -> Bool #-}
  87 {-# SPECIALIZE isExported :: Id -> Bool #-}
  88 {-# SPECIALIZE isExported :: TyCon -> Bool #-}
  89 #endif
  90 \end{code}
  91
  92 @ltLexical@ is used for sorting things into lexicographical order, so
  93 as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
  94 comparison.]
  95
  96 \begin{code}
  97 a `ltLexical` b
  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
 104     else
 105        case _CMP_STRING_ a_mod b_mod of
 106          LT_  -> True
 107          EQ_  -> a_name < b_name
 108          GT__ -> False
 109     BEND BEND BEND BEND
 110
 111 #ifdef USE_ATTACK_PRAGMAS
 112 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
 113 {-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
 114 {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
 115 #endif
 116 \end{code}
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
 121 %*                                                                      *
 122 %************************************************************************
 123
 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
 129 imported.
 130
 131 \begin{code}
 132 data ExportFlag
 133   = ExportAll           -- export with all constructors/methods
 134   | ExportAbs           -- export abstractly
 135   | NotExported
 136 \end{code}
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection[Outputable-class]{The @Outputable@ class}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 class Outputable a where
 146         ppr :: PprStyle -> a -> Pretty
 147 \end{code}
 148
 149 \begin{code}
 150 -- the ppSep in the ppInterleave puts in the spaces
 151 -- Death to ppSep! (WDP 94/11)
 152
 153 interppSP  :: Outputable a => PprStyle -> [a] -> Pretty
 154 interppSP  sty xs = ppIntersperse ppSP (map (ppr sty) xs)
 155
 156 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
 157 interpp'SP sty xs
 158   = ppInterleave sep (map (ppr sty) xs)
 159   where
 160     sep = ppBeside ppComma ppSP
 161
 162 #ifdef USE_ATTACK_PRAGMAS
 163 {-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
 164 {-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
 165
 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 #-}
 171 #endif
 172 \end{code}
 173
 174 \begin{code}
 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
 178
 179 ifnotPprForUser   sty p = case sty of PprForUser -> ppNil ; _ -> p
 180 ifnotPprShowAll   sty p = case sty of PprShowAll -> ppNil ; _ -> p
 181 \end{code}
 182
 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)@
 186
 187 \begin{code}
 188 isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
 189
 190 isConop cs
 191   | _NULL_ cs   = False
 192   | c == '_'    = isConop (_TAIL_ cs)           -- allow for leading _'s
 193   | otherwise   = isUpper c || c == ':'
 194                   || c == '[' || c == '('       -- [] () and (,,) come is as Conop strings !!!
 195                   || isUpperISO c
 196   where
 197     c = _HEAD_ cs
 198
 199 isAconop cs
 200   | _NULL_ cs   = False
 201   | otherwise   = c == ':'
 202   where
 203     c = _HEAD_ cs
 204
 205 isAvarid cs
 206   | _NULL_ cs    = False
 207   | c == '_'     = isAvarid (_TAIL_ cs) -- allow for leading _'s
 208   | isLower c    = True
 209   | isLowerISO c = True
 210   | otherwise    = False
 211   where
 212     c = _HEAD_ cs
 213
 214 isAvarop cs
 215   | _NULL_ cs                       = False
 216   | isLower c                       = False
 217   | isUpper c                       = False
 218   | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
 219   | isSymbolISO c                   = True
 220   | otherwise                       = False
 221   where
 222     c = _HEAD_ cs
 223
 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
 227 \end{code}
 228
 229 And one ``higher-level'' interface to those:
 230
 231 \begin{code}
 232 isOpLexeme :: NamedThing a => a -> Bool
 233
 234 isOpLexeme v
 235   = let str = snd (getOrigName v) in isAvarop str || isAconop str
 236
 237 -- print `vars`, (op) correctly
 238 pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 239
 240 pprOp sty var
 241   = if isOpLexeme var
 242     then ppr sty var
 243     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 244
 245 pprNonOp sty var
 246   = if isOpLexeme var
 247     then ppBesides [ppLparen, ppr sty var, ppRparen]
 248     else ppr sty var
 249
 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 #-}
 255 #endif
 256 \end{code}
 257
 258 \begin{code}
 259 instance Outputable Bool where
 260     ppr sty True = ppPStr SLIT("True")
 261     ppr sty False = ppPStr SLIT("False")
 262
 263 instance (Outputable a) => Outputable [a] where
 264     ppr sty xs =
 265       ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
 266
 267 instance (Outputable a, Outputable b) => Outputable (a, b) where
 268     ppr sty (x,y) =
 269       ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
 270
 271 -- ToDo: may not be used
 272 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 273     ppr sty (x,y,z) =
 274       ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
 275               ppBeside (ppr sty y) ppComma,
 276               ppBeside (ppr sty z) ppRparen ]
 277 \end{code}