[project @ 2003-08-15 12:43:57 by simonmar]

[ghc-hetmet.git] / ghc / compiler / utils / Pretty.lhs

diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index c033683..ab9864b 100644 (file)
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -55,10 +55,10 @@ Version 3.0     28 May 1997
     The "fragments" are encapsulated in the TextDetails data type:
         data TextDetails = Chr  Char
                          | Str  String
     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
 
     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 ()),
 
     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 ()),

@@ -158,7 +158,7 @@ module Pretty (
 
         empty, isEmpty, nest,
 
 
         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,
         int, integer, float, double, rational,
         parens, brackets, braces, quotes, doubleQuotes,
         semi, comma, colon, space, equals,

@@ -172,16 +172,33 @@ module Pretty (
         hang, punctuate,
         
 --      renderStyle,            -- Haskell 1.3 only
         hang, punctuate,
         
 --      renderStyle,            -- Haskell 1.3 only

-        render, fullRender, printDoc
+        render, fullRender, printDoc, showDocWith

   ) where
 
 #include "HsVersions.h"
 
 import FastString
   ) where
 
 #include "HsVersions.h"
 
 import FastString

-import GlaExts
+import PrimPacked      ( strLength )
+
+import GLAEXTS
+

 import Numeric (fromRat)
 import IO
 
 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
 
 infixl 6 <> 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
 infixl 6 <> 

@@ -493,7 +510,9 @@ reduceDoc p              = p
 
 data TextDetails = Chr  Char
                  | Str  String
 
 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}
 space_text = Chr ' '
 nl_text    = Chr '\n'
 \end{code}

@@ -581,7 +600,14 @@ isEmpty _     = False
 
 char  c = textBeside_ (Chr c) 1# Empty
 text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
 
 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
 
 
 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
 

@@ -884,12 +910,28 @@ renderStyle Style{mode, lineLength, ribbonsPerLine} doc
   = fullRender mode lineLength ribbonsPerLine doc ""
 -}
 
   = 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 (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}
 \end{code}
 
 \begin{code}

@@ -920,7 +962,7 @@ fullRender mode line_length ribbons_per_line txt end doc
     best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
 
     hacked_line_length, ribbon_length :: Int
     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
     hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
 
 display mode IBOX(page_width) IBOX(ribbon_width) txt end doc

@@ -975,11 +1017,26 @@ pprCols = (100 :: Int) -- could make configurable
 
 printDoc :: Mode -> Handle -> Doc -> IO ()
 printDoc mode hdl doc
 
 printDoc :: Mode -> Handle -> Doc -> IO ()
 printDoc mode hdl doc

-  = fullRender mode pprCols 1.5 put done 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 
   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'
 
     done = hPutChar hdl '\n'

+
+#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}
 \end{code}