X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=a9cddcd98b8eaf452cae7d6330cc5dc489709aee;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=f7fb7fc3165222a20bd2b89883ff9d6571857c16;hpb=fed91d4d411b583c92a5f80545e124daab0b8be5;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index f7fb7fc..a9cddcd 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,40 +7,55 @@ 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, 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, + 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, + + printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, + pprCode, pprCols, + showSDoc, showsPrecSDoc, pprFSAsString, + + + -- error handling + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, + 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 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 Util ( panic, assertPanic, panic#, trace ) +import ST ( runST ) +import Foreign \end{code} @@ -52,26 +67,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 @@ -81,37 +93,158 @@ 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) + +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)) + +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) +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} %************************************************************************ @@ -122,30 +255,39 @@ 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]) -- 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 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} @@ -156,9 +298,11 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher %************************************************************************ \begin{code} +pprCols = (100 :: Int) -- could make configurable + printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc - = fullRender mode 100 1.5 put done doc + = fullRender mode pprCols 1.5 put done doc where put (Chr c) next = hPutChar hdl c >> next put (Str s) next = hPutStr hdl s >> next @@ -169,12 +313,15 @@ printDoc mode hdl doc \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 => [a] -> SDoc +interpp'SP xs = hsep (punctuate comma (map ppr xs)) -interpp'SP :: Outputable a => PprStyle -> [a] -> Doc -interpp'SP sty xs - = hsep (punctuate comma (map (ppr sty) xs)) +pprQuotedList :: Outputable a => [a] -> SDoc +-- [x,y,z] ==> `x', `y', `z' +pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \end{code} @@ -190,7 +337,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") @@ -207,3 +354,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++ " " ++ (showSDoc 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}