From e2e89b5ef183ab9ed0d4974b31d29cd7ea7a7e5c Mon Sep 17 00:00:00 2001
From: Nick Bowler <nbowler@draconx.ca>
Date: Wed, 23 Dec 2009 23:59:43 -0500
Subject: [PATCH] floating: Add a class which supports rounding functions.

---
 Data/Floating/Classes.hs | 28 +++++++++++++++++++++++++++-
 Data/Floating/Double.hs  | 26 ++++++++++++++++++++++++--
 Data/Floating/Prelude.hs |  1 +
 3 files changed, 52 insertions(+), 3 deletions(-)

diff --git a/Data/Floating/Classes.hs b/Data/Floating/Classes.hs
index 6ecd5fb..96f8ca3 100644
--- a/Data/Floating/Classes.hs
+++ b/Data/Floating/Classes.hs
@@ -10,12 +10,38 @@
 -- off of the C math library.
 module Data.Floating.Classes where
 
-import Prelude hiding (Floating(..), RealFloat(..))
+import Prelude hiding (Floating(..), RealFloat(..), RealFrac(..), Ord(..))
+import Data.Ratio
+import Data.Poset
 
 -- | Classification of floating point values.
 data FPClassification = FPInfinite | FPNaN | FPNormal | FPSubNormal | FPZero
     deriving (Show, Read, Eq, Enum, Bounded)
 
+-- | Class for types which can be rounded to integers.
+--
+-- Minimal complete definition: 'toIntegral' and 'round'.
+class (Fractional a, Poset a) => Roundable a where
+    -- | Discards the fractional component from a value.  Results in 'Nothing'
+    -- if the result cannot be represented as an integer, such as if the input
+    -- is infinite or NaN.
+    toIntegral :: Integral b => a -> Maybe b
+    ceiling    :: a -> a
+    floor      :: a -> a
+    truncate   :: a -> a
+    round      :: a -> a
+
+    floor x
+        | round x == x = x
+        | otherwise = round $ x - fromRational (1%2)
+    ceiling x
+        | round x == x = x
+        | otherwise = round $ x + fromRational (1%2)
+    truncate x
+        | x < 0 = ceiling x
+        | x > 0 = floor x
+        | otherwise = x
+
 -- | Class for floating point types (real or complex-valued).
 --
 -- Minimal complete definition: everything.
diff --git a/Data/Floating/Double.hs b/Data/Floating/Double.hs
index 2a17d33..e7a2d22 100644
--- a/Data/Floating/Double.hs
+++ b/Data/Floating/Double.hs
@@ -6,18 +6,20 @@
  - There is NO WARRANTY, to the extent permitted by law.
  -}
 
-{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
 {-# INCLUDE <stdlib.h> <math.h> "cfloat.h" #-}
 module Data.Floating.Double (
     Double
 ) where
 
-import Prelude hiding (Double, Floating(..), RealFloat(..))
+import Prelude hiding (Double, Floating(..), RealFloat(..), Ord(..))
 import Control.Applicative
 import Control.Monad
+import Data.Maybe
 import Data.Ratio
 import Data.Poset
 
+import GHC.Exts hiding (Double(..))
 import GHC.Integer
 import GHC.Prim
 
@@ -89,6 +91,26 @@ instance Fractional Double where
         (fromInteger . numerator)
         (fromInteger . denominator)
 
+-- | Internal function which discards the fractional component of a Double.
+-- The results are meaningful only for finite input.
+dropFrac :: Double -> Integer
+dropFrac (D# x)
+    | e >= 0    = s * 2^e
+    | otherwise = quot s (2^(negate e))
+    where
+        (# s, e# #) = decodeDoubleInteger x
+        e = I# e#
+
+instance Roundable Double where
+    toIntegral x = case classify x of
+        FPInfinite -> Nothing
+        FPNaN      -> Nothing
+        otherwise  -> Just . fromInteger . dropFrac $ x
+    floor    = libmDouble c_floor
+    ceiling  = libmDouble c_ceil
+    truncate = libmDouble c_trunc
+    round    = libmDouble c_round
+
 instance Floating Double where
     (D# x) ** (D# y) = D# (x **## y)
     sqrt (D# x) = D# (sqrtDouble# x)
diff --git a/Data/Floating/Prelude.hs b/Data/Floating/Prelude.hs
index f577a65..5861981 100644
--- a/Data/Floating/Prelude.hs
+++ b/Data/Floating/Prelude.hs
@@ -19,6 +19,7 @@ import Prelude hiding (
     Floating(..), RealFloat(..),
     Ordering(..), Ord(..),
     Double, Float,
+    round, truncate, ceiling, floor
     )
 import Data.Floating
 import Data.Poset
-- 
2.11.4.GIT