-*********************************************************************************
-* *
-* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
-* *
-* based on "The Design of a Pretty-printing Library" *
-* in Advanced Functional Programming, *
-* Johan Jeuring and Erik Meijer (eds), LNCS 925 *
-* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
-* *
-* Heavily modified by Simon Peyton Jones, Dec 96 *
-* *
-*********************************************************************************
+%*********************************************************************************
+%* *
+%* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
+%* *
+%* based on "The Design of a Pretty-printing Library" *
+%* in Advanced Functional Programming, *
+%* Johan Jeuring and Erik Meijer (eds), LNCS 925 *
+%* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
+%* *
+%* Heavily modified by Simon Peyton Jones, Dec 96 *
+%* *
+%*********************************************************************************
Version 3.0 28 May 1997
* Cured massive performance bug. If you write
\begin{code}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS -fno-warn-unused-imports #-}
+-- XXX GHC 6.9 seems to be confused by unpackCString# being used only in
+-- a RULE
+
module Pretty (
Doc, -- Abstract
Mode(..), TextDetails(..),
empty, isEmpty, nest,
- text, char, ftext, ptext,
+ char, text, ftext, ptext,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
hang, punctuate,
-- renderStyle, -- Haskell 1.3 only
- render, fullRender, printDoc, showDocWith
+ render, fullRender, printDoc, showDocWith,
+ bufLeftRender -- performance hack
) where
import BufWrite
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{The interface}
-* *
-*********************************************************
+%* *
+%*********************************************************
The primitive @Doc@ values
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{The @Doc@ calculus}
-* *
-*********************************************************
+%* *
+%*********************************************************
The @Doc@ combinators satisfy the following laws:
\begin{verbatim}
<n5> nest k empty = empty
<n6> x <> nest k y = x <> y, if x non-empty
-** Note the side condition on <n6>! It is this that
-** makes it OK for empty to be a left unit for <>.
+ - Note the side condition on <n6>! It is this that
+ makes it OK for empty to be a left unit for <>.
Miscellaneous
~~~~~~~~~~~~~
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Simple derived definitions}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
semi = char ';'
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{The @Doc@ data type}
-* *
-*********************************************************
+%* *
+%*********************************************************
A @Doc@ represents a {\em set} of layouts. A @Doc@ with
no occurrences of @Union@ or @NoDoc@ represents just one layout.
_ok _ = False
\end{code}
-
Notice the difference between
* NoDoc (no documents)
* Empty (one empty document; no height and no width)
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{@empty@, @text@, @nest@, @union@}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
empty = Empty
ftext :: FastString -> Doc
ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
ptext :: LitString -> Doc
-ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
+ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
where s = {-castPtr-} s_
#if defined(__GLASGOW_HASKELL__)
mkUnion p q = p `union_` q
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Vertical composition @$$@}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
where
- k1 = k -# sl
+ !k1 = k -# sl
rest = case p of
Empty -> nilAboveNest g k1 q
_ -> aboveNest p g k1 q
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Horizontal composition @<>@}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
p <> q = Beside p False q
| otherwise = p
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Separate, @sep@, Hughes version}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
-- Specification: sep ps = oneLiner (hsep ps)
sepNB g p k ys = sep1 g p k ys
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{@fill@}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
fsep = fill True
`mkUnion`
nilAboveNest False k (fill g (y:ys))
where
- k1 | g = k -# _ILIT(1)
- | otherwise = k
+ !k1 | g = k -# _ILIT(1)
+ | otherwise = k
fillNB g p k ys = fill1 g p k ys
\end{code}
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Selecting the best layout}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
best :: Int -- Line length
best w_ r_ p
= get (iUnbox w_) p
where
- r = iUnbox r_
+ !r = iUnbox r_
get :: FastInt -- (Remaining) width of line
-> Doc -> Doc
get _ Empty = Empty
-*********************************************************
-* *
+%*********************************************************
+%* *
\subsection{Displaying the best layout}
-* *
-*********************************************************
+%* *
+%*********************************************************
\begin{code}
\begin{code}
pprCols :: Int
-pprCols = 120 -- could make configurable
+pprCols = 100 -- could make configurable
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc LeftMode hdl doc
where
put (Chr c) next = hPutChar hdl c >> next
put (Str s) next = hPutStr hdl s >> next
- put (PStr s) next = hPutFS hdl s >> next
+ put (PStr s) next = hPutStr hdl (unpackFS s) >> next
+ -- NB. not hPutFS, we want this to go through
+ -- the I/O library's encoding layer. (#3398)
put (LStr s l) next = hPutLitString hdl s l >> next
done = hPutChar hdl '\n'
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = do
b <- newBufHandle hdl
- layLeft b (reduceDoc doc)
+ bufLeftRender b doc
bFlush b
+bufLeftRender :: BufHandle -> Doc -> IO ()
+bufLeftRender b doc = layLeft b (reduceDoc doc)
+
-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
-- this function with the IO state lambda. Otherwise we end up with
-- closures in all the case branches.
projects / ghc-hetmet.git / blobdiff