ghc/lib/prelude/Core.hs

   1 module PreludeCore (
   2         __i0,
   3         __i1,
   4         __i2,
   5         __im1,
   6         __i8,
   7         __i10,
   8         __i16,
   9         __rhalf,
  10         _fromRational,
  11         _showRational,
  12         _readList,
  13         _showList
  14     ) where
  15
  16 import Cls
  17 import IChar
  18 import IComplex
  19 import IDouble
  20 import IFloat
  21 import IInt
  22 import IInteger
  23 import IList
  24 import IRatio
  25 import List             ( reverse, dropWhile, take, drop, repeat, (++), head, tail )
  26 import Prel             ( (&&), (^^), (^), not, otherwise, asTypeOf, const, (.), atan2, maxInt )
  27 import PS               ( _PackedString, _unpackPS )
  28 import Text
  29 import TyComplex
  30 import TyArray
  31
  32 -----------------------------------------------------------------
  33 -- some *** NON-STANDARD *** constants (to help compiling Cls.hs)
  34
  35
  36 {-# GENERATE_SPECS __i0 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  37 __i0    :: Num a => a
  38 {-# GENERATE_SPECS __i1 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  39 __i1  :: Num a => a
  40 {-# GENERATE_SPECS __i2 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  41 __i2  :: Num a => a
  42 {-# GENERATE_SPECS __im1 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  43 __im1 :: Num a => a
  44 {-# GENERATE_SPECS __i8 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  45 __i8  :: Num a => a
  46 {-# GENERATE_SPECS __i10 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  47 __i10 :: Num a => a
  48 {-# GENERATE_SPECS __i16 a{Int#,Double#,Int,Integer,Double,Complex(Double#),Complex(Double),Rational} #-}
  49 __i16 :: Num a => a
  50
  51 __i0    = fromInt 0
  52 __i1    = fromInt 1
  53 __i2    = fromInt 2
  54 __im1   = fromInt (-1)
  55 __i8    = fromInt 8
  56 __i10   = fromInt 10
  57 __i16   = fromInt 16
  58
  59 {-# GENERATE_SPECS __rhalf a{Double#,Double,Complex(Double#),Complex(Double),Rational} #-}
  60 __rhalf :: Fractional a => a
  61 __rhalf = fromRational (__i1:%__i2)
  62
  63
  64 -- bits of PreludeCore that aren't classes, instances, etc.
  65
  66 {-
  67 [In response to a request by simonpj, Joe Fasel writes:]
  68
  69 A quite reasonable request!  This code was added to the Prelude just
  70 before the 1.2 release, when Lennart, working with an early version
  71 of hbi, noticed that (read . show) was not the identity for
  72 floating-point numbers.  (There was a one-bit error about half the time.)
  73 The original version of the conversion function was in fact simply
  74 a floating-point divide, as you suggest above.  The new version is,
  75 I grant you, somewhat denser.
  76
  77 How's this?
  78
  79 Joe
  80 -}
  81
  82 {-# GENERATE_SPECS _fromRational a{Double#,Double} #-}
  83 _fromRational :: (RealFloat a) => Rational -> a
  84 _fromRational x = x'
  85         where x' = f e
  86
  87 --              If the exponent of the nearest floating-point number to x
  88 --              is e, then the significand is the integer nearest xb^(-e),
  89 --              where b is the floating-point radix.  We start with a good
  90 --              guess for e, and if it is correct, the exponent of the
  91 --              floating-point number we construct will again be e.  If
  92 --              not, one more iteration is needed.
  93
  94               f e   = if e' == e then y else f e'
  95                       where y      = encodeFloat (round (x * (__i1 % b)^^e)) e
  96                             (_,e') = decodeFloat y
  97               b     = floatRadix x'
  98
  99 --              We obtain a trial exponent by doing a floating-point
 100 --              division of x's numerator by its denominator.  The
 101 --              result of this division may not itself be the ultimate
 102 --              result, because of an accumulation of three rounding
 103 --              errors.
 104
 105               (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 106                                         / fromInteger (denominator x))
 107
 108
 109 {- Hmmm...
 110
 111 -- Another version of _fromRational which is floating around ...
 112 -- Any idea what is the true story ? (PS)
 113
 114 _fromRational :: (RealFloat a) => Rational -> a
 115 _fromRational r
 116         let
 117             h = ceiling (huge `asTypeOf` x)
 118             b = toInteger (floatRadix x)
 119             x = fromRat 0 r
 120
 121             fromRat e0 r' =
 122 {--}            _trace (shows e0 ('/' : shows r' ('/' : shows h "\n"))) (
 123                 let d = denominator r'
 124                     n = numerator r'
 125                 in  if d > h then
 126                        let e = integerLogBase b (d `div` h) + 1
 127                        in  fromRat (e0-e) (n % (d `div` (b^e)))
 128                     else if abs n > h then
 129                        let e = integerLogBase b (abs n `div` h) + 1
 130                        in  fromRat (e0+e) ((n `div` (b^e)) % d)
 131                     else
 132                        scaleFloat e0 (rationalToRealFloat r')
 133                        -- now that we know things are in-bounds,
 134                        -- we use the "old" Prelude code.
 135 {--}            )
 136         in  x
 137
 138 -- Compute the discrete log of i in base b.
 139 -- Simplest way would be just divide i by b until it's smaller then b, but that would
 140 -- be very slow!  We are just slightly more clever.
 141 integerLogBase :: Integer -> Integer -> Int
 142 integerLogBase b i =
 143      if i < b then
 144         0
 145      else
 146         -- Try squaring the base first to cut down the number of divisions.
 147         let l = 2 * integerLogBase (b*b) i
 148             doDiv :: Integer -> Int -> Int
 149             doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
 150         in  doDiv (i `div` (b^l)) l
 151
 152
 153 ------------
 154
 155 -- Compute smallest and largest floating point values.
 156 tiny :: (RealFloat a) => a
 157 tiny =
 158         let (l, _) = floatRange x
 159             x = encodeFloat 1 (l-1)
 160         in  x
 161
 162 huge :: (RealFloat a) => a
 163 huge =
 164         let (_, u) = floatRange x
 165             d = floatDigits x
 166             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
 167         in  x
 168
 169 ...mmmH -}
 170
 171 -------------------------------------------------------------------------
 172 -- from/by Lennart, 94/09/26
 173
 174 -- Convert a Rational to a string that looks like a floating point number,
 175 -- but without converting to any floating type (because of the possible overflow).
 176 _showRational :: Int -> Rational -> String
 177 _showRational n r =
 178     if r == __i0 then
 179         "0.0"
 180     else
 181         let (r', e) = normalize r
 182         in  prR n r' e
 183
 184 startExpExp = 4 :: Int
 185
 186 -- make sure 1 <= r < 10
 187 normalize :: Rational -> (Rational, Int)
 188 normalize r = if r < __i1 then
 189                   case norm startExpExp (__i1 / r) 0 of (r', e) -> (__i10 / r', -e-1)
 190               else
 191                   norm startExpExp r 0
 192         where norm :: Int -> Rational -> Int -> (Rational, Int)
 193               -- Invariant: r*10^e == original r
 194               norm 0  r e = (r, e)
 195               norm ee r e =
 196                 let n = 10^ee
 197                     tn = __i10^n
 198                 in  if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
 199
 200 drop0 "" = ""
 201 drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
 202
 203 prR :: Int -> Rational -> Int -> String
 204 prR n r e | r <  __i1  = prR n (r*__i10) (e-1)          -- final adjustment
 205 prR n r e | r >= __i10 = prR n (r/__i10) (e+1)
 206 prR n r e0 =
 207         let s = show ((round (r * __i10^n))::Integer)
 208             e = e0+1
 209         in  if e > 0 && e < 8 then
 210                 take e s ++ "." ++ drop0 (drop e s)
 211             else if e <= 0 && e > -3 then
 212                 "0." ++ take (-e) (repeat '0') ++ drop0 s
 213             else
 214                 head s : "."++ drop0 (tail s) ++ "e" ++ show e0
 215
 216 -----------------------------------------------------------------
 217
 218 {-# GENERATE_SPECS _readList a #-}
 219 _readList :: ReadS a -> ReadS [a]
 220
 221 _readList readx = readParen False (\r -> [pr | ("[",s)  <- lex r,
 222                                                pr       <- readl s])
 223                   where readl  s = [([],t)   | ("]",t)  <- lex s] ++
 224                                    [(x:xs,u) | (x,t)    <- readx s,
 225                                                (xs,u)   <- readl2 t]
 226                         readl2 s = [([],t)   | ("]",t)  <- lex s] ++
 227                                    [(x:xs,v) | (",",t)  <- lex s,
 228                                                (x,u)    <- readx t,
 229                                                (xs,v)   <- readl2 u]
 230
 231 {-# GENERATE_SPECS _showList a #-}
 232 _showList :: (a -> ShowS) ->  [a] -> ShowS
 233
 234 _showList showx [] = showString "[]"
 235 _showList showx (x:xs)
 236              = showChar '[' . showx x . showl xs
 237
 238                where showl []     = showChar ']'
 239                      showl (x:xs) = showString ", " . showx x . showl xs