X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=19ad6666776d7e8c70529c129e9f229dc1e72a15;hb=6f531423b6927191dac4958ed11086def74cb3b3;hp=d72dc8528b79adb451f6d51051f8e50f8f70d087;hpb=e376c9e1b8da2741389b9ad2322475e37284beb9;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index d72dc85..19ad666 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1996 +% (c) The GRASP Project, Glasgow University, 1992-1998 % \section[Outputable]{Classes for pretty-printing} @@ -7,43 +7,56 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} -#include "HsVersions.h" +{-# OPTIONS -fno-prune-tydecls #-} +-- Hopefully temporary; 3.02 complained about not being able +-- to see the consructors for ForeignObj module Outputable ( - Outputable(..), -- class - - PprStyle(..), - codeStyle, ifaceStyle, userStyle, - ifPprDebug, - ifnotPprForUser, - ifPprShowAll, ifnotPprShowAll, - ifPprInterface, - pprQuote, - - printDoc, printErrs, pprCols, pprDumpStyle, pprErrorsStyle, - - interppSP, interpp'SP, - - speakNth - -#if __GLASGOW_HASKELL__ <= 200 - , Mode -#endif - + Outputable(..), -- Class + + PprStyle, CodeStyle(..), + getPprStyle, withPprStyle, pprDeeper, + codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, + ifPprDebug, ifNotPprForUser, + + SDoc, -- Abstract + interppSP, interpp'SP, pprQuotedList, pprWithCommas, + empty, nest, + text, char, ptext, + int, integer, float, double, rational, + parens, brackets, braces, quotes, doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, punctuate, + speakNth, speakNTimes, + + printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, printForUser, + pprCode, pprCols, + showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc, + pprFSAsString, + + + -- error handling + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, + trace, panic, panic#, assertPanic ) where -#if __GLASGOW_HASKELL__ >= 202 -import IO -import GlaExts -#else -import Ubiq ( Uniquable(..), Unique, Name ) -- FastString mentions it; todo: rm +#include "HsVersions.h" -#endif -import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User ) +import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) +import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString -import Pretty -import Util ( cmpPString ) +import qualified Pretty +import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Panic +import ST ( runST ) +import Foreign \end{code} @@ -55,26 +68,23 @@ import Util ( cmpPString ) \begin{code} data PprStyle - = PprForUser Int -- Pretty-print in a way that will + = PprUser Depth -- 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 | PprDebug -- Standard debugging output - | PprShowAll -- Debugging output which leaves - -- nothing to the imagination | PprInterface -- Interface generation - | PprForC -- must print out C-acceptable names + | PprCode CodeStyle -- Print code; either C or assembler + - | PprForAsm -- must print out assembler-acceptable names - Bool -- prefix CLabel with underscore? - (String -> String) -- format AsmTempLabel +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle +data Depth = AllTheWay + | PartWay Int -- 0 => stop \end{code} Orthogonal to the above printing styles are (possibly) some @@ -84,37 +94,179 @@ 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 + +pprDeeper :: SDoc -> SDoc +pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) +pprDeeper d other_sty = d other_sty + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df sty = df sty sty +\end{code} + \begin{code} codeStyle :: PprStyle -> Bool -codeStyle PprForC = True -codeStyle (PprForAsm _ _) = True +codeStyle (PprCode _) = True codeStyle _ = False +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle other = False + ifaceStyle :: PprStyle -> Bool ifaceStyle PprInterface = True ifaceStyle other = False +debugStyle :: PprStyle -> Bool +debugStyle PprDebug = True +debugStyle other = False + userStyle :: PprStyle -> Bool -userStyle PprQuote = True -userStyle (PprForUser _) = True -userStyle other = False +userStyle (PprUser _) = True +userStyle other = False \end{code} \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 +ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style +ifNotPprForUser d sty@(PprUser _) = Pretty.empty +ifNotPprForUser d sty = d sty -ifnotPprForUser sty p = case sty of { PprForUser _ -> empty ; PprQuote -> empty; _ -> p } -ifnotPprShowAll sty p = case sty of { PprShowAll -> empty ; _ -> p } +ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style +ifPprDebug d sty@PprDebug = d sty +ifPprDebug d sty = Pretty.empty \end{code} \begin{code} -pprQuote :: PprStyle -> (PprStyle -> Doc) -> Doc -pprQuote PprQuote fn = quotes (fn (PprForUser 5{-opt_PprUserLength-})) -pprQuote sty fn = fn sty +printSDoc :: SDoc -> PprStyle -> IO () +printSDoc d sty = printDoc PageMode stdout (d sty) + +-- I'm not sure whether the direct-IO approach of printDoc +-- above is better or worse than the put-big-string approach here +printErrs :: SDoc -> IO () +printErrs doc = printDoc PageMode stderr (final_doc user_style) + where + final_doc = doc -- $$ text "" + user_style = mkUserStyle (PartWay opt_PprUserLength) + +printDump :: SDoc -> IO () +printDump doc = printForUser stdout (doc $$ text "") + -- We used to always print in debug style, but I want + -- to try the effect of a more user-ish style (unless you + -- say -dppr-debug + +printForUser :: Handle -> SDoc -> IO () +printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay)) + +-- printForC, printForAsm do what they sound like +printForC :: Handle -> SDoc -> IO () +printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) + +printForAsm :: Handle -> SDoc -> IO () +printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) + +-- printForIface prints all on one line for interface files. +-- It's called repeatedly for successive lines +printForIface :: Handle -> SDoc -> IO () +printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +-- 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 (mkUserStyle AllTheWay)) + +showSDocIface :: SDoc -> String +showSDocIface doc = showDocWith OneLineMode (doc PprInterface) + +showSDocDebug :: SDoc -> String +showSDocDebug d = show (d PprDebug) + +showsPrecSDoc :: Int -> SDoc -> ShowS +showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay)) + +mkUserStyle depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser depth \end{code} +\begin{code} +empty sty = Pretty.empty +text s sty = Pretty.text s +char c sty = Pretty.char c +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("::") +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} %************************************************************************ @@ -125,30 +277,51 @@ pprQuote sty fn = fn sty \begin{code} class Outputable a where - ppr :: PprStyle -> a -> Doc + ppr :: a -> SDoc \end{code} \begin{code} instance Outputable Bool where - ppr sty True = ptext SLIT("True") - ppr sty False = ptext SLIT("False") + ppr True = ptext SLIT("True") + ppr False = ptext SLIT("False") instance Outputable Int where - ppr sty n = int n + ppr n = int n instance (Outputable a) => Outputable [a] where - ppr sty xs = brackets (fsep (punctuate comma (map (ppr sty) xs))) + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) 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) + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x -- 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 ]) + 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 = text (unpackFS fs) -- Prints an unadorned string, + -- no double quotes or anything + +pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints +pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes + +instance Show FastString where + showsPrec p fs = showsPrecSDoc p (ppr fs) \end{code} @@ -161,13 +334,6 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher \begin{code} pprCols = (100 :: Int) -- could make configurable --- pprErrorsStyle is the style to print ordinary error messages with --- pprDumpStyle is the style to print -ddump-xx information in -(pprDumpStyle, pprErrorsStyle) - | opt_PprStyle_All = (PprShowAll, PprShowAll) - | opt_PprStyle_Debug = (PprDebug, PprDebug) - | otherwise = (PprDebug, PprQuote) - printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc = fullRender mode pprCols 1.5 put done doc @@ -178,23 +344,30 @@ printDoc mode hdl doc done = hPutChar hdl '\n' --- I'm not sure whether the direct-IO approach of printDoc --- above is better or worse than the put-big-string approach here -printErrs :: Doc -> IO () -printErrs doc = hPutStr stderr (show (doc $$ text "")) +showDocWith :: Mode -> Doc -> String +showDocWith mode doc + = fullRender mode 100 1.5 put "" doc + where + put (Chr c) s = c:s + put (Str s1) s2 = s1 ++ s2 + put (PStr s1) s2 = _UNPK_ s1 ++ s2 \end{code} \begin{code} -interppSP :: Outputable a => PprStyle -> [a] -> Doc -interppSP sty xs = hsep (map (ppr sty) xs) +pprWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprWithCommas pp xs = hsep (punctuate comma (map pp xs)) -interpp'SP :: Outputable a => PprStyle -> [a] -> Doc -interpp'SP sty xs - = hsep (punctuate comma (map (ppr sty) xs)) -\end{code} +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = hsep (map ppr xs) +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = hsep (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} %************************************************************************ @@ -207,7 +380,7 @@ interpp'SP sty xs ``first'' etc. \begin{code} -speakNth :: Int -> Doc +speakNth :: Int -> SDoc speakNth 1 = ptext SLIT("first") speakNth 2 = ptext SLIT("second") @@ -224,3 +397,52 @@ speakNth n = hcat [ int n, text st_nd_rd_th ] n_rem_10 = n `rem` 10 \end{code} + +\begin{code} +speakNTimes :: Int {- >=1 -} -> SDoc +speakNTimes t | t == 1 = ptext SLIT("once") + | t == 2 = ptext SLIT("twice") + | otherwise = int t <+> ptext SLIT("times") +\end{code} + + +%************************************************************************ +%* * +\subsection{Error handling} +%* * +%************************************************************************ + +\begin{code} +pprPanic :: String -> SDoc -> a +pprError :: String -> SDoc -> a +pprTrace :: String -> SDoc -> a -> a +pprPanic = pprAndThen panic +pprError = pprAndThen error +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}