ghc/lib/prelude/Core.hs

   1 module PreludeCore (
   2         _integer_0,
   3         _integer_1,
   4         _integer_m1,
   5         fromRationalX,
   6         i0__,
   7         i1__,
   8         i2__,
   9         iminus1__,
  10         int2Integer,
  11         _showRational,
  12         r0__,
  13         r1__,
  14         rhalf__,
  15         _readList, _showList,
  16         _properFraction, _truncate, _round, _ceiling, _floor
  17     ) where
  18
  19 import Cls
  20 import IChar        -- instances
  21 import IDouble
  22 import IFloat
  23 import IInt
  24 import IInteger
  25 import IList
  26 import IRatio
  27 import List             ( reverse, dropWhile, take, drop, repeat, (++), head, tail )
  28 import Prel             ( (&&), (^^), (^), not, otherwise, asTypeOf, const, (.) )
  29 import PS               ( _PackedString, _unpackPS )
  30 import Text
  31 import TyComplex    -- for pragmas
  32
  33 -----------------------------------------------------------------
  34 -- some *** NON-STANDARD *** constants (to help compiling Cls.hs)
  35
  36 i0__, iminus1__, i1__, i2__ :: Num a => a
  37
  38 {-# SPECIALIZE i0__ :: Int, Integer #-}
  39
  40 i0__            = fromInteger 0
  41 iminus1__       = fromInteger (-1)
  42 i1__            = fromInteger 1
  43 i2__            = fromInteger 2
  44
  45 r0__, rhalf__, r1__ :: Fractional a => a
  46
  47 r0__            = fromRational 0
  48 rhalf__         = fromRational 0.5
  49 r1__            = fromRational 1
  50
  51 -- other bits of PreludeCore that aren't classes, instances, etc.
  52
  53 {- OLD:
  54 absReal         :: (Real a) => a -> a
  55 absReal x    | x >= 0    =  x
  56              | otherwise =  - x
  57
  58 signumReal      :: (Real a) => a -> a
  59 signumReal x | x == 0    =  0
  60              | x > 0     =  1
  61              | otherwise = -1
  62 -}
  63
  64 {- *RAW PRELUDE*: NOT REALLY USED:
  65 numericEnumFrom         :: (Real a) => a -> [a]
  66 numericEnumFromThen     :: (Real a) => a -> a -> [a]
  67 numericEnumFrom         =  iterate (+1)
  68 numericEnumFromThen n m =  iterate (+(m-n)) n
  69 -}
  70
  71 {- OLD:
  72 realFloatToRational :: (RealFloat a) => a -> Rational
  73 realFloatToRational x   =  (m%1)*(b%1)^^n
  74                            where (m,n) = decodeFloat x
  75                                  b     = floatRadix  x
  76 -}
  77
  78 {-
  79 [In response to a request by simonpj, Joe Fasel writes:]
  80
  81 A quite reasonable request!  This code was added to the Prelude just
  82 before the 1.2 release, when Lennart, working with an early version
  83 of hbi, noticed that (read . show) was not the identity for
  84 floating-point numbers.  (There was a one-bit error about half the time.)
  85 The original version of the conversion function was in fact simply
  86 a floating-point divide, as you suggest above.  The new version is,
  87 I grant you, somewhat denser.
  88
  89 How's this?
  90
  91 --Joe
  92 -}
  93
  94 --{-# GENERATE_SPECS rationalToRealFloat a{Double#,Double} #-}
  95 rationalToRealFloat :: (RealFloat a) => Rational -> a
  96
  97 rationalToRealFloat x   =  x'
  98         where x'    = f e
  99
 100 --              If the exponent of the nearest floating-point number to x
 101 --              is e, then the significand is the integer nearest xb^(-e),
 102 --              where b is the floating-point radix.  We start with a good
 103 --              guess for e, and if it is correct, the exponent of the
 104 --              floating-point number we construct will again be e.  If
 105 --              not, one more iteration is needed.
 106
 107               f e   = if e' == e then y else f e'
 108                       where y      = encodeFloat (round (x * (1%b)^^e)) e
 109                             (_,e') = decodeFloat y
 110               b     = floatRadix x'
 111
 112 --              We obtain a trial exponent by doing a floating-point
 113 --              division of x's numerator by its denominator.  The
 114 --              result of this division may not itself be the ultimate
 115 --              result, because of an accumulation of three rounding
 116 --              errors.
 117
 118               (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 119                                         / fromInteger (denominator x))
 120
 121 -------------------------------------------------------------------------
 122 -- These RealFrac things are here so we can
 123 -- SPECIALIZE the tapookies out of them.
 124 -- Also: get rid of gratuitous lazy pattern matching.
 125
 126 _properFraction     :: (RealFloat a, Integral b) => a -> (b,a)
 127 _truncate, _round   :: (RealFrac a, Integral b) => a -> b
 128 _ceiling, _floor    :: (RealFrac a, Integral b) => a -> b
 129
 130 {-# SPECIALIZE _properFraction
 131         :: Double -> (Int, Double)
 132   #-}
 133 {-# SPECIALIZE _truncate
 134         :: Double -> Int
 135   #-}
 136 {-# SPECIALIZE _round
 137         :: Double   -> Int,
 138            Rational -> Integer
 139   #-}
 140 {-# SPECIALIZE _ceiling
 141         :: Double -> Int
 142   #-}
 143 {-# SPECIALIZE _floor
 144         :: Double -> Int
 145   #-}
 146
 147 _properFraction x
 148   = case (decodeFloat x)      of { (m,n) ->
 149     let  b = floatRadix x     in
 150     if n >= 0 then
 151         (fromInteger m * fromInteger b ^ n, 0)
 152     else
 153         case (quotRem m (b^(-n))) of { (w,r) ->
 154         (fromInteger w, encodeFloat r n)
 155         }
 156     }
 157
 158 _truncate x =  case (properFraction x) of { (m, _) -> m }
 159
 160 _round x
 161   -- this defn differs from that in the report; uses _tagCmp
 162   --
 163   = case (properFraction x) of { (n,r) ->
 164     let
 165         m     = if r < r0__ then n - i1__ else n + i1__
 166         sign  = signum (abs r - rhalf__) --UNUSED!
 167
 168         half_down = abs r - rhalf__
 169     in
 170     case (_tagCmp half_down r0__) of
 171       _LT -> n
 172       _EQ -> if even n then n else m
 173       _GT -> m
 174 {- OLD:
 175     if sign == iminus1__ then n
 176     else if sign == i0__ then (if even n then n else m)
 177     else if sign == i1__ then m
 178     else error "_round{PreludeCore}: no match in sign\n"
 179 -}
 180     }
 181
 182 _ceiling x
 183   = case (properFraction x) of { (n,r) ->
 184     if r > r0__ then n + i1__ else n }
 185
 186 _floor x
 187   = case (properFraction x) of { (n,r) ->
 188     if r < r0__ then n - i1__ else n }
 189
 190 -------------------------------------------------------------------------
 191 -- from/by Lennart, 94/09/26
 192
 193 --module Rational(prRational, fromRationalX, tinyDouble, tinyFloat, hugeDouble, hugeFloat, tiny, huge, integerLogBase) where
 194
 195 -- Convert a Rational to a string that looks like a floating point number,
 196 -- but without converting to any floating type (because of the possible overflow).
 197 _showRational :: Int -> Rational -> String
 198 _showRational n r =
 199     if r == 0 then
 200         "0.0"
 201     else
 202         let (r', e) = normalize r
 203         in  prR n r' e
 204
 205 startExpExp = 4 :: Int
 206
 207 -- make sure 1 <= r < 10
 208 normalize :: Rational -> (Rational, Int)
 209 normalize r = if r < 1 then case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1) else norm startExpExp r 0
 210         where norm :: Int -> Rational -> Int -> (Rational, Int)
 211               -- Invariant: r*10^e == original r
 212               norm 0  r e = (r, e)
 213               norm ee r e =
 214                 let n = 10^ee
 215                     tn = 10^n
 216                 in  if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
 217
 218 drop0 "" = ""
 219 drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
 220
 221 prR :: Int -> Rational -> Int -> String
 222 prR n r e | r <   1 = prR n (r*10) (e-1)                -- final adjustment
 223 prR n r e | r >= 10 = prR n (r/10) (e+1)
 224 prR n r e0 =
 225         let s = show ((_round (r * 10^n))::Integer)
 226             e = e0+1
 227         in  if e > 0 && e < 8 then
 228                 take e s ++ "." ++ drop0 (drop e s)
 229             else if e <= 0 && e > -3 then
 230                 "0." ++ take (-e) (repeat '0') ++ drop0 s
 231             else
 232                 head s : "."++ drop0 (tail s) ++ "e" ++ show e0
 233
 234 ------------
 235
 236 -- The Prelude version of fromRational is broken; if the denominator or nominator is
 237 -- out of range it fails.  So we use this (very expensive!) version instead.
 238
 239 fromRationalX :: (RealFloat a) => Rational -> a
 240
 241 fromRationalX r =
 242   rationalToRealFloat r
 243 {- Hmmm...
 244         let
 245             h = ceiling (huge `asTypeOf` x)
 246             b = toInteger (floatRadix x)
 247             x = fromRat 0 r
 248
 249             fromRat e0 r' =
 250 {--}            _trace (shows e0 ('/' : shows r' ('/' : shows h "\n"))) (
 251                 let d = denominator r'
 252                     n = numerator r'
 253                 in  if d > h then
 254                        let e = integerLogBase b (d `div` h) + 1
 255                        in  fromRat (e0-e) (n % (d `div` (b^e)))
 256                     else if abs n > h then
 257                        let e = integerLogBase b (abs n `div` h) + 1
 258                        in  fromRat (e0+e) ((n `div` (b^e)) % d)
 259                     else
 260                        scaleFloat e0 (rationalToRealFloat r')
 261                        -- now that we know things are in-bounds,
 262                        -- we use the "old" Prelude code.
 263 {--}            )
 264         in  x
 265 -}
 266
 267 -- Compute the discrete log of i in base b.
 268 -- Simplest way would be just divide i by b until it's smaller then b, but that would
 269 -- be very slow!  We are just slightly more clever.
 270 integerLogBase :: Integer -> Integer -> Int
 271 integerLogBase b i =
 272      if i < b then
 273         0
 274      else
 275         -- Try squaring the base first to cut down the number of divisions.
 276         let l = 2 * integerLogBase (b*b) i
 277             doDiv :: Integer -> Int -> Int
 278             doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
 279         in  doDiv (i `div` (b^l)) l
 280
 281
 282 ------------
 283
 284 -- Compute smallest and largest floating point values.
 285 tiny :: (RealFloat a) => a
 286 tiny =
 287         let (l, _) = floatRange x
 288             x = encodeFloat 1 (l-1)
 289         in  x
 290
 291 huge :: (RealFloat a) => a
 292 huge =
 293         let (_, u) = floatRange x
 294             d = floatDigits x
 295             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
 296         in  x
 297
 298 tinyDouble = tiny :: Double
 299 tinyFloat  = tiny :: Float
 300 hugeDouble = huge :: Double
 301 hugeFloat  = huge :: Float
 302
 303 -----------------------------------------------------------------
 304 -- It is problematic having this in Cls.hs
 305 -- (You really don't want to know why -- WDP 94/12)
 306 --
 307 _readList :: Text a => ReadS [a]
 308
 309 _readList   = readParen False (\r -> [pr | ("[",s)  <- lex r,
 310                                            pr       <- readl s])
 311               where readl  s = [([],t)   | ("]",t)  <- lex s] ++
 312                                [(x:xs,u) | (x,t)    <- reads s,
 313                                            (xs,u)   <- readl2 t]
 314                     readl2 s = [([],t)   | ("]",t)  <- lex s] ++
 315                                [(x:xs,v) | (",",t)  <- lex s,
 316                                            (x,u)    <- reads t,
 317                                            (xs,v)   <- readl2 u]
 318
 319 _showList :: Text a => [a] -> ShowS
 320
 321 _showList [] = showString "[]"
 322 _showList (x:xs)
 323              = showChar '[' . shows x . showl xs
 324
 325                where showl []     = showChar ']'
 326                      showl (x:xs) = showString ", " . shows x . showl xs