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.
2. There is a paragraph-fill combinator, fsep, that's much like sep,
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)
semi, comma, colon, space, equals,
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
#if defined(__GLASGOW_HASKELL__)
--for a RULES
-import GHC.Base ( unpackCString# )
-import GHC.Ptr ( Ptr(..) )
+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}
\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
-> 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
data Doc
= Empty -- empty
| NilAbove Doc -- text "" $$ x
- | TextBeside !TextDetails FastInt Doc -- text s <> 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
data TextDetails = Chr {-#UNPACK#-}!Char
| Str String
- | PStr FastString -- a hashed string
- | LStr {-#UNPACK#-}!LitString FastInt -- 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),
#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
-- 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 -# 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
\begin{code}
nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
--- Specification: text s <> nilaboveNest g k q
+-- 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!
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
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
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 -# _ILIT(1)
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
fits :: FastInt -- Space available
-> Doc
-> Bool -- True if *first line* of Doc fits in space available
-
+
fits n p | n <# _ILIT(0) = False
fits n NoDoc = False
fits n Empty = True
@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 ""
-}
\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
let
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 >=# gap_width
lay1 (k +# shift) s sl p )))
other -> lay1 k s 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 +# 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 r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt`
indent (n -# _ILIT(8)) r
| otherwise = Str (spaces n) `txt` r
in
cant_fail = error "easy_display: NoDoc"
multi_ch n ch | n <=# _ILIT(0) = ""
- | otherwise = ch : multi_ch (n -# _ILIT(1)) ch
+ | otherwise = ch : multi_ch (n -# _ILIT(1)) ch
spaces n | n <=# _ILIT(0) = ""
| otherwise = ' ' : spaces (n -# _ILIT(1))
= 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'
-- 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
projects / ghc-hetmet.git / commitdiff