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
= 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}
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
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