%
-% (c) The GRASP Project, Glasgow University, 1992-1996
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[Outputable]{Classes for pretty-printing}
``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}
\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
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}
%************************************************************************
\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}
%************************************************************************
\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
\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}
``first'' etc.
\begin{code}
-speakNth :: Int -> Doc
+speakNth :: Int -> SDoc
speakNth 1 = ptext SLIT("first")
speakNth 2 = ptext SLIT("second")
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}
projects / ghc-hetmet.git / blobdiff