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