diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,1 +1,6 @@ +0.2.0: Raw interface for non-RealFloat types + Back to the old integerToDigits because we may now deal with + larger Integers, the performance loss for Double/Float is + small enough to accept. +0.1.1: Leaner integerToDigits 0.1: First release diff --git a/Text/FShow/Raw.hs b/Text/FShow/Raw.hs new file mode 100644 --- /dev/null +++ b/Text/FShow/Raw.hs @@ -0,0 +1,292 @@ +-- | +-- Module: Text.FShow.Raw +-- Copyright: (c) 2011 Daniel Fischer +-- Licence: BSD3 +-- Maintainer: Daniel Fischer +-- Stability: experimental +-- Portability: non-portable (GHC extensions) +-- +-- Lower level conversion of base-2 numbers to base-10 representations. +-- These functions can be used to define 'Show' instances for types which +-- don't support the full 'RealFloat' interface but have an analogue to +-- 'decodeFloat' (and maybe to 'isNaN', 'isInfinite' and 'isNegativeZero'). +module Text.FShow.Raw + ( -- * Classes + BinDecode(..) + , DecimalFormat(..) + -- * Format type + , FormatStyle(..) + -- * Functions + -- ** Medium level + , decimalFormat + , binDecFormat + -- ** Low level + , rawFormat + , fullRawFormat + , formatDigits + -- ** Dangerous + , posToDigits + -- ** Auxiliary + , fullDecimalDigits + , integerLog2 + ) where + +import Text.FShow.RealFloat.Internals + +import Data.Maybe (fromMaybe) + +-- | Class for types whose values can be decoded into the form +-- @m * 2^e@ with an 'Integer' mantissa @m@ and an 'Int' exponent @e@. +-- +-- Minimal complete definition: one of 'decode' and 'decodeL'. +-- +-- It is strongly recommended to override the default implementation +-- of 'showDigits' if the datatype allows distinguishing values +-- without using an exact representation. +class BinDecode a where + -- | 'decode' is analogous to 'decodeFloat'. + {-# INLINE decode #-} + decode :: a -> (Integer, Int) + decode x = case decodeL x of + (_, n, e) -> (n, e) + -- | 'decodeL' gives the integer base-@2@ logarithm of the mantissa + -- in addition to the result of 'decode'. If the absolute value of + -- the mantissa always has the same highest set bit (excepting @0@), + -- specifying that as a constant will be faster than calculating the + -- logarithm for each individual mantissa. + -- If @x = m*2^e@ with @m /= 0@, then + -- @'decodeL' x == ('integerLog2' (abs m), m, e)@ must hold. + {-# INLINE decodeL #-} + decodeL :: a -> (Int, Integer, Int) + decodeL x = case decode x of + (0,_) -> (0,0,0) + (n,e) -> (integerLog2 (abs n), n, e) + -- | The number of significant digits needed to uniquely determine the + -- value (or however many digits are desired). Usually, 'showDigits' + -- will be a constant function, but that is not necessary. However, + -- all values of 'showDigits' must be positive. + -- + -- If the mantissa always has the same highest bit, @highBit@, set + -- when it is nonzero, + -- + -- @ + -- 'showDigits' _ = 2 + 'floor' ((highBit+1) * 'logBase 10 2) + -- @ + -- + -- is sufficient to make the values and formatted 'String's + -- uniquely determine each other and in general this is the smallest + -- number to achieve that (calculate the number once and supply the + -- result as a constant). + -- + -- If the highest set bit of nonzero mantissae varies, things are not + -- so easy. If the width of mantissae is bounded, plugging the largest + -- possible value into the above formula works, but may yield an unduly + -- large number for common cases. Using the formula with @highBit@ + -- determined by the mantissa almost works, but if the representation + -- is rounded at all, with sufficiently many bits in the mantissa, + -- there will be values between the original and the representation. + -- So, with mantissae of width varying over a large range, the only + -- feasible way of obtaining a bijection between values and their + -- decimal representations is printing to full precision in + -- general, optionally capping atthe upper limit. + -- + -- The default implementation prints values exactly, which in general + -- is undesirable because it involves huge 'Integer's and long + -- representations. + {-# INLINE showDigits #-} + showDigits :: a -> Int + showDigits x = case decodeL x of + (a, _, e) -> fullDecimalDigits a e + +-- | Class for types whose values may be @NaN@ or infinite and can +-- otherwise be decoded into the form @m * 2^e@. +class (Num a, Ord a, BinDecode a) => DecimalFormat a where + -- | @'nanTest'@ defaults to @'const' 'False'@ + {-# INLINE nanTest #-} + nanTest :: a -> Bool + nanTest _ = False + -- | @'infTest'@ defaults to @'const' 'False'@ + {-# INLINE infTest #-} + infTest :: a -> Bool + infTest _ = False + -- | @'negTest' x@ defaults to @x < 0@, it must be overridden if + -- negative zero has to be accounted for. + {-# INLINE negTest #-} + negTest :: a -> Bool + negTest x = x < 0 + +-- | The Style in which to format the display 'String' +data FormatStyle + = Exponent -- ^ Display in scientific notation, e.g. @1.234e-5@ + | Fixed -- ^ Display in standard decimal notation, e.g. @0.0123@ + -- or @123.456@ + | Generic (Maybe (Int,Int)) + -- ^ Use 'Fixed' for numbers with magnitude close enough to @1@, + -- 'Exponent' otherwise. The default range for using 'Fixed' + -- is @0.1 <= |x| < 10^7@, corresponding to @'Generic' ('Just' (-1,7))@. + +-- | @'fullDecimalDigits' a e@ calculates the number of decimal digits that +-- may be required to exactly display a value @x = m * 2^e@ where @m@ is +-- an 'Integer' satisfying @2^a <= m < 2^(a+1)@. Usually, the calculated +-- value is not much larger than the actual number of digits in the +-- exact decimal representation, but it will be if the exponent @e@ +-- is negative and has large absolute value and the mantissa is divisible +-- by a large power of @2@. +fullDecimalDigits :: Int -> Int -> Int +fullDecimalDigits a e + | e >= 0 = q+2 + | p > 0 = q+1-e + | otherwise = q-e + where + p = a+e+1 + q = (p*8651) `quot` 28738 + +-- | 'rawFormat' is a low-level formatter. The sign is determined from +-- the sign of the mantissa. +rawFormat :: (a -> (Int,Integer,Int)) -- ^ decoder, same restrictions as 'decodeL' + -> Int -- ^ number of significant digits + -> FormatStyle -- ^ formatting style + -> Maybe Int -- ^ desired precision + -> a -- ^ value to be displayed + -> String +rawFormat decoder decimals fmt prec x + | mt < 0 = '-':formatDigits fmt decimals prec digits ex1 + | mt == 0 = formatDigits fmt decimals prec [0] 0 + | otherwise = formatDigits fmt decimals prec digits ex1 + where + (md,mt,ex) = decoder x + (digits,ex1) = posToDigits decimals md (abs mt) ex + +-- | 'fullRawFormat' is a low-level formatter producing an exact representation +-- of a value which can be decoded into the form @m * 2^e@. +fullRawFormat :: (a -> (Int,Integer,Int)) -- ^ decoder, same restriction as 'decodeL' + -> FormatStyle -- ^ formatting style + -> a -- ^ value to be displayed + -> String +fullRawFormat decoder fmt x + | mt < 0 = '-':formatDigits fmt decs Nothing digits ex1 + | mt == 0 = formatDigits fmt 2 Nothing [0] 0 + | otherwise = formatDigits fmt decs Nothing digits ex1 + where + (md, mt, ex) = decoder x + decs = fullDecimalDigits md ex + (digits, ex1) = posToDigits decs md (abs mt) ex + +-- | 'binDecFormat' is the formatter for instances of the 'BinDecode' +-- class. Any special values must be processed before it is called. +-- It fills in the missing arguments before calling 'rawFormat'. +{-# INLINE binDecFormat #-} +binDecFormat :: BinDecode a => FormatStyle -> Maybe Int -> a -> String +binDecFormat fmt decs x = rawFormat decodeL (showDigits x) fmt decs x + +-- | 'decimalFormat' is a slightly higher-level formatter, treating the +-- special cases of @NaN@ and infinities. +decimalFormat :: DecimalFormat a => FormatStyle -> Maybe Int -> a -> String +decimalFormat fmt decs x + | nanTest x = "NaN" + | infTest x = if negTest x then "-Infinity" else "Infinity" + | negTest x = '-':formatDigits fmt sd decs digits ex1 + | otherwise = formatDigits fmt sd decs digits ex1 + where + sd = showDigits x + (md,mt,ex) = decodeL (abs x) + (digits,ex1) + | mt == 0 = ([0],0) + | otherwise = posToDigits sd md mt ex + +-- | 'formatDigits' builds the display 'String' from the digits and +-- the exponent of a nonnegative number. +{-# INLINE formatDigits #-} +formatDigits :: FormatStyle -- ^ formatting style + -> Int -- ^ number of significant digits required + -> Maybe Int -- ^ desired precision + -> [Int] -- ^ list of significant digits + -> Int -- ^ base-@10@ logarithm + -> String +formatDigits style sig decs digits ex = + case style of + Generic rg -> let dst = case fromMaybe (-1,7) rg of + (lo, hi) -> if lo <= ex && ex < hi + then Fixed else Exponent + in formatDigits dst sig decs digits ex + Exponent -> + case decs of + Nothing -> + let (c,d:ds) = roundToS sig digits + show_e = show (ex+c) + fluff :: [Int] -> [Int] + fluff [] = [0] + fluff xs = xs + in case digits of + [0] -> "0.0e0" + _ -> i2D d : '.' : map i2D (fluff ds) ++ 'e' : show_e + Just pl -> + let sd = max 1 pl + in case digits of + [0] -> '0' : '.' : take sd (repeat '0') ++ "e0" + _ -> + let (c,digs) = roundTo (sd+1) digits + (d:ds) = map i2D (if c == 0 then digs else init digs) + in d : '.' : ds ++ 'e' : show (ex+c) + Fixed -> + let mk0 ls = case ls of { "" -> "0" ; _ -> ls} + in case decs of + Nothing -> + let (c,is) = roundToS sig digits + e' = ex+1+c + ds = map i2D is + in case digits of + [0] -> "0.0" + _ | e' <= 0 -> "0." ++ replicate (-e') '0' ++ ds + | otherwise -> + let f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in f e' "" ds + Just pl -> + let dec = max 0 pl + e' = ex+1 + in + if e' >= 0 then + let (c,is') = roundTo (dec + e') digits + (ls,rs) = splitAt (e'+c) (map i2D is') + in mk0 ls ++ (if null rs then "" else '.':rs) + else + let (c,is') = roundTo dec (replicate (-e') 0 ++ digits) + d:ds' = map i2D (if c == 0 then 0:is' else is') + in d : (if null ds' then "" else '.':ds') + +roundToS :: Int -> [Int] -> (Int,[Int]) +roundToS d is = + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundToS: bad Value" + where + f _ [] = (0, []) + f 0 (x:_) = (if x < 5 then 0 else 1, []) + f n (i:xs) + | i' == 10 = (1,prep 0 ds) + | otherwise = (0,prep i' ds) + where + prep 0 [] = [] + prep a bs = a:bs + (c,ds) = f (n-1) xs + i' = c + i + +roundTo :: Int -> [Int] -> (Int,[Int]) +roundTo d is = + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + f n [] = (0, replicate n 0) + f 0 (x:_) = (if x < 5 then 0 else 1, []) + f n [i] = (if i < 5 then 0 else 1, replicate n 0) + f n (i:xs) + | i' == 10 = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) xs + i' = c + i diff --git a/Text/FShow/RealFloat.hs b/Text/FShow/RealFloat.hs --- a/Text/FShow/RealFloat.hs +++ b/Text/FShow/RealFloat.hs @@ -194,6 +194,15 @@ fshowGFloat :: (DispFloat a) => Maybe Int -> a -> ShowS fshowGFloat d x = showString (formatFloat FFGeneric d x) +{- +Code duplication ahead. The below code is - with minor modifications - +replicated in Text.FShow.Raw. +Yuck! +But reusing that interface here costs too much performance here, so +this is staying. +'Tis a library, it needn't be pretty, it's gotta be fast. +-} + data FFFormat = FFExponent | FFFixed | FFGeneric {-# SPECIALISE formatFloat :: FFFormat -> Maybe Int -> Double -> String, @@ -217,11 +226,11 @@ doFmt format (is, e) = case format of FFGeneric -> - doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) (is,e) + doFmt (if e < (-1) || e > 6 then FFExponent else FFFixed) (is,e) FFExponent -> case decs of Nothing -> - let show_e' = if ei == 0 then show (e-1) else show e + let show_e' = show (e+ei) (ei,(d:ds)) = roundToS (decDigits x) is in case is of [0] -> "0.0e0" @@ -231,32 +240,34 @@ case is of [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0" _ -> let (ei,is') = roundTo (dec'+1) is - (d:ds') = map i2D (if ei > 0 then init is' else is') - in d:'.':ds' ++ 'e':show (e-1+ei) + (d:ds') = map i2D (if ei == 0 then is' else init is') + in d:'.':ds' ++ 'e':show (e+ei) FFFixed -> let mk0 ls = case ls of { "" -> "0" ; _ -> ls} in case decs of Nothing -> let (ei, is') = roundToS (decDigits x) is - e' = e+ei + e' = e+1+ei ds = map i2D is' in case is of [0] -> "0.0" - _ | e' <= 0 -> "0." ++ replicate (-e') '0' ++ map i2D is' + _ | e' <= 0 -> "0." ++ replicate (-e') '0' ++ ds | otherwise -> let f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs f n s "" = f (n-1) ('0':s) "" f n s (r:rs) = f (n-1) (r:s) rs in f e' "" ds Just dec -> - let dec' = max dec 0 in - if e >= 0 then - let (ei,is') = roundTo (dec' + e) is - (ls,rs) = splitAt (e+ei) (map i2D is') + let dec' = max dec 0 + e' = e+1 + in + if e' >= 0 then + let (ei,is') = roundTo (dec' + e') is + (ls,rs) = splitAt (e'+ei) (map i2D is') in mk0 ls ++ (if null rs then "" else '.':rs) else - let (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) - d:ds' = map i2D (if ei > 0 then is' else 0:is') + let (ei,is') = roundTo dec' (replicate (-e') 0 ++ is) + d:ds' = map i2D (if ei == 0 then 0:is' else is') in d : (if null ds' then "" else '.':ds') roundToS :: Int -> [Int] -> (Int,[Int]) @@ -267,7 +278,7 @@ _ -> error "roundToS: bad Value" where f _ [] = (0, []) - f 0 (x:_) = (if x >= 5 then 1 else 0, []) + f 0 (x:_) = (if x < 5 then 0 else 1, []) f n (i:xs) | i' == 10 = (1,prep 0 ds) | otherwise = (0,prep i' ds) @@ -285,7 +296,8 @@ _ -> error "roundTo: bad Value" where f n [] = (0, replicate n 0) - f 0 (x:_) = (if x >= 5 then 1 else 0, []) + f 0 (x:_) = (if x < 5 then 0 else 1, []) + f n [i] = (if i < 5 then 0 else 1, replicate n 0) f n (i:xs) | i' == 10 = (1,0:ds) | otherwise = (0,i':ds) diff --git a/Text/FShow/RealFloat/Internals.hs b/Text/FShow/RealFloat/Internals.hs --- a/Text/FShow/RealFloat/Internals.hs +++ b/Text/FShow/RealFloat/Internals.hs @@ -13,6 +13,7 @@ module Text.FShow.RealFloat.Internals ( posToDigits , i2D + , integerLog2 ) where #include "MachDeps.h" @@ -23,7 +24,24 @@ import Data.Array.Base (unsafeAt) import Data.Array.IArray +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Base +import GHC.Integer.Logarithms +-- | Integer base-@2@ logarithm of a positive 'Integer'. +{-# INLINE integerLog2 #-} +integerLog2 :: Integer -> Int +integerLog2 n = I# (integerLog2# n) +#else +import GHC.Float (integerLogBase) + +-- | Integer base-@2@ logarithm of a positive 'Integer'. +{-# INLINE integerLog2 #-} +integerLog2 :: Integer -> Int +integerLog2 = integerLogBase 2 +#endif + + #if WORD_SIZE_IN_BITS == 32 #define DIGITS 9 #define BASE 1000000000 @@ -37,10 +55,38 @@ i2D :: Int -> Char i2D (I# i#) = C# (chr# (ord# '0'# +# i#)) --- digits and exponent for a floating point number. --- floatRadix is assumed to be 2, decodeFloat to return --- a mantissa 2^(floatDigits-1) <= mantissa < 2^floatDigits -posToDigits :: Int -> Int -> Integer -> Int -> ([Int],Int) +-- | 'posToDigits' converts a positive number into a list of digits and +-- an exponent. If @x = 10^e*d_1.d_2...d_m...@ with @d_1 /= 0@ and +-- @0 <= d_i <= 9@, the result is @([d_1,d_2,...,d_m],e)@, where +-- @m@ is one or two larger than the number of requested digits, +-- provided that @2^(-70776) <= x < 2^248236@ (with 64-bit 'Int's, +-- the upper bound is about @2^1.3e9@). +-- +-- The number @x@ is (indirectly) given in the form +-- @mantissa * 2^exponent@, similar to 'encodeFloat', +-- as the final two arguments. The second argument is the base-2 +-- logarithm of the mantissa and the first is the number of decimal +-- digits needed to discriminate between different numbers. +-- +-- In @'posToDigits' digs mlog mant exp@, it is assumed that +-- +-- * @digs > 0@, @mlog >= 0@, +-- +-- * @2^mlog <= mant < 2^(mlog+1)@. +-- +-- These assumptions are not checked, and if they're not satisfied, +-- wrong results or worse are the consequences. /You have been warned/. +-- +-- The digits argument may be smaller than would be necessary to uniquely +-- determine each value if that is not required. As a rule of thumb, +-- requiring fewer significant digits means faster generation of the +-- representation. +{-# INLINE posToDigits #-} +posToDigits :: Int -- ^ number of digits required + -> Int -- ^ base @2@ logarithm of the mantissa + -> Integer -- ^ mantissa + -> Int -- ^ scaling exponent + -> ([Int], Int) posToDigits showDigs mantExp mant scaleExp@(I# e#) = (integerToDigits decMant, e10) where !rex = mantExp + scaleExp @@ -57,7 +103,7 @@ | binshift <# 0# = shiftRInteger (mant * expt5 decshift) (negateInt# binshift) | otherwise = shiftLInteger (mant * expt5 decshift) binshift - !e10 = if decMant < expt10 (showDigs+1) then l10+1 else l10+2 + !e10 = if decMant < expt10 (showDigs+1) then l10 else l10+1 expt5 :: Int -> Integer expt5 k = if k <= maxEx5 && k >= 0 then unsafeAt expts5 k else 5^k @@ -85,14 +131,56 @@ -- Divide and conquer implementation -- generate the sequence of digits of a positive Integer integerToDigits :: Integer -> [Int] -integerToDigits nm = integerToDigits' nm [] - -integerToDigits' :: Integer -> [Int] -> [Int] -integerToDigits' nm ds - | nm < BASE = jhead (fromInteger nm) ds - | otherwise = case nm `quotRemInteger` BASE of - (# q, r #) -> integerToDigits' q (jblock (fromInteger r) ds) +integerToDigits nm + | nm < BASE = jhead (fromInteger nm) [] + | otherwise = jprinth (jsplitf (BASE*BASE) nm) [] where + + -- Split n into digits in base p. We first split n into digits + -- in base p*p and then split each of these digits into two. + -- Note that the first 'digit' modulo p*p may have a leading zero + -- in base p that we need to drop - this is what jsplith takes care of. + -- jsplitb the handles the remaining digits. + jsplitf :: Integer -> Integer -> [Integer] + jsplitf p n + | p > n = [n] + | otherwise = jsplith p (jsplitf (p*p) n) + + jsplith :: Integer -> [Integer] -> [Integer] + jsplith p (n:ns) = + case n `quotRemInteger` p of + (# q, r #) -> + if q > 0 then q : r : jsplitb p ns + else r : jsplitb p ns + jsplith _ [] = error "jsplith: []" + + jsplitb :: Integer -> [Integer] -> [Integer] + jsplitb _ [] = [] + jsplitb p (n:ns) = case n `quotRemInteger` p of + (# q, r #) -> + q : r : jsplitb p ns + + -- Convert a number that has been split into digits in base BASE^2 + -- this includes a last splitting step and then conversion of digits + -- that all fit into a machine word. + jprinth :: [Integer] -> [Int] -> [Int] + jprinth (n:ns) cs = + case n `quotRemInteger` BASE of + (# q', r' #) -> + let q = fromInteger q' + r = fromInteger r' + in if q > 0 then jhead q $ jblock r $ jprintb ns cs + else jhead r $ jprintb ns cs + jprinth [] _ = error "jprinth []" + + jprintb :: [Integer] -> [Int] -> [Int] + jprintb [] cs = cs + jprintb (n:ns) cs = case n `quotRemInteger` BASE of + (# q', r' #) -> + let q = fromInteger q' + r = fromInteger r' + in jblock q $ jblock r $ jprintb ns cs + -- Convert an integer that fits into a machine word. Again, we have two -- functions, one that drops leading zeros (jhead) and one that doesn't -- (jblock) diff --git a/floatshow.cabal b/floatshow.cabal --- a/floatshow.cabal +++ b/floatshow.cabal @@ -7,13 +7,14 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.1 +Version: 0.2.0 -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6 -- A short (one-line) description of the package. -Synopsis: Alternative faster String representations for Double and Float +Synopsis: Alternative faster String representations for Double and Float, + String representations for more general numeric types. -- A longer description of the package. Description: The String representations provided by this package @@ -26,6 +27,10 @@ shorter representation, the display functions of this package can be faster, sometimes by a big margin. + Text.FShow.Raw provides building blocks for representations + of numeric types which don't belong to RealFloat but have + some of its functionality. + The bulk of the code is a minor modification of code from the base package, whence the GHC License is included as an extra-source-file. @@ -67,6 +72,7 @@ Library -- Modules exported by the library. Exposed-modules: Text.FShow.RealFloat + Text.FShow.Raw -- Packages needed in order to build this package. Build-depends: base >= 4 && < 5, array >= 0.1 && < 0.4