%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[Outputable]{Classes for pretty-printing}
#include "HsVersions.h"
module Outputable (
- -- NAMED-THING-ERY
- NamedThing(..), -- class
- ExportFlag(..),
- isExported, getLocalName, ltLexical,
-
- -- PRINTERY AND FORCERY
Outputable(..), -- class
- PprStyle(..), -- style-ry (re-exported)
interppSP, interpp'SP,
---UNUSED: ifPprForUser,
ifnotPprForUser,
- ifPprDebug, --UNUSED: ifnotPprDebug,
+ ifPprDebug,
ifPprShowAll, ifnotPprShowAll,
- ifPprInterface, --UNUSED: ifnotPprInterface,
---UNUSED: ifPprForC, ifnotPprForC,
---UNUSED: ifPprUnfolding, ifnotPprUnfolding,
-
- isOpLexeme, pprOp, pprNonOp,
- isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
-
- -- and to make the interface self-sufficient...
- Pretty(..), GlobalSwitch,
- PrettyRep, UniType, Unique, SrcLoc
+ ifPprInterface
) where
-import AbsUniType ( UniType,
- TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import Id ( Id ) -- for specialising
-import NameTypes -- for specialising
-import ProtoName -- for specialising
-import Pretty
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[NamedThing-class]{The @NamedThing@ class}
-%* *
-%************************************************************************
-
-\begin{code}
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-})
- getOccurrenceName :: a -> FAST_STRING
- getInformingModules :: a -> [FAST_STRING]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
- -- see also friendly functions that follow...
-\end{code}
-
-\begin{description}
-\item[@getExportFlag@:]
-Obvious.
-
-\item[@getOrigName@:]
-Obvious.
-
-\item[@isLocallyDefined@:]
-Whether the thing is defined in this module or not.
-
-\item[@getOccurrenceName@:]
-Gets the name by which a thing is known in this module (e.g., if
-renamed, or whatever)...
-
-\item[@getInformingModules@:]
-Gets the name of the modules that told me about this @NamedThing@.
-
-\item[@getSrcLoc@:]
-Obvious.
-
-\item[@hasType@ and @getType@:]
-In pretty-printing @AbsSyntax@, we need to query if a datatype has
-types attached yet or not. We use @hasType@ to see if there are types
-available; and @getType@ if we want to grab one... (Ugly but effective)
-
-\item[@fromPreludeCore@:]
-Tests a quite-delicate property: it is \tr{True} iff the entity is
-actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
-it is re-exported by \tr{PreludeCore}. See the @FullName@ type in
-module \tr{NameTypes}.
-
-NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test.
-This is a bummer for types that are wired into the compiler.
-\end{description}
-
-Some functions to go with:
-\begin{code}
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
-
-getLocalName :: (NamedThing a) => a -> FAST_STRING
-
-getLocalName = snd . getOrigName
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
-#endif
-\end{code}
-
-@ltLexical@ is used for sorting things into lexicographical order, so
-as to canonicalize interfaces. [Regular @(<)@ should be used for fast
-comparison.]
-
-\begin{code}
-a `ltLexical` b
- = BIND isLocallyDefined a _TO_ a_local ->
- BIND isLocallyDefined b _TO_ b_local ->
- BIND getOrigName a _TO_ (a_mod, a_name) ->
- BIND getOrigName b _TO_ (b_mod, b_name) ->
- if a_local || b_local then
- a_name < b_name -- can't compare module names
- else
- case _CMP_STRING_ a_mod b_mod of
- LT_ -> True
- EQ_ -> a_name < b_name
- GT__ -> False
- BEND BEND BEND BEND
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
-{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
-{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
-#endif
-\end{code}
+import Ubiq{-uitous-}
-%************************************************************************
-%* *
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
-%* *
-%************************************************************************
-
-The export flag @ExportAll@ means `export all there is', so there are
-times when it is attached to a class or data type which has no
-ops/constructors (if the class/type was imported abstractly). In
-fact, @ExportAll@ is attached to everything except to classes/types
-which are being {\em exported} abstractly, regardless of how they were
-imported.
-
-\begin{code}
-data ExportFlag
- = ExportAll -- export with all constructors/methods
- | ExportAbs -- export abstractly
- | NotExported
+import PprStyle ( PprStyle(..) )
+import Pretty
+import Util ( cmpPString )
\end{code}
%************************************************************************
interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
interpp'SP sty xs
- = ppInterleave sep (map (ppr sty) xs)
+ = ppIntersperse sep (map (ppr sty) xs)
where
sep = ppBeside ppComma ppSP
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-}
-{-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-}
-
-{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-}
-#endif
\end{code}
\begin{code}
---UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil
ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil
ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil
-ifPprInterface sty p = case sty of PprInterface _ -> p ; _ -> ppNil
---UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil
---UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil
-
-ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
---UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p
-ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
---UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p
---UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p
---UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p
-\end{code}
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report. Normally applied as in, e.g.,
-@isConop (getOccurrenceName foo)@... [just for pretty-printing]
-
-\begin{code}
-isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
-
-isConop cs
- | _NULL_ cs = False
- | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isUpper c || c == ':'
- where
- c = _HEAD_ cs
-
-{- UNUSED:
-isAconid [] = False
-isAconid ('_':cs) = isAconid cs
-isAconid (c:cs) = isUpper c
--}
-
-isAconop cs
- | _NULL_ cs = False
- | otherwise = c == ':'
- where
- c = _HEAD_ cs
-
-isAvarid cs
- | _NULL_ cs = False
- | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isLower c
- where
- c = _HEAD_ cs
-
-isAvarop cs
- | _NULL_ cs = False
- | isLower c = False -- shortcut
- | isUpper c = False -- ditto
- | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
- where
- c = _HEAD_ cs
-\end{code}
-
-And one ``higher-level'' interface to those:
-
-\begin{code}
-isOpLexeme :: NamedThing a => a -> Bool
-
-isOpLexeme v
- = let str = getOccurrenceName v in isAvarop str || isAconop str
-
--- print `vars`, (op) correctly
-pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
-
-pprOp sty var
- = if isOpLexeme var
- then ppr sty var
- else ppBesides [ppChar '`', ppr sty var, ppChar '`']
-
-pprNonOp sty var
- = if isOpLexeme var
- then ppBesides [ppLparen, ppr sty var, ppRparen]
- else ppr sty var
+ifPprInterface sty p = case sty of PprInterface -> p ; _ -> ppNil
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
-#endif
+ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
+ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff