ghc/lib/prelude/Cls.hs

   1 module PreludeCore (
   2         Eq(..), Ord(..), Num(..), Real(..), Integral(..),
   3         Fractional(..), Floating(..), RealFrac(..), RealFloat(..),
   4         Ix(..), Enum(..), Text(..), Binary(..),
   5         _CCallable(..), _CReturnable(..),
   6         Bin
   7     ) where
   8
   9 import UTypes
  10
  11 import Core
  12 import IChar
  13 import IInt             ( Int )
  14 import IInteger         ( __integer1, Integer )
  15 import List             ( takeWhile, (++), foldr )
  16 import Prel             ( (&&), (.), otherwise )
  17 import PS               ( _PackedString, _unpackPS )
  18 import Text
  19 import TyArray
  20 import TyComplex
  21
  22 {- We have to do something unpleasant about overloaded constants
  23    herein.  Those constants are automagically wrapped in applications
  24    of the *BUILT-IN* from{Integer,Rational} Ids.
  25
  26    Those are *NOT* the same methods as those being compiled here!
  27    (The builtin class information is "turned off" for compiling this
  28    file, but that does not help w/ the from{Integer,Rational} Ids,
  29    which are reached-out-and-grabbed from thin air.
  30
  31    Instead the overloaded constants are declared in Core.hs
  32 -}
  33
  34 -- class declarations from PreludeCore
  35
  36 class  Eq a  where
  37     (==), (/=)          :: a -> a -> Bool
  38
  39     x /= y = if x == y then False else True
  40
  41 class  (Eq a) => Ord a  where
  42     (<), (<=), (>=), (>):: a -> a -> Bool
  43     max, min            :: a -> a -> a
  44     -- NON-STANDARD GLASGOW ADDITION:
  45     _tagCmp :: a -> a -> _CMP_TAG
  46
  47     x <  y =  x <= y && x /= y
  48     x >= y =  y <= x
  49     x >  y =  y <  x
  50     max x y | x >= y    =  x
  51             | y >= x    =  y
  52             |otherwise  =  error "max{PreludeCore}: no ordering relation\n"
  53     min x y | x <= y    =  x
  54             | y <= x    =  y
  55             |otherwise  =  error "min{PreludeCore}: no ordering relation\n"
  56     _tagCmp a b = if a == b then _EQ else if a < b then _LT else _GT
  57
  58 class  (Eq a, Text a) => Num a  where
  59     (+), (-), (*)       :: a -> a -> a
  60     negate              :: a -> a
  61     abs, signum         :: a -> a
  62     fromInteger         :: Integer -> a
  63     fromInt             :: Int -> a             -- partain: extra! (see note below)
  64
  65     x - y               = x + negate y
  66     fromInt i           = fromInteger (int2Integer i)
  67                         where
  68                           int2Integer (I# i#) = int2Integer# i#
  69                                         -- Go via the standard class-op if the
  70                                         -- non-standard one ain't provided
  71
  72 {-
  73 Note: Both GHC and HBC provide an extra class operation in @Num@,
  74 namely @fromInt@.  This makes small overloaded literal constants, such
  75 as ``42'', much more efficient.  Instead of building the @Integer@ for
  76 ``42'' and then converting that expensively to the desired type, we
  77 can then just make the @Int@ for ``42'' and convert that to the
  78 desired type.
  79 -}
  80
  81 class  (Num a, Enum a) => Real a  where
  82     toRational          ::  a -> Rational
  83
  84 class  (Real a, Ix a) => Integral a  where
  85     quot, rem, div, mod :: a -> a -> a
  86     quotRem, divMod     :: a -> a -> (a,a)
  87     even, odd           :: a -> Bool
  88     toInteger           :: a -> Integer
  89     toInt               :: a -> Int             -- partain: also extra (as above)
  90
  91     n `quot` d  =  q  where (q,r) = quotRem n d
  92     n `rem` d   =  r  where (q,r) = quotRem n d
  93     n `div` d   =  q  where (q,r) = divMod n d
  94     n `mod` d   =  r  where (q,r) = divMod n d
  95     divMod n d  =  if signum r == - signum d then (q - __i1, r+d) else qr
  96                            where qr@(q,r) = quotRem n d
  97     even n      =  n `rem` __i2 == __i0
  98     odd  n      =  n `rem` __i2 /= __i0
  99
 100 class  (Num a) => Fractional a  where
 101     (/)                 :: a -> a -> a
 102     recip               :: a -> a
 103     fromRational        :: Rational -> a
 104
 105     recip x             =  __i1 / x
 106
 107 class  (Fractional a) => Floating a  where
 108     pi                  :: a
 109     exp, log, sqrt      :: a -> a
 110     (**), logBase       :: a -> a -> a
 111     sin, cos, tan       :: a -> a
 112     asin, acos, atan    :: a -> a
 113     sinh, cosh, tanh    :: a -> a
 114     asinh, acosh, atanh :: a -> a
 115
 116     x ** y              =  exp (log x * y)
 117     logBase x y         =  log y / log x
 118     sqrt x              =  x ** __rhalf
 119     tan  x              =  sin  x / cos  x
 120     tanh x              =  sinh x / cosh x
 121
 122 class  (Real a, Fractional a) => RealFrac a  where
 123     properFraction      :: (Integral b) => a -> (b,a)
 124     truncate, round     :: (Integral b) => a -> b
 125     ceiling, floor      :: (Integral b) => a -> b
 126
 127     truncate x  = case properFraction x of
 128                      (n,_) -> n
 129
 130     round x     = case properFraction x of
 131                      (n,r) -> let
 132                                 m         = if r < __i0 then n - __i1 else n + __i1
 133                                 half_down = abs r - __rhalf
 134                               in
 135                               case (_tagCmp half_down __i0) of
 136                                 _LT -> n
 137                                 _EQ -> if even n then n else m
 138                                 _GT -> m
 139
 140     ceiling x   = case properFraction x of
 141                     (n,r) -> if r > __i0 then n + __i1 else n
 142
 143     floor x     = case properFraction x of
 144                     (n,r) -> if r < __i0 then n - __i1 else n
 145
 146
 147 class  (RealFrac a, Floating a) => RealFloat a  where
 148     floatRadix          :: a -> Integer
 149     floatDigits         :: a -> Int
 150     floatRange          :: a -> (Int,Int)
 151     decodeFloat         :: a -> (Integer,Int)
 152     encodeFloat         :: Integer -> Int -> a
 153     exponent            :: a -> Int
 154     significand         :: a -> a
 155     scaleFloat          :: Int -> a -> a
 156
 157     exponent x          =  if m == __i0 then __i0 else n + floatDigits x
 158                            where (m,n) = decodeFloat x
 159
 160     significand x       =  encodeFloat m (- (floatDigits x))
 161                            where (m,_) = decodeFloat x
 162
 163     scaleFloat k x      =  encodeFloat m (n+k)
 164                            where (m,n) = decodeFloat x
 165
 166 class  (Ord a) => Ix a  where
 167     range               :: (a,a) -> [a]
 168     index               :: (a,a) -> a -> Int
 169     inRange             :: (a,a) -> a -> Bool
 170
 171 class  (Ord a) => Enum a        where
 172     enumFrom            :: a -> [a]             -- [n..]
 173     enumFromThen        :: a -> a -> [a]        -- [n,m..]
 174     enumFromTo          :: a -> a -> [a]        -- [n..m]
 175     enumFromThenTo      :: a -> a -> a -> [a]   -- [n,m..p]
 176
 177     enumFromTo n m       =  takeWhile (<= m) (enumFrom n)
 178     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
 179                                       (enumFromThen n m)
 180
 181 class  Text a  where
 182     readsPrec :: Int -> ReadS a
 183     showsPrec :: Int -> a -> ShowS
 184     readList  :: ReadS [a]
 185     showList  :: [a] -> ShowS
 186
 187     readList = _readList (readsPrec 0)
 188     showList = _showList (showsPrec 0)
 189
 190 -- Well, we've got to put it somewhere...
 191
 192 instance  Text (a -> b)  where
 193     readsPrec p s  =  error "readsPrec{PreludeCore}: Cannot read functions."
 194     showsPrec p f  =  showString "<<function>>"
 195     readList       =  _readList (readsPrec 0)
 196     showList       =  _showList (showsPrec 0)
 197
 198 class  Binary a  where
 199     readBin             :: Bin -> (a,Bin)
 200     showBin             :: a -> Bin -> Bin
 201
 202 class _CCallable a
 203 class _CReturnable a