X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FClasses.hs;h=54b36bc11297f2dda570c580afb970a35186be14;hb=3feb1f34df467291e1e0a118db86e680b37fef96;hp=c3dd0264bf9ee70d6b1f182526916c6759014df0;hpb=6e10ad01213942b3ef4a27c16f2f9360334955a8;p=ghc-base.git

diff --git a/GHC/Classes.hs b/GHC/Classes.hs
index c3dd026..54b36bc 100644
--- a/GHC/Classes.hs
+++ b/GHC/Classes.hs
@@ -1,5 +1,5 @@
 
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
 -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.
 {-# OPTIONS_HADDOCK hide #-}
@@ -19,7 +19,7 @@
 
 module GHC.Classes where
 
-import GHC.Bool
+import GHC.Integer
 -- GHC.Magic is used in some derived instances
 import GHC.Magic ()
 import GHC.Ordering
@@ -27,6 +27,9 @@ import GHC.Prim
 import GHC.Tuple
 import GHC.Types
 import GHC.Unit
+-- For defining instances for the generic deriving mechanism
+import GHC.Generics (Arity(..), Associativity(..), Fixity(..))
+
 
 infix  4  ==, /=, <, <=, >=, >
 infixr 3  &&
@@ -89,28 +92,33 @@ instance (Eq a) => Eq [a] where
     (x:xs) == (y:ys) = x == y && xs == ys
     _xs    == _ys    = False
 
--- XXX This doesn't work:
--- deriving instance Eq Bool
--- <wired into compiler>:
---     Illegal binding of built-in syntax: con2tag_Bool#
-instance Eq Bool where
-    True  == True  = True
-    False == False = True
-    _     == _     = False
-
--- XXX This doesn't work:
--- deriving instance Eq Ordering
--- Illegal binding of built-in syntax: con2tag_Ordering#
-instance Eq Ordering where
-    EQ == EQ = True
-    LT == LT = True
-    GT == GT = True
-    _  == _  = False
+deriving instance Eq Bool
+deriving instance Eq Ordering
 
 instance Eq Char where
     (C# c1) == (C# c2) = c1 `eqChar#` c2
     (C# c1) /= (C# c2) = c1 `neChar#` c2
 
+instance  Eq Integer  where
+    (==) = eqInteger
+    (/=) = neqInteger
+
+instance Eq Float where
+    (F# x) == (F# y) = x `eqFloat#` y
+
+instance Eq Double where
+    (D# x) == (D# y) = x ==## y
+
+instance Eq Int where
+    (==) = eqInt
+    (/=) = neInt
+
+{-# INLINE eqInt #-}
+{-# INLINE neInt #-}
+eqInt, neInt :: Int -> Int -> Bool
+(I# x) `eqInt` (I# y) = x ==# y
+(I# x) `neInt` (I# y) = x /=# y
+
 -- | The 'Ord' class is used for totally ordered datatypes.
 --
 -- Instances of 'Ord' can be derived for any user-defined
@@ -187,24 +195,8 @@ instance (Ord a) => Ord [a] where
                                 EQ    -> compare xs ys
                                 other -> other
 
--- XXX This doesn't work:
--- deriving instance Ord Bool
--- <wired into compiler>:
---     Illegal binding of built-in syntax: con2tag_Bool#
-instance Ord Bool where
-    compare False True  = LT
-    compare True  False = GT
-    compare _     _     = EQ
-
--- XXX This doesn't work:
--- deriving instance Ord Ordering
--- Illegal binding of built-in syntax: con2tag_Ordering#
-instance Ord Ordering where
-    LT <= _  = True
-    _  <= LT = False
-    EQ <= _  = True
-    _  <= EQ = False
-    GT <= GT = True
+deriving instance Ord Bool
+deriving instance Ord Ordering
 
 -- We don't use deriving for Ord Char, because for Ord the derived
 -- instance defines only compare, which takes two primops.  Then
@@ -215,6 +207,61 @@ instance Ord Char where
     (C# c1) <= (C# c2) = c1 `leChar#` c2
     (C# c1) <  (C# c2) = c1 `ltChar#` c2
 
+instance Ord Integer where
+    (<=) = leInteger
+    (>)  = gtInteger
+    (<)  = ltInteger
+    (>=) = geInteger
+    compare = compareInteger
+
+instance Ord Float where
+    (F# x) `compare` (F# y)
+        = if      x `ltFloat#` y then LT
+          else if x `eqFloat#` y then EQ
+          else                        GT
+
+    (F# x) <  (F# y) = x `ltFloat#`  y
+    (F# x) <= (F# y) = x `leFloat#`  y
+    (F# x) >= (F# y) = x `geFloat#`  y
+    (F# x) >  (F# y) = x `gtFloat#`  y
+
+instance Ord Double where
+    (D# x) `compare` (D# y)
+        = if      x <##  y then LT
+          else if x ==## y then EQ
+          else                  GT
+
+    (D# x) <  (D# y) = x <##  y
+    (D# x) <= (D# y) = x <=## y
+    (D# x) >= (D# y) = x >=## y
+    (D# x) >  (D# y) = x >##  y
+
+instance Ord Int where
+    compare = compareInt
+    (<)     = ltInt
+    (<=)    = leInt
+    (>=)    = geInt
+    (>)     = gtInt
+
+{-# INLINE gtInt #-}
+{-# INLINE geInt #-}
+{-# INLINE ltInt #-}
+{-# INLINE leInt #-}
+gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool
+(I# x) `gtInt` (I# y) = x >#  y
+(I# x) `geInt` (I# y) = x >=# y
+(I# x) `ltInt` (I# y) = x <#  y
+(I# x) `leInt` (I# y) = x <=# y
+
+compareInt :: Int -> Int -> Ordering
+(I# x#) `compareInt` (I# y#) = compareInt# x# y#
+
+compareInt# :: Int# -> Int# -> Ordering
+compareInt# x# y#
+    | x# <#  y# = LT
+    | x# ==# y# = EQ
+    | True      = GT
+
 -- OK, so they're technically not part of a class...:
 
 -- Boolean functions
@@ -234,3 +281,17 @@ not                     :: Bool -> Bool
 not True                =  False
 not False               =  True
 
+
+------------------------------------------------------------------------
+-- Generic deriving
+------------------------------------------------------------------------
+
+-- We need instances for some basic datatypes, but some of those use Int,
+-- so we have to put the instances here
+deriving instance Eq Arity
+deriving instance Eq Associativity
+deriving instance Eq Fixity
+
+deriving instance Ord Arity
+deriving instance Ord Associativity
+deriving instance Ord Fixity