X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FClasses.hs;h=54b36bc11297f2dda570c580afb970a35186be14;hb=a223a71a0d40523d2fb3a6b84b5da37d9fc719b8;hp=16384561346e4968444c5968992650471a3d1991;hpb=447f62d3421ea5d00eb6585ec0617c1b512f36f0;p=ghc-base.git diff --git a/GHC/Classes.hs b/GHC/Classes.hs index 1638456..54b36bc 100644 --- a/GHC/Classes.hs +++ b/GHC/Classes.hs @@ -1,5 +1,7 @@ -{-# 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 #-} ----------------------------------------------------------------------------- -- | @@ -17,8 +19,17 @@ module GHC.Classes where -import GHC.Bool +import GHC.Integer +-- GHC.Magic is used in some derived instances +import GHC.Magic () import GHC.Ordering +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 && @@ -36,9 +47,78 @@ default () -- Double isn't available yet class Eq a where (==), (/=) :: a -> a -> Bool + {-# INLINE (/=) #-} + {-# INLINE (==) #-} x /= y = not (x == y) x == y = not (x /= y) +deriving instance Eq () +deriving instance (Eq a, Eq b) => Eq (a, b) +deriving instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +deriving instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) + => Eq (a, b, c, d, e, f) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) + => Eq (a, b, c, d, e, f, g) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h) + => Eq (a, b, c, d, e, f, g, h) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i) + => Eq (a, b, c, d, e, f, g, h, i) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j) + => Eq (a, b, c, d, e, f, g, h, i, j) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k) + => Eq (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Eq a) => Eq [a] where + {-# SPECIALISE instance Eq [Char] #-} + [] == [] = True + (x:xs) == (y:ys) = x == y && xs == ys + _xs == _ys = 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 @@ -72,6 +152,116 @@ class (Eq a) => Ord a where max x y = if x <= y then y else x min x y = if x <= y then x else y +deriving instance Ord () +deriving instance (Ord a, Ord b) => Ord (a, b) +deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) + => Ord (a, b, c, d, e, f) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) + => Ord (a, b, c, d, e, f, g) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h) + => Ord (a, b, c, d, e, f, g, h) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i) + => Ord (a, b, c, d, e, f, g, h, i) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j) + => Ord (a, b, c, d, e, f, g, h, i, j) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k) + => Ord (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Ord a) => Ord [a] where + {-# SPECIALISE instance Ord [Char] #-} + compare [] [] = EQ + compare [] (_:_) = LT + compare (_:_) [] = GT + compare (x:xs) (y:ys) = case compare x y of + EQ -> compare xs ys + other -> other + +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 +-- '>' uses compare, and therefore takes two primops instead of one. +instance Ord Char where + (C# c1) > (C# c2) = c1 `gtChar#` c2 + (C# c1) >= (C# c2) = c1 `geChar#` c2 + (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 @@ -91,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