X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=861f4b5f09e310b956a5c8a3507650e4ec97cef7;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=ea1188795763850b6ed04d6c0738025bc2206d0e;hpb=ff14742cc328f19b9bf7c04d9a69408e641cf64a;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index ea11887..861f4b5 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -7,47 +7,47 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} -#include "HsVersions.h" - 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, + getPprStyle, withPprStyle, pprDeeper, + codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, + ifPprDebug, ifNotPprForUser, + + SDoc, -- Abstract + interppSP, interpp'SP, pprQuotedList, + empty, nest, + text, char, ptext, + int, integer, float, double, rational, + parens, brackets, braces, quotes, doubleQuotes, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, punctuate, + speakNth, speakNTimes, + + showSDoc, printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, + pprCols, + + -- error handling + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, + panic, panic#, assertPanic ) where -#if __GLASGOW_HASKELL__ >= 202 -import IO -import GlaExts -# if __GLASGOW_HASKELL__ >= 209 -import Addr -# endif - -#else -import Ubiq ( Uniquable(..), Unique, Name ) -- FastString mentions it; todo: rm - -#endif +#include "HsVersions.h" -import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User ) +import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) +import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User, opt_PprUserLength ) import FastString -import Pretty -import Util ( cmpPString ) +import qualified Pretty +import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Util ( panic, assertPanic, panic# ) +import GlaExts ( trace ) \end{code} @@ -59,26 +59,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 @@ -88,37 +85,152 @@ 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 = printDoc PageMode stderr (final_doc PprDebug) + where + final_doc = doc $$ text "" + + +-- printForC, printForAsm doe 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) + + +-- showSDoc just blasts it out as a string +showSDoc :: SDoc -> String +showSDoc d = show (d (mkUserStyle AllTheWay)) + +mkUserStyle depth | opt_PprStyle_Debug + || opt_PprStyle_All = 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) +quotes d sty = Pretty.quotes (d sty) +doubleQuotes d sty = Pretty.doubleQuotes (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 + +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} %************************************************************************ @@ -129,30 +241,29 @@ 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 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) = + hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen) -- 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 ]) \end{code} @@ -165,13 +276,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 @@ -181,21 +285,19 @@ printDoc mode hdl doc put (PStr s) next = hPutFS hdl s >> next 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 "")) \end{code} \begin{code} -interppSP :: Outputable a => PprStyle -> [a] -> Doc -interppSP sty xs = hsep (map (ppr sty) xs) +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = hsep (map ppr xs) -interpp'SP :: Outputable a => PprStyle -> [a] -> Doc -interpp'SP sty xs - = hsep (punctuate comma (map (ppr sty) 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} @@ -211,7 +313,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") @@ -228,3 +330,41 @@ 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[Utils-errors]{Error handling} +%* * +%************************************************************************ + +\begin{code} +pprPanic heading pretty_msg = panic (show (doc PprDebug)) + where + doc = text heading <+> pretty_msg + +pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg)) + +pprTrace heading pretty_msg = trace (show (doc PprDebug)) + where + doc = text heading <+> pretty_msg + +pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) + where + doc = text heading <+> 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] +\end{code}