The "fragments" are encapsulated in the TextDetails data type:
data TextDetails = Chr Char
| Str String
- | PStr FAST_STRING
+ | PStr FastString
The Chr and Str constructors are obvious enough. The PStr constructor has a packed
- string (FAST_STRING) inside it. It's generated by using the new "ptext" export.
+ string (FastString) inside it. It's generated by using the new "ptext" export.
An advantage of this new setup is that you can get the renderer to do output
directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
empty, isEmpty, nest,
- text, char, ptext,
+ text, char, 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
+ render, fullRender, printDoc, showDocWith
) where
#include "HsVersions.h"
import FastString
-import GlaExts
+import PrimPacked ( strLength )
+
+import GLAEXTS
+
import Numeric (fromRat)
+import IO
+
+#if __GLASGOW_HASKELL__ < 503
+import IOExts ( hPutBufFull )
+#else
+import System.IO ( hPutBuf )
+#endif
+
+#if __GLASGOW_HASKELL__ < 503
+import PrelBase ( unpackCString# )
+#else
+import GHC.Base ( unpackCString# )
+#endif
+
+import PrimPacked ( Ptr(..) )
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
#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#
data Doc
= Empty -- empty
| NilAbove Doc -- text "" $$ x
- | TextBeside TextDetails INT Doc -- text s <> x
+ | TextBeside !TextDetails INT Doc -- text s <> x
| Nest INT Doc -- nest k x
| Union Doc Doc -- ul `union` ur
| NoDoc -- The empty set of documents
data TextDetails = Chr Char
| Str String
- | PStr FAST_STRING
+ | PStr FastString -- a hashed string
+ | LStr Addr# Int# -- a '\0'-terminated array of bytes
+
space_text = Chr ' '
nl_text = Chr '\n'
\end{code}
char c = textBeside_ (Chr c) 1# Empty
text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
-ptext s = case _LENGTH_ s of {IBOX(sl) -> textBeside_ (PStr 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}
+
+-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
+-- intermediate packing/unpacking of the string.
+{-# RULES
+ "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
+ #-}
nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
*********************************************************
\begin{code}
-best :: Mode
- -> Int -- Line length
+best :: Int -- Line length
-> Int -- Ribbon length
-> RDoc
-> RDoc -- No unions in here!
-best OneLineMode IBOX(w) IBOX(r) p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode IBOX(w) IBOX(r) p
+best IBOX(w) IBOX(r) p
= get w p
where
get :: INT -- (Remaining) width of line
first p q | nonEmptySet p = p
| otherwise = q
-nonEmptySet NoDoc = False
+nonEmptySet NoDoc = False
nonEmptySet (p `Union` q) = True
nonEmptySet Empty = True
nonEmptySet (NilAbove p) = True -- NoDoc always in first line
= fullRender mode lineLength ribbonsPerLine doc ""
-}
-render doc = showDoc doc ""
-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
+render doc = showDocWith PageMode doc
+showDoc doc rest = showDocWithAppend PageMode doc rest
+
+showDocWithAppend :: Mode -> Doc -> String -> String
+showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
+
+showDocWith :: Mode -> Doc -> String
+showDocWith mode doc = showDocWithAppend mode doc ""
string_txt (Chr c) s = c:s
string_txt (Str s1) s2 = s1 ++ s2
-string_txt (PStr s1) s2 = _UNPK_ 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 = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc 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 (Nest k p) = lay p
+ lay Empty = end
+ 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
+ = 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
fullRender mode line_length ribbons_per_line txt end doc
= display mode line_length ribbon_length txt end best_doc
where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
+ best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
hacked_line_length, ribbon_length :: Int
- ribbon_length = round (fromInt line_length / ribbons_per_line)
+ ribbon_length = round (fromIntegral line_length / ribbons_per_line)
hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
}}
cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
| otherwise = spaces n
spaces ILIT(0) = ""
spaces n = ' ' : spaces (n MINUS ILIT(1))
\end{code}
+
+\begin{code}
+pprCols = (120 :: Int) -- could make configurable
+
+printDoc :: Mode -> Handle -> Doc -> IO ()
+printDoc LeftMode hdl doc
+ = do { printLeftRender hdl doc; hFlush hdl }
+printDoc mode hdl doc
+ = do { fullRender mode pprCols 1.5 put done doc ;
+ 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
+
+ done = hPutChar hdl '\n'
+
+-- basically a specialised version of fullRender for LeftMode with IO output.
+printLeftRender :: Handle -> Doc -> IO ()
+printLeftRender hdl 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 = hPutChar hdl '\n'
+ lay (NilAbove p) = hPutChar hdl '\n' >> lay p
+ lay (TextBeside s sl p) = put s >> lay p
+
+ put (Chr c) = hPutChar hdl c
+ put (Str s) = hPutStr hdl s
+ put (PStr s) = hPutFS hdl s
+ put (LStr s l) = hPutLitString hdl s l
+
+#if __GLASGOW_HASKELL__ < 503
+hPutBuf = hPutBufFull
+#endif
+
+ -- 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
+\end{code}
projects / ghc-hetmet.git / blobdiff