#include "HsVersions.h"
module Outputable (
- -- NAMED-THING-ERY
- NamedThing(..), -- class
- ExportFlag(..),
- isExported, getLocalName, ltLexical,
-
- -- PRINTERY AND FORCERY
Outputable(..), -- class
- interppSP, interpp'SP,
- ifnotPprForUser,
+ PprStyle(..),
+ codeStyle, ifaceStyle, userStyle,
ifPprDebug,
+ ifnotPprForUser,
ifPprShowAll, ifnotPprShowAll,
ifPprInterface,
+ pprQuote,
+
+ printDoc, interppSP, interpp'SP,
- isOpLexeme, pprOp, pprNonOp,
- isConop, isAconop, isAvarid, isAvarop
+ speakNth
+
+#if __GLASGOW_HASKELL__ <= 200
+ , Mode
+#endif
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
+#if __GLASGOW_HASKELL__ >= 202
+import IO
+import GlaExts
+#else
+import Ubiq ( Uniquable(..), Unique, Name ) -- FastString mentions it; todo: rm
+
+#endif
-import PprStyle ( PprStyle(..) )
+import FastString
import Pretty
import Util ( cmpPString )
\end{code}
+
%************************************************************************
%* *
-\subsection[NamedThing-class]{The @NamedThing@ class}
+\subsection{The @PprStyle@ data type}
%* *
%************************************************************************
\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
- getItsUnique :: a -> Unique
- fromPreludeCore :: a -> Bool
- -- see also friendly functions that follow...
-\end{code}
-
-\begin{description}
-\item[@getExportFlag@:]
-Obvious.
+data PprStyle
+ = PprForUser Int -- Pretty-print in a way that will
+ -- make sense to the ordinary user;
+ -- must be very close to Haskell
+ -- syntax, etc.
+ -- Parameterised over how much to expand
+ -- a pretty-printed value (<= 0 => stop pp).
+ | PprQuote -- Like PprForUser, but also quote the whole thing
-\item[@getOrigName@:]
-Obvious.
+ | PprDebug -- Standard debugging output
+ | PprShowAll -- Debugging output which leaves
+ -- nothing to the imagination
-\item[@isLocallyDefined@:]
-Whether the thing is defined in this module or not.
+ | PprInterface -- Interface generation
-\item[@getOccurrenceName@:]
-Gets the name by which a thing is known in this module (e.g., if
-renamed, or whatever)...
+ | PprForC -- must print out C-acceptable names
-\item[@getInformingModules@:]
-Gets the name of the modules that told me about this @NamedThing@.
+ | PprForAsm -- must print out assembler-acceptable names
+ Bool -- prefix CLabel with underscore?
+ (String -> String) -- format AsmTempLabel
-\item[@getSrcLoc@:]
-Obvious.
-
-\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}.
+\end{code}
-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}
+Orthogonal to the above printing styles are (possibly) some
+command-line flags that affect printing (often carried with the
+style). The most likely ones are variations on how much type info is
+shown.
-Some functions to go with:
+The following test decides whether or not we are actually generating
+code (either C or assembly), or generating interface files.
\begin{code}
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
-
-getLocalName :: (NamedThing a) => a -> FAST_STRING
+codeStyle :: PprStyle -> Bool
+codeStyle PprForC = True
+codeStyle (PprForAsm _ _) = True
+codeStyle _ = False
+
+ifaceStyle :: PprStyle -> Bool
+ifaceStyle PprInterface = True
+ifaceStyle other = False
+
+userStyle :: PprStyle -> Bool
+userStyle PprQuote = True
+userStyle (PprForUser _) = True
+userStyle other = False
+\end{code}
-getLocalName = snd . getOrigName
+\begin{code}
+ifPprDebug sty p = case sty of PprDebug -> p ; _ -> empty
+ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> empty
+ifPprInterface sty p = case sty of PprInterface -> p ; _ -> empty
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
-#endif
+ifnotPprForUser sty p = case sty of { PprForUser _ -> empty ; PprQuote -> empty; _ -> p }
+ifnotPprShowAll sty p = case sty of { PprShowAll -> empty ; _ -> p }
\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
+pprQuote :: PprStyle -> (PprStyle -> Doc) -> Doc
+pprQuote PprQuote fn = quotes (fn (PprForUser 5{-opt_PprUserLength-}))
+pprQuote sty fn = fn sty
\end{code}
-%************************************************************************
-%* *
-\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
-\end{code}
%************************************************************************
%* *
\begin{code}
class Outputable a where
- ppr :: PprStyle -> a -> Pretty
+ ppr :: PprStyle -> a -> Doc
\end{code}
\begin{code}
--- the ppSep in the ppInterleave puts in the spaces
--- Death to ppSep! (WDP 94/11)
-
-interppSP :: Outputable a => PprStyle -> [a] -> Pretty
-interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs)
+instance Outputable Bool where
+ ppr sty True = ptext SLIT("True")
+ ppr sty False = ptext SLIT("False")
-interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
-interpp'SP sty xs
- = ppInterleave 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 -> [Type] -> Pretty #-}
-#endif
-\end{code}
+instance (Outputable a) => Outputable [a] where
+ ppr sty xs = brackets (fsep (punctuate comma (map (ppr sty) xs)))
-\begin{code}
-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
+instance (Outputable a, Outputable b) => Outputable (a, b) where
+ ppr sty (x,y) =
+ hang (hcat [lparen, ppr sty x, comma]) 4 ((<>) (ppr sty y) rparen)
-ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
-ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
+-- ToDo: may not be used
+instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
+ ppr sty (x,y,z) =
+ parens (sep [ (<>) (ppr sty x) comma,
+ (<>) (ppr sty y) comma,
+ ppr sty z ])
\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]
+
+%************************************************************************
+%* *
+\subsection{Other helper functions}
+%* *
+%************************************************************************
\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 == ':'
- || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
- || isUpperISO c
- where
- c = _HEAD_ cs
-
-isAconop cs
- | _NULL_ cs = False
- | otherwise = c == ':'
- where
- c = _HEAD_ cs
-
-isAvarid cs
- | _NULL_ cs = False
- | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
- | isLower c = True
- | isLowerISO c = True
- | otherwise = False
+printDoc :: Mode -> Handle -> Doc -> IO ()
+printDoc mode hdl doc
+ = fullRender mode 100 1.5 put done doc
where
- c = _HEAD_ cs
-
-isAvarop cs
- | _NULL_ cs = False
- | isLower c = False
- | isUpper c = False
- | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
- | isSymbolISO c = True
- | otherwise = False
- where
- c = _HEAD_ cs
+ put (Chr c) next = hPutChar hdl c >> next
+ put (Str s) next = hPutStr hdl s >> next
+ put (PStr s) next = hPutFS hdl s >> next
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+ done = hPutChar hdl '\n'
\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
+interppSP :: Outputable a => PprStyle -> [a] -> Doc
+interppSP sty xs = hsep (map (ppr sty) xs)
--- print `vars`, (op) correctly
-pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
+interpp'SP :: Outputable a => PprStyle -> [a] -> Doc
+interpp'SP sty xs
+ = hsep (punctuate comma (map (ppr sty) xs))
+\end{code}
-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
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
-#endif
-\end{code}
-\begin{code}
-instance Outputable Bool where
- ppr sty True = ppPStr SLIT("True")
- ppr sty False = ppPStr SLIT("False")
+%************************************************************************
+%* *
+\subsection{Printing numbers verbally}
+%* *
+%************************************************************************
-instance (Outputable a) => Outputable [a] where
- ppr sty xs =
- ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ]
+@speakNth@ converts an integer to a verbal index; eg 1 maps to
+``first'' etc.
-instance (Outputable a, Outputable b) => Outputable (a, b) where
- ppr sty (x,y) =
- ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen)
+\begin{code}
+speakNth :: Int -> Doc
+
+speakNth 1 = ptext SLIT("first")
+speakNth 2 = ptext SLIT("second")
+speakNth 3 = ptext SLIT("third")
+speakNth 4 = ptext SLIT("fourth")
+speakNth 5 = ptext SLIT("fifth")
+speakNth 6 = ptext SLIT("sixth")
+speakNth n = hcat [ int n, text st_nd_rd_th ]
+ where
+ st_nd_rd_th | n_rem_10 == 1 = "st"
+ | n_rem_10 == 2 = "nd"
+ | n_rem_10 == 3 = "rd"
+ | otherwise = "th"
--- ToDo: may not be used
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
- ppr sty (x,y,z) =
- ppSep [ ppBesides [ppLparen, ppr sty x, ppComma],
- ppBeside (ppr sty y) ppComma,
- ppBeside (ppr sty z) ppRparen ]
+ n_rem_10 = n `rem` 10
\end{code}
projects / ghc-hetmet.git / blobdiff