certainly guarantee is insensivity to associativity. It matters: suddenly
GHC's compilation times went up by a factor of 100 when I switched to the
new pretty printer.
-
+
I fixed it with a bit of a hack (because I wanted to get GHC back on the
road). I added two new constructors to the Doc type, Above and Beside:
-
+
<> = Beside
$$ = Above
-
+
Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
the Doc to squeeze out these suspended calls to Beside and Above; but in so
doing I re-associate. It's quite simple, but I'm not satisfied that I've done
======================================================================
Relative to John's original paper, there are the following new features:
-1. There's an empty document, "empty". It's a left and right unit for
+1. There's an empty document, "empty". It's a left and right unit for
both <> and $$, and anywhere in the argument list for
sep, hcat, hsep, vcat, fcat etc.
It is Really Useful in practice.
2. There is a paragraph-fill combinator, fsep, that's much like sep,
- only it keeps fitting things on one line until itc can't fit any more.
+ only it keeps fitting things on one line until it can't fit any more.
-3. Some random useful extra combinators are provided.
+3. Some random useful extra combinators are provided.
<+> puts its arguments beside each other with a space between them,
unless either argument is empty in which case it returns the other
These new ones do the obvious things:
char, semi, comma, colon, space,
- parens, brackets, braces,
+ parens, brackets, braces,
quotes, doubleQuotes
-
+
4. The "above" combinator, $$, now overlaps its two arguments if the
last line of the top argument stops before the first line of the second begins.
For example: text "hi" $$ nest 5 "there"
5. Several different renderers are provided:
* a standard one
- * one that uses cut-marks to avoid deeply-nested documents
+ * one that uses cut-marks to avoid deeply-nested documents
simply piling up in the right-hand margin
* one that ignores indentation (fewer chars output; good for machines)
* one that ignores indentation and newlines (ditto, only more so)
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Pretty (
Doc, -- Abstract
Mode(..), TextDetails(..),
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
+ (<>), (<+>), hcat, hsep,
+ ($$), ($+$), vcat,
+ sep, cat,
+ fsep, fcat,
hang, punctuate,
-
+
-- renderStyle, -- Haskell 1.3 only
render, fullRender, printDoc, showDocWith
) where
import BufWrite
import FastString
-
-import GLAEXTS
+import FastTypes
import Numeric (fromRat)
-import IO
+import System.IO
+--import Foreign.Ptr (castPtr)
-import System.IO ( hPutBuf )
-
-import GHC.Base ( unpackCString# )
-import GHC.Ptr ( Ptr(..) )
+#if defined(__GLASGOW_HASKELL__)
+--for a RULES
+import GHC.Base ( unpackCString# )
+import GHC.Ptr ( Ptr(..) )
+#endif
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
-infixl 6 <>
+infixl 6 <>
infixl 6 <+>
infixl 5 $$, $+$
\end{code}
-
-*********************************************************
-* *
-\subsection{CPP magic so that we can compile with both GHC and Hugs}
-* *
-*********************************************************
-
-The library uses unboxed types to get a bit more speed, but these CPP macros
-allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
- __GLASGOW_HASKELL__
-
\begin{code}
-#if defined(__GLASGOW_HASKELL__)
-
--- Glasgow Haskell
-
-- Disable ASSERT checks; they are expensive!
#define LOCAL_ASSERT(x)
-#define ILIT(x) (x#)
-#define IBOX(x) (I# (x))
-#define INT Int#
-#define MINUS -#
-#define NEGATE negateInt#
-#define PLUS +#
-#define GR >#
-#define GREQ >=#
-#define LT <#
-#define DIV `quotInt#`
-
-
-#define SHOW Show
-#define MAXINT maxBound
-
-#else
-
--- Standard Haskell
-
-#define LOCAL_ASSERT(x)
-
-#define INT Int
-#define IBOX(x) x
-#define MINUS -
-#define NEGATE negate
-#define PLUS +
-#define GR >
-#define GREQ >=
-#define LT <
-#define DIV `quot`
-#define ILIT(x) x
-
-#define SHOW Show
-#define MAXINT maxBound
-
-#endif
-
\end{code}
\begin{code}
empty :: Doc
isEmpty :: Doc -> Bool
-text :: String -> Doc
+text :: String -> Doc
char :: Char -> Doc
semi, comma, colon, space, equals :: Doc
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
-parens, brackets, braces :: Doc -> Doc
+parens, brackets, braces :: Doc -> Doc
quotes, doubleQuotes :: Doc -> Doc
int :: Int -> Doc
punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
\end{code}
-Displaying @Doc@ values.
+Displaying @Doc@ values.
\begin{code}
-instance SHOW Doc where
+instance Show Doc where
showsPrec prec doc cont = showDoc doc cont
render :: Doc -> String -- Uses default style
-> Doc
-> a -- Result
-{- When we start using 1.3
+{- When we start using 1.3
renderStyle :: Style -> Doc -> String
data Style = Style { lineLength :: Int, -- In chars
ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-}
-data Mode = PageMode -- Normal
+data Mode = PageMode -- Normal
| ZigZagMode -- With zig-zag cuts
| LeftMode -- No indentation, infinitely long lines
| OneLineMode -- All on one line
Miscellaneous
~~~~~~~~~~~~~
-<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
+<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
nest (-length s) y)
<m2> (x $$ y) <> z = x $$ (y <> z)
Laws for oneLiner
~~~~~~~~~~~~~~~~~
<o1> oneLiner (nest k p) = nest k (oneLiner p)
-<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
\end{verbatim}
You might think that the following verion of <m1> would
be neater:
\begin{verbatim}
-<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
+<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
nest (-length s) y)
\end{verbatim}
But it doesn't work, for if x=empty, we would have
integer n = text (show n)
float n = text (show n)
double n = text (show n)
-rational n = text (show (fromRat n))
+rational n = text (show (fromRat n :: Double))
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
quotes p = char '`' <> p <> char '\''
brackets p = char '[' <> p <> char ']'
braces p = char '{' <> p <> char '}'
+cparen True = parens
+cparen False = id
hcat = foldr (<>) empty
hsep = foldr (<+>) empty
data Doc
= Empty -- empty
| NilAbove Doc -- text "" $$ x
- | TextBeside !TextDetails INT Doc -- text s <> x
- | Nest INT Doc -- nest k x
+ | TextBeside !TextDetails FastInt Doc -- text s <> x
+ | Nest FastInt Doc -- nest k x
| Union Doc Doc -- ul `union` ur
| NoDoc -- The empty set of documents
| Beside Doc Bool Doc -- True <=> space between
data TextDetails = Chr {-#UNPACK#-}!Char
| Str String
- | PStr FastString -- a hashed string
- | LStr Addr# Int# -- a '\0'-terminated array of bytes
+ | PStr FastString -- a hashed string
+ | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated
+ -- array of bytes
space_text = Chr ' '
nl_text = Chr '\n'
\item
The arugment of @TextBeside@ is never @Nest@.
-\item
+\item
The layouts of the two arguments of @Union@ both flatten to the same string.
-\item
+\item
The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
\item
If the left argument of a union is equivalent to the empty set (@NoDoc@),
then the @NoDoc@ appears in the first line.
-\item
+\item
An empty document is always represented by @Empty@.
It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
-\item
+\item
The first line of every layout in the left argument of @Union@
is longer than the first line of any layout in the right argument.
(1) ensures that the left argument has a first line. In view of (3),
isEmpty Empty = True
isEmpty _ = False
-char c = textBeside_ (Chr c) 1# Empty
-text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
-ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
-ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+char c = textBeside_ (Chr c) (_ILIT(1)) Empty
+text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty}
+ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
+ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
+ where s = {-castPtr-} s_
+#if defined(__GLASGOW_HASKELL__)
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
-{-# RULES
+{-# RULES
"text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
#-}
+#endif
-nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
+nest k p = mkNest (iUnbox k) (reduceDoc p) -- Externally callable version
-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
+mkNest k (Nest k1 p) = mkNest (k +# k1) p
mkNest k NoDoc = NoDoc
mkNest k Empty = Empty
-mkNest ILIT(0) p = p -- Worth a try!
+mkNest k p | k ==# _ILIT(0) = p -- Worth a try!
mkNest k p = nest_ k p
-- mkUnion checks for an empty document
above :: Doc -> Bool -> RDoc -> RDoc
above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
-above p g q = aboveNest p g ILIT(0) (reduceDoc q)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
+above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q)
-aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
+aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
-- Specfication: aboveNest p g k q = p $g$ (nest k q)
aboveNest NoDoc g k q = NoDoc
-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
aboveNest p2 g k q
-
+
aboveNest Empty g k q = mkNest k q
-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q)
-- p can't be Empty, so no need for mkNest
-
+
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 MINUS sl
+ k1 = k -# sl
rest = case p of
Empty -> nilAboveNest g k1 q
other -> aboveNest p g k1 q
\end{code}
\begin{code}
-nilAboveNest :: Bool -> INT -> RDoc -> RDoc
--- Specification: text s <> nilaboveNest g k q
+nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
+-- Specification: text s <> nilaboveNest g k q
-- = text s <> (text "" $g$ nest k q)
nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
-nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
+nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap
= textBeside_ (Str (spaces k)) k q
| otherwise -- Put them really above
= nilAbove_ (mkNest k q)
beside :: Doc -> Bool -> RDoc -> RDoc
-- Specification: beside g p q = p <g> q
-
+
beside NoDoc g q = NoDoc
beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
beside Empty g q = q
beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
-beside p@(Beside p1 g1 q1) g2 q2
- {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
+beside p@(Beside p1 g1 q1) g2 q2
+ {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
[ && (op1 == <> || op1 == <+>) ] -}
| g1 == g2 = beside p1 g1 $! beside q1 g2 q2
| otherwise = beside (reduceDoc p) g2 q2
\begin{code}
nilBeside :: Bool -> RDoc -> RDoc
--- Specification: text "" <> nilBeside g p
+-- Specification: text "" <> nilBeside g p
-- = text "" <g> p
nilBeside g Empty = Empty -- Hence the text "" in the spec
nilBeside g (Nest _ p) = nilBeside g p
-nilBeside g p | g = textBeside_ space_text ILIT(1) p
+nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p
| otherwise = p
\end{code}
cat = sepX False -- Don't
sepX x [] = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
+sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
-- = oneLiner (x <g> nest k (hsep ys))
-- `union` x $$ nest k (vcat ys)
-sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
+sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
sep1 g NoDoc k ys = NoDoc
sep1 g (p `Union` q) k ys = sep1 g p k ys
`union_`
(aboveNest q False k (reduceDoc (vcat ys)))
sep1 g Empty k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k MINUS n) ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k -# n) ys)
sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
-- Called when we have already found some text in the first item
sepNB g (Nest _ p) k ys = sepNB g p k ys
sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
- `mkUnion`
+ `mkUnion`
nilAboveNest False k (reduceDoc (vcat ys))
where
rest | g = hsep ys
fsep = fill True
fcat = fill False
--- Specification:
+-- Specification:
-- fill [] = empty
-- fill [p] = p
--- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
-- (fill (oneLiner p2 : ps))
-- `union`
-- p1 $$ fill ps
fill g [] = empty
-fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
+fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
-fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
+fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
fill1 g NoDoc k ys = NoDoc
fill1 g (p `Union` q) k ys = fill1 g p k ys
`union_`
(aboveNest q False k (fill g ys))
fill1 g Empty k ys = mkNest k (fill g ys)
-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k MINUS n) ys)
+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k -# n) ys)
fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
fillNB g (Nest _ p) k ys = fillNB g p k ys
fillNB g Empty k [] = Empty
fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
- `mkUnion`
+ `mkUnion`
nilAboveNest False k (fill g (y:ys))
where
- k1 | g = k MINUS ILIT(1)
+ k1 | g = k -# _ILIT(1)
| otherwise = k
fillNB g p k ys = fill1 g p k ys
-> RDoc
-> RDoc -- No unions in here!
-best IBOX(w) IBOX(r) p
- = get w p
+best w_ r_ p
+ = get (iUnbox w_) p
where
- get :: INT -- (Remaining) width of line
+ r = iUnbox r_
+ get :: FastInt -- (Remaining) width of line
-> Doc -> Doc
get w Empty = Empty
get w NoDoc = NoDoc
get w (NilAbove p) = nilAbove_ (get w p)
get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
- get w (Nest k p) = nest_ k (get (w MINUS k) p)
+ get w (Nest k p) = nest_ k (get (w -# k) p)
get w (p `Union` q) = nicest w r (get w p) (get w q)
- get1 :: INT -- (Remaining) width of line
- -> INT -- Amount of first line already eaten up
+ get1 :: FastInt -- (Remaining) width of line
+ -> FastInt -- Amount of first line already eaten up
-> Doc -- This is an argument to TextBeside => eat Nests
-> Doc -- No unions in here!
get1 w sl Empty = Empty
get1 w sl NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
+ get1 w sl (NilAbove p) = nilAbove_ (get (w -# sl) p)
+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)
get1 w sl (Nest k p) = get1 w sl p
- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
(get1 w sl q)
-nicest w r p q = nicest1 w r ILIT(0) p q
-nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
+nicest w r p q = nicest1 w r (_ILIT(0)) p q
+nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
| otherwise = q
-fits :: INT -- Space available
+fits :: FastInt -- Space available
-> Doc
-> Bool -- True if *first line* of Doc fits in space available
-
-fits n p | n LT ILIT(0) = False
+
+fits n p | n <# _ILIT(0) = False
fits n NoDoc = False
fits n Empty = True
fits n (NilAbove _) = True
-fits n (TextBeside _ sl p) = fits (n MINUS sl) p
-
-minn x y | x LT y = x
- | otherwise = y
+fits n (TextBeside _ sl p) = fits (n -# sl) p
\end{code}
@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
@first@ returns its first argument if it is non-empty, otherwise its second.
\begin{code}
-first p q | nonEmptySet p = p
+first p q | nonEmptySet p = p
| otherwise = q
nonEmptySet NoDoc = False
\begin{code}
{-
-renderStyle Style{mode, lineLength, ribbonsPerLine} doc
+renderStyle Style{mode, lineLength, ribbonsPerLine} doc
= fullRender mode lineLength ribbonsPerLine doc ""
-}
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
-
-unpackLitString addr =
- unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
\end{code}
\begin{code}
-fullRender OneLineMode _ _ txt end doc
+fullRender OneLineMode _ _ txt end doc
= lay (reduceDoc doc)
where
lay NoDoc = cant_fail
- lay (Union p q) = (lay q) -- Second arg can't be NoDoc
+ lay (Union p q) = (lay q) -- Second arg can't be NoDoc
lay (Nest k p) = lay p
lay Empty = end
- lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
+ lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on
+ -- first line
lay (TextBeside s sl p) = s `txt` lay p
-fullRender LeftMode _ _ txt end doc
+fullRender LeftMode _ _ txt end doc
= lay (reduceDoc doc)
where
- lay NoDoc = cant_fail
- lay (Union p q) = lay (first p q)
- lay (Nest k p) = lay p
- lay Empty = end
- lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
- lay (TextBeside s sl p) = s `txt` lay p
+ lay NoDoc = cant_fail
+ lay (Union p q) = lay (first p q)
+ lay (Nest k p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s sl p) = s `txt` lay p
fullRender mode line_length ribbons_per_line txt end doc
= display mode line_length ribbon_length txt end best_doc
- where
+ where
best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
hacked_line_length, ribbon_length :: Int
ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
-display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
- = case page_width MINUS ribbon_width of { gap_width ->
- case gap_width DIV ILIT(2) of { shift ->
+display mode page_width ribbon_width txt end doc
+ = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
+ case gap_width `quotFastInt` _ILIT(2) of { shift ->
let
- lay k (Nest k1 p) = lay (k PLUS k1) p
+ lay k (Nest k1 p) = lay (k +# k1) p
lay k Empty = end
-
+
lay k (NilAbove p) = nl_text `txt` lay k p
-
+
lay k (TextBeside s sl p)
= case mode of
- ZigZagMode | k GREQ gap_width
+ ZigZagMode | k >=# gap_width
-> nl_text `txt` (
Str (multi_ch shift '/') `txt` (
nl_text `txt` (
- lay1 (k MINUS shift) s sl p)))
+ lay1 (k -# shift) s sl p)))
- | k LT ILIT(0)
+ | k <# _ILIT(0)
-> nl_text `txt` (
Str (multi_ch shift '\\') `txt` (
nl_text `txt` (
- lay1 (k PLUS shift) s sl p )))
+ lay1 (k +# shift) s sl p )))
other -> lay1 k s sl p
-
- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
-
+
+ lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
+
lay2 k (NilAbove p) = nl_text `txt` lay k p
- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
lay2 k (Nest _ p) = lay2 k p
lay2 k Empty = end
+
+ -- optimise long indentations using LitString chunks of 8 spaces
+ indent n r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt`
+ indent (n -# _ILIT(8)) r
+ | otherwise = Str (spaces n) `txt` r
in
- lay ILIT(0) doc
+ lay (_ILIT(0)) doc
}}
cant_fail = error "easy_display: NoDoc"
-indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
- | otherwise = spaces n
+multi_ch n ch | n <=# _ILIT(0) = ""
+ | otherwise = ch : multi_ch (n -# _ILIT(1)) ch
-multi_ch ILIT(0) ch = ""
-multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
+spaces n | n <=# _ILIT(0) = ""
+ | otherwise = ' ' : spaces (n -# _ILIT(1))
-spaces ILIT(0) = ""
-spaces n = ' ' : spaces (n MINUS ILIT(1))
\end{code}
\begin{code}
= do { printLeftRender hdl doc; hFlush hdl }
printDoc mode hdl doc
= do { fullRender mode pprCols 1.5 put done doc ;
- hFlush hdl }
+ hFlush hdl }
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 (LStr s l) next = hPutLitString hdl s l >> next
+ 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 (LStr s l) next = hPutLitString hdl s l >> next
done = hPutChar hdl '\n'
-- some versions of hPutBuf will barf if the length is zero
-hPutLitString handle a# 0# = return ()
-hPutLitString handle a# l#
-#if __GLASGOW_HASKELL__ < 411
- = hPutBuf handle (A# a#) (I# l#)
-#else
- = hPutBuf handle (Ptr a#) (I# l#)
-#endif
+hPutLitString handle a l = if l ==# _ILIT(0)
+ then return ()
+ else hPutBuf handle a (iBox l)
-- Printing output in LeftMode is performance critical: it's used when
-- dumping C and assembly output, so we allow ourselves a few dirty
-- hacks:
--
--- (1) we specialise fullRender for LeftMode with IO output.
+-- (1) we specialise fullRender for LeftMode with IO output.
--
--- (2) we add a layer of buffering on top of Handles. Handles
--- don't perform well with lots of hPutChars, which is mostly
--- what we're doing here, because Handles have to be thread-safe
--- and async exception-safe. We only have a single thread and don't
--- care about exceptions, so we add a layer of fast buffering
--- over the Handle interface.
+-- (2) we add a layer of buffering on top of Handles. Handles
+-- don't perform well with lots of hPutChars, which is mostly
+-- what we're doing here, because Handles have to be thread-safe
+-- and async exception-safe. We only have a single thread and don't
+-- care about exceptions, so we add a layer of fast buffering
+-- over the Handle interface.
--
--- (3) a few hacks in layLeft below to convince GHC to generate the right
--- code.
+-- (3) a few hacks in layLeft below to convince GHC to generate the right
+-- code.
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = do
-- 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.
-layLeft b _ | b `seq` False = undefined -- make it strict in b
-layLeft b NoDoc = cant_fail
-layLeft b (Union p q) = return () >> layLeft b (first p q)
-layLeft b (Nest k p) = return () >> layLeft b p
-layLeft b Empty = bPutChar b '\n'
-layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
-layLeft b (TextBeside s sl p) = put b s >> layLeft b p
+layLeft b _ | b `seq` False = undefined -- make it strict in b
+layLeft b NoDoc = cant_fail
+layLeft b (Union p q) = return () >> layLeft b (first p q)
+layLeft b (Nest k p) = return () >> layLeft b p
+layLeft b Empty = bPutChar b '\n'
+layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
+layLeft b (TextBeside s sl p) = put b s >> layLeft b p
where
put b _ | b `seq` False = undefined
put b (Chr c) = bPutChar b c
put b (Str s) = bPutStr b s
put b (PStr s) = bPutFS b s
put b (LStr s l) = bPutLitString b s l
-
-#if __GLASGOW_HASKELL__ < 503
-hPutBuf = hPutBufFull
-#endif
-
\end{code}