+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-\section[Outputable]{Classes for pretty-printing}
-
-Defines classes for pretty-printing and forcing, both forms of
-``output.''
-
-\begin{code}
-
-module Outputable (
- Outputable(..), OutputableBndr(..), -- Class
-
- BindingSite(..),
-
- PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
- getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
- codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
- ifPprDebug, unqualStyle,
- mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
-
- SDoc, -- Abstract
- docToSDoc,
- interppSP, interpp'SP, pprQuotedList, pprWithCommas,
- empty, nest,
- text, char, ftext, ptext,
- int, integer, float, double, rational,
- parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
- semi, comma, colon, dcolon, space, equals, dot, arrow,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
- hang, punctuate,
- speakNth, speakNTimes, speakN, speakNOf, plural,
-
- printSDoc, printErrs, printDump,
- printForC, printForAsm, printForUser,
- pprCode, mkCodeStyle,
- showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
- showSDocUnqual, showsPrecSDoc,
- pprHsChar, pprHsString,
-
- -- error handling
- pprPanic, assertPprPanic, pprPanic#, pprPgmError,
- pprTrace, warnPprTrace,
- trace, pgmError, panic, panic#, assertPanic
- ) where
-
-#include "HsVersions.h"
-
-
-import {-# SOURCE #-} Module( Module )
-import {-# SOURCE #-} OccName( OccName )
-
-import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
-import PackageConfig ( PackageId, packageIdString )
-import FastString
-import qualified Pretty
-import Pretty ( Doc, Mode(..) )
-import Panic
-
-import DATA_WORD ( Word32 )
-
-import IO ( Handle, stderr, stdout, hFlush )
-import Char ( ord )
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The @PprStyle@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data PprStyle
- = PprUser PrintUnqualified Depth
- -- Pretty-print in a way that will make sense to the
- -- ordinary user; must be very close to Haskell
- -- syntax, etc.
- -- Assumes printing tidied code: non-system names are
- -- printed without uniques.
-
- | PprCode CodeStyle
- -- Print code; either C or assembler
-
- | PprDump -- For -ddump-foo; less verbose than PprDebug.
- -- Does not assume tidied code: non-external names
- -- are printed with uniques.
-
- | PprDebug -- Full debugging output
-
-data CodeStyle = CStyle -- The format of labels differs for C and assembler
- | AsmStyle
-
-data Depth = AllTheWay
- | PartWay Int -- 0 => stop
-
-
-type PrintUnqualified = Module -> OccName -> Bool
- -- This function tells when it's ok to print
- -- a (Global) name unqualified
-
-alwaysQualify,neverQualify :: PrintUnqualified
-alwaysQualify m n = False
-neverQualify m n = True
-
-defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
-
-defaultDumpStyle | opt_PprStyle_Debug = PprDebug
- | otherwise = PprDump
-
-mkErrStyle :: PrintUnqualified -> PprStyle
--- Style for printing error messages
-mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
-
-defaultErrStyle :: PprStyle
--- Default style for error messages
--- It's a bit of a hack because it doesn't take into account what's in scope
--- Only used for desugarer warnings, and typechecker errors in interface sigs
-defaultErrStyle
- | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
- | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
-
-mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
- | otherwise = PprUser unqual depth
-\end{code}
-
-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.
-
-The following test decides whether or not we are actually generating
-code (either C or assembly), or generating interface files.
-
-%************************************************************************
-%* *
-\subsection{The @SDoc@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-type SDoc = PprStyle -> Doc
-
-withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d sty' = d sty
-
-withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
-
-pprDeeper :: SDoc -> SDoc
-pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
-pprDeeper d other_sty = d other_sty
-
-pprSetDepth :: Int -> SDoc -> SDoc
-pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n))
-pprSetDepth n d other_sty = d other_sty
-
-getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
-\end{code}
-
-\begin{code}
-unqualStyle :: PprStyle -> PrintUnqualified
-unqualStyle (PprUser unqual _) m n = unqual m n
-unqualStyle other m n = False
-
-codeStyle :: PprStyle -> Bool
-codeStyle (PprCode _) = True
-codeStyle _ = False
-
-asmStyle :: PprStyle -> Bool
-asmStyle (PprCode AsmStyle) = True
-asmStyle other = False
-
-dumpStyle :: PprStyle -> Bool
-dumpStyle PprDump = True
-dumpStyle other = False
-
-debugStyle :: PprStyle -> Bool
-debugStyle PprDebug = True
-debugStyle other = False
-
-userStyle :: PprStyle -> Bool
-userStyle (PprUser _ _) = True
-userStyle other = False
-
-ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug d sty = Pretty.empty
-\end{code}
-
-\begin{code}
--- Unused [7/02 sof]
-printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = do
- Pretty.printDoc PageMode stdout (d sty)
- hFlush stdout
-
--- I'm not sure whether the direct-IO approach of Pretty.printDoc
--- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
- hFlush stderr
-
-printDump :: SDoc -> IO ()
-printDump doc = do
- Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
- hFlush stdout
- where
- better_doc = doc $$ text ""
-
-printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
-printForUser handle unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
-
--- printForC, printForAsm do what they sound like
-printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
-
-printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
-
-pprCode :: CodeStyle -> SDoc -> SDoc
-pprCode cs d = withPprStyle (PprCode cs) d
-
-mkCodeStyle :: CodeStyle -> PprStyle
-mkCodeStyle = PprCode
-
--- Can't make SDoc an instance of Show because SDoc is just a function type
--- However, Doc *is* an instance of Show
--- showSDoc just blasts it out as a string
-showSDoc :: SDoc -> String
-showSDoc d = show (d defaultUserStyle)
-
-showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
-
-showSDocUnqual :: SDoc -> String
--- Only used in the gruesome HsExpr.isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
-
-showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
-
-showSDocDump :: SDoc -> String
-showSDocDump d = show (d PprDump)
-
-showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
-\end{code}
-
-\begin{code}
-docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
-
-empty sty = Pretty.empty
-text s sty = Pretty.text s
-char c sty = Pretty.char c
-ftext s sty = Pretty.ftext s
-ptext s sty = Pretty.ptext s
-int n sty = Pretty.int n
-integer n sty = Pretty.integer n
-float n sty = Pretty.float n
-double n sty = Pretty.double n
-rational n sty = Pretty.rational n
-
-parens d sty = Pretty.parens (d sty)
-braces d sty = Pretty.braces (d sty)
-brackets d sty = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d = char '<' <> d <> char '>'
-
--- quotes encloses something in single quotes...
--- but it omits them if the thing ends in a single quote
--- so that we don't get `foo''. Instead we just have foo'.
-quotes d sty = case show pp_d of
- ('\'' : _) -> pp_d
- other -> Pretty.quotes pp_d
- where
- pp_d = d sty
-
-semi sty = Pretty.semi
-comma sty = Pretty.comma
-colon sty = Pretty.colon
-equals sty = Pretty.equals
-space sty = Pretty.space
-lparen sty = Pretty.lparen
-rparen sty = Pretty.rparen
-lbrack sty = Pretty.lbrack
-rbrack sty = Pretty.rbrack
-lbrace sty = Pretty.lbrace
-rbrace sty = Pretty.rbrace
-dcolon sty = Pretty.ptext SLIT("::")
-arrow sty = Pretty.ptext SLIT("->")
-underscore = char '_'
-dot = char '.'
-
-nest n d sty = Pretty.nest n (d sty)
-(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
-
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty = Pretty.sep [d sty | d <- ds]
-cat ds sty = Pretty.cat [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
-
-hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
-
-punctuate :: SDoc -> [SDoc] -> [SDoc]
-punctuate p [] = []
-punctuate p (d:ds) = go d ds
- where
- go d [] = [d]
- go d (e:es) = (d <> p) : go e es
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Outputable-class]{The @Outputable@ class}
-%* *
-%************************************************************************
-
-\begin{code}
-class Outputable a where
- ppr :: a -> SDoc
-\end{code}
-
-\begin{code}
-instance Outputable Bool where
- ppr True = ptext SLIT("True")
- ppr False = ptext SLIT("False")
-
-instance Outputable Int where
- ppr n = int n
-
-instance Outputable () where
- ppr _ = text "()"
-
-instance (Outputable a) => Outputable [a] where
- ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
-
-instance (Outputable a, Outputable b) => Outputable (a, b) where
- ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
-
-instance Outputable a => Outputable (Maybe a) where
- ppr Nothing = ptext SLIT("Nothing")
- ppr (Just x) = ptext SLIT("Just") <+> ppr x
-
--- ToDo: may not be used
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
- ppr (x,y,z) =
- parens (sep [ppr x <> comma,
- ppr y <> comma,
- ppr z ])
-
-instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
- Outputable (a, b, c, d) where
- ppr (x,y,z,w) =
- parens (sep [ppr x <> comma,
- ppr y <> comma,
- ppr z <> comma,
- ppr w])
-
-instance Outputable FastString where
- ppr fs = ftext fs -- Prints an unadorned string,
- -- no double quotes or anything
-
-instance Outputable PackageId where
- ppr pid = text (packageIdString pid)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The @OutputableBndr@ class}
-%* *
-%************************************************************************
-
-When we print a binder, we often want to print its type too.
-The @OutputableBndr@ class encapsulates this idea.
-
-@BindingSite@ is used to tell the thing that prints binder what
-language construct is binding the identifier. This can be used
-to decide how much info to print.
-
-\begin{code}
-data BindingSite = LambdaBind | CaseBind | LetBind
-
-class Outputable a => OutputableBndr a where
- pprBndr :: BindingSite -> a -> SDoc
- pprBndr b x = ppr x
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Random printing helpers}
-%* *
-%************************************************************************
-
-\begin{code}
--- We have 31-bit Chars and will simply use Show instances
--- of Char and String.
-
-pprHsChar :: Char -> SDoc
-pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
- | otherwise = text (show c)
-
-pprHsString :: FastString -> SDoc
-pprHsString fs = text (show (unpackFS fs))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Other helper functions}
-%* *
-%************************************************************************
-
-\begin{code}
-pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
-pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
-
-interppSP :: Outputable a => [a] -> SDoc
-interppSP xs = sep (map ppr xs)
-
-interpp'SP :: Outputable a => [a] -> SDoc
-interpp'SP xs = sep (punctuate comma (map ppr xs))
-
-pprQuotedList :: Outputable a => [a] -> SDoc
--- [x,y,z] ==> `x', `y', `z'
-pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Printing numbers verbally}
-%* *
-%************************************************************************
-
-@speakNth@ converts an integer to a verbal index; eg 1 maps to
-``first'' etc.
-
-\begin{code}
-speakNth :: Int -> SDoc
-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 suffix ]
- where
- suffix | n <= 20 = "th" -- 11,12,13 are non-std
- | last_dig == 1 = "st"
- | last_dig == 2 = "nd"
- | last_dig == 3 = "rd"
- | otherwise = "th"
-
- last_dig = n `rem` 10
-
-speakN :: Int -> SDoc
-speakN 0 = ptext SLIT("none") -- E.g. "he has none"
-speakN 1 = ptext SLIT("one") -- E.g. "he has one"
-speakN 2 = ptext SLIT("two")
-speakN 3 = ptext SLIT("three")
-speakN 4 = ptext SLIT("four")
-speakN 5 = ptext SLIT("five")
-speakN 6 = ptext SLIT("six")
-speakN n = int n
-
-speakNOf :: Int -> SDoc -> SDoc
-speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
-speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
-speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
-
-speakNTimes :: Int {- >=1 -} -> SDoc
-speakNTimes t | t == 1 = ptext SLIT("once")
- | t == 2 = ptext SLIT("twice")
- | otherwise = speakN t <+> ptext SLIT("times")
-
-plural [x] = empty
-plural xs = char 's'
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-pprPanic, pprPgmError :: String -> SDoc -> a
-pprTrace :: String -> SDoc -> a -> a
-pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
-
-pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
- -- (used for unusual pgm errors)
-pprTrace = pprAndThen trace
-
-pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
-
-pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
- where
- doc = sep [text heading, nest 4 pretty_msg]
-
-assertPprPanic :: String -> Int -> SDoc -> a
-assertPprPanic file line msg
- = panic (show (doc PprDebug))
- where
- doc = sep [hsep[text "ASSERT failed! file",
- text file,
- text "line", int line],
- msg]
-
-warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
-warnPprTrace False file line msg x = x
-warnPprTrace True file line msg x
- = trace (show (doc PprDebug)) x
- where
- doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
- msg]
-\end{code}
projects / ghc-hetmet.git / blobdiff