Add tests from testsuite/tests/h98

[ghc-base.git] / GHC / Classes.hs

diff --git a/GHC/Classes.hs b/GHC/Classes.hs
index 30f706a..17d0f93 100644 (file)
--- 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,6 @@
 
 module GHC.Classes where
 
-import GHC.Bool
 import GHC.Integer
 -- GHC.Magic is used in some derived instances
 import GHC.Magic ()
@@ -101,6 +100,12 @@ 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
+
 -- | The 'Ord' class is used for totally ordered datatypes.
 --
 -- Instances of 'Ord' can be derived for any user-defined
@@ -196,6 +201,28 @@ instance Ord Integer where
     (>=) = 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
+
 -- OK, so they're technically not part of a class...:
 
 -- Boolean functions