--- from Lennart
-fromRationalX :: (RealFloat a) => Rational -> a
-
-fromRationalX r =
- let
- h = ceiling (huge `asTypeOf` x)
- b = toInteger (floatRadix x)
- x = fromRat 0 r
- fromRat e0 r' =
- let d = denominator r'
- n = numerator r'
- in if d > h then
- let e = integerLogBase b (d `div` h) + 1
- in fromRat (e0-e) (n % (d `div` (b^e)))
- else if abs n > h then
- let e = integerLogBase b (abs n `div` h) + 1
- in fromRat (e0+e) ((n `div` (b^e)) % d)
- else
- scaleFloat e0 (fromRational r')
- in x
-
--- Compute the discrete log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b, but that would
--- be very slow! We are just slightly more clever.
-integerLogBase :: Integer -> Integer -> Int
-integerLogBase b i =
- if i < b then
- 0
- else
- -- Try squaring the base first to cut down the number of divisions.
- let l = 2 * integerLogBase (b*b) i
-
- doDiv :: Integer -> Int -> Int
- doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
- in
- doDiv (i `div` (b^l)) l
-
-
-------------
-
--- Compute smallest and largest floating point values.
-{-
-tiny :: (RealFloat a) => a
-tiny =
- let (l, _) = floatRange x
- x = encodeFloat 1 (l-1)
- in x
--}
+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'
+
+ -- 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
+
+-- 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.
+--
+-- (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.
+
+printLeftRender :: Handle -> Doc -> IO ()
+printLeftRender hdl doc = do
+ b <- newBufHandle hdl
+ layLeft b (reduceDoc doc)
+ bFlush b
+
+-- 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
+ 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
projects / ghc-hetmet.git / blobdiff