Merge pull request #69 from Mathnerd314/seconds

Fix/extend tests, move Seconds into separate module

System/Clock.hsc

@@ -17,10 +17,11 @@ module System.Clock
   , toNanoSecs
   , diffTimeSpec
   , timeSpecAsNanoSecs
+  , normalize
+  , s2ns
   ) where
 
 import Control.Applicative ((<$>), (<*>))
-import Data.Coerce
 import Data.Int
 import Data.Word
 import Data.Ratio
@@ -229,12 +230,12 @@ normalize (TimeSpec xs xn) | xn < 0 || xn >= s2ns = TimeSpec (xs + q)  r
 instance Num TimeSpec where
   (TimeSpec xs xn) + (TimeSpec ys yn) = normalize $! TimeSpec (xs + ys) (xn + yn)
   (TimeSpec xs xn) - (TimeSpec ys yn) = normalize $! TimeSpec (xs - ys) (xn - yn)
-  (toInteger-> t1) * (toInteger-> t2) = fromInteger $! t1 * t2
+  (normalize -> TimeSpec xs xn) * (normalize -> TimeSpec ys yn) = normalize $! TimeSpec (s2ns*xs*ys+xs*yn+xn*ys) (xn*yn)
   negate (TimeSpec xs xn) = normalize $! TimeSpec (negate xs) (negate xn)
   abs    (normalize -> TimeSpec xs xn) | xs == 0   = normalize $! TimeSpec 0 xn
                                        | otherwise = normalize $! TimeSpec (abs xs) (signum xs * xn)
-  signum (normalize -> TimeSpec xs xn) | xs == 0   = TimeSpec (signum xn) 0
-                                       | otherwise = TimeSpec (signum xs) 0
+  signum (normalize -> TimeSpec xs xn) | xs == 0   = TimeSpec 0 (signum xn)
+                                       | otherwise = TimeSpec 0 (signum xs)
   fromInteger x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns
 
 instance Enum TimeSpec where
@@ -267,6 +268,10 @@ instance Ord TimeSpec where
                                                                       | otherwise = os
                                                                         where  os = compare xs ys
 
+instance Bounded TimeSpec where
+  minBound = TimeSpec minBound 0
+  maxBound = TimeSpec maxBound (s2ns-1)
+
 -- | TimeSpec from nano seconds.
 fromNanoSecs :: Integer -> TimeSpec
 fromNanoSecs x = TimeSpec (fromInteger  q) (fromInteger  r) where (q, r) = x `divMod` s2ns
@@ -284,34 +289,3 @@ diffTimeSpec ts1 ts2 = abs (ts1 - ts2)
 -- | TimeSpec as nano seconds.
 timeSpecAsNanoSecs :: TimeSpec -> Integer
 timeSpecAsNanoSecs   (TimeSpec s n) = toInteger s * s2ns + toInteger n
-
-newtype Seconds = Seconds TimeSpec
- deriving (Generic, Read, Show, Typeable, Eq, Ord, Storable)
-
-instance Num Seconds where
-  fromInteger n = Seconds $ TimeSpec (fromInteger n) 0
-  Seconds a * Seconds b = Seconds $ a * b `div` s2ns
-  (+) = coerce ((+) :: TimeSpec -> TimeSpec -> TimeSpec)
-  (-) = coerce ((-) :: TimeSpec -> TimeSpec -> TimeSpec)
-  negate = coerce (negate :: TimeSpec -> TimeSpec)
-  abs = coerce (abs :: TimeSpec -> TimeSpec)
-  signum = coerce (signum :: TimeSpec -> TimeSpec)
-
-instance Enum Seconds where
-  succ x = x + 1
-  pred x = x - 1
-  toEnum x = Seconds . normalize $ TimeSpec (fromIntegral x) 0
-  fromEnum (Seconds (TimeSpec s _)) = fromEnum s
-
-instance Real Seconds where
-  toRational (Seconds x) = toInteger x % s2ns
-
-instance Fractional Seconds where
-  fromRational x = Seconds . fromInteger $ floor (x * s2ns)
-  Seconds a / Seconds b = Seconds $ a * s2ns `div` b
-  recip (Seconds a) = Seconds $ s2ns * s2ns `div` a
-
-instance RealFrac Seconds where
-  properFraction (Seconds (TimeSpec s ns))
-    | s >= 0 = (fromIntegral s, Seconds $ TimeSpec 0 ns)
-    | otherwise = (fromIntegral (s+1), Seconds $ TimeSpec (-1) ns)

System/Clock/Seconds.hs

@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+module System.Clock.Seconds
+  ( Clock(..)
+  , Seconds(..)
+  , getTime
+  , getRes
+  , fromNanoSecs
+  , toNanoSecs
+  , diffTimeSpec
+  ) where
+
+import Data.Coerce
+import Data.Ratio
+import Data.Typeable (Typeable)
+import Foreign.Storable
+import GHC.Generics (Generic)
+
+import System.Clock(TimeSpec(..), Clock, s2ns, normalize)
+import qualified System.Clock as C
+
+newtype Seconds = Seconds { toTimeSpec :: TimeSpec }
+ deriving (Generic, Read, Show, Typeable, Eq, Ord, Storable, Bounded)
+
+instance Num Seconds where
+  fromInteger n = Seconds $ TimeSpec (fromInteger n) 0
+  Seconds (TimeSpec xs xn) * Seconds (TimeSpec ys yn) =
+    Seconds $ normalize $! TimeSpec (xs*ys) (xs*yn+xn*ys+((xn*yn) `div` s2ns))
+  (+) = coerce ((+) :: TimeSpec -> TimeSpec -> TimeSpec)
+  (-) = coerce ((-) :: TimeSpec -> TimeSpec -> TimeSpec)
+  negate = coerce (negate :: TimeSpec -> TimeSpec)
+  abs = coerce (abs :: TimeSpec -> TimeSpec)
+  signum (Seconds a) = case signum a of
+    1 -> 1
+    (-1) -> (-1)
+    _ -> 0
+
+instance Enum Seconds where
+  succ x = x + 1
+  pred x = x - 1
+  toEnum x = Seconds $ TimeSpec (fromIntegral x) 0
+  fromEnum (Seconds (TimeSpec s _)) = fromEnum s
+
+instance Real Seconds where
+  toRational (Seconds x) = toInteger x % s2ns
+
+instance Fractional Seconds where
+  fromRational x = Seconds . fromInteger $ floor (x * s2ns)
+  Seconds a / Seconds b = Seconds $ a * s2ns `div` b
+  recip (Seconds a) = Seconds $ s2ns * s2ns `div` a
+
+instance RealFrac Seconds where
+  properFraction (Seconds (TimeSpec s ns))
+    | s >= 0 = (fromIntegral s, Seconds $ TimeSpec 0 ns)
+    | otherwise = (fromIntegral (s+1), Seconds $ TimeSpec (-1) ns)
+
+-- | The 'getTime' function shall return the current value for the
+--   specified clock.
+getTime :: Clock -> IO Seconds
+getTime = coerce C.getTime
+
+-- | The 'getRes' function shall return the resolution of any clock.
+--   Clock resolutions are implementation-defined and cannot be set
+--   by a process.
+getRes :: Clock -> IO Seconds
+getRes = coerce C.getRes
+
+-- | Seconds from nano seconds.
+fromNanoSecs :: Integer -> Seconds
+fromNanoSecs = coerce C.fromNanoSecs
+
+-- | Seconds to nano seconds.
+toNanoSecs :: Seconds -> Integer
+toNanoSecs = coerce C.toNanoSecs
+
+-- | Compute the absolute difference.
+diffTimeSpec :: Seconds -> Seconds -> Seconds
+diffTimeSpec = coerce C.diffTimeSpec

clock.cabal

@@ -71,6 +71,7 @@ library
       build-depends:     ghc-prim
     build-depends:       base >= 4.4 && < 5
     exposed-modules:     System.Clock
+                        System.Clock.Seconds
     default-extensions:          DeriveGeneric
                          DeriveDataTypeable
                          ForeignFunctionInterface
@@ -88,6 +89,9 @@ library
 
 test-suite test
     default-language: Haskell2010
+    default-extensions: ScopedTypeVariables
+                         GeneralizedNewtypeDeriving
+                         StandaloneDeriving
     type:
       exitcode-stdio-1.0
     hs-source-dirs:

tests/test.hs

@@ -4,35 +4,106 @@ import Data.Fixed
 import Data.List
 -- import Test.Tasty.HUnit as HUnit
 import System.Clock
+import System.Clock.Seconds as S
 
 instance Arbitrary TimeSpec where
   arbitrary = do
     sec <- arbitrarySizedIntegral
     nan <- arbitrarySizedIntegral
     return $ TimeSpec sec nan
 
-main = defaultMain (adjustOption (QuickCheckTests 100000 +) $ tests)
+deriving instance Arbitrary Seconds
+
+main = defaultMain (localOption (QuickCheckTests 100000) $ tests)
 
 tests :: TestTree
-tests  = testGroup "All tests" [numInstanceTests, ordInstanceTests]
-
-numInstanceTests = testGroup "Num instance tests" [qcNumInstance]
-ordInstanceTests = testGroup "Ord instance tests" [qcOrdInstance]
-
-qcNumInstance = testGroup "QuickCheck"
-  [ 
-    QuickCheck.testProperty "x = abs(x) * signum(x)"                                 $ \ x   -> (x :: TimeSpec) == (abs x) * (signum x)
-  , QuickCheck.testProperty "integer     addition equals TimeSpec     addition"      $ \ x y -> x + y == toNanoSecs (fromInteger x + fromInteger y)
-  , QuickCheck.testProperty "integer subtraction equals TimeSpec subtracttion"      $ \ x y -> x - y == toNanoSecs (fromInteger x - fromInteger y)
-  , QuickCheck.testProperty "rational multiplication equals TimeSpec multiplication" $
-      \ x y ->
-        let rationalMul = truncate                         ((x :: Nano) *                       (y :: Nano) * (10^9))
-            timespecMul = toNanoSecs (fromInteger (truncate (x * 10^9)) * fromInteger (truncate (y * 10^9)))
-        in  rationalMul == timespecMul
-  , QuickCheck.testProperty "neg(neg(x)) = x" $ \ x -> negate (negate x :: TimeSpec) == x
+tests  = testGroup "All tests" [timeSpecTests, secondsTests]
+
+timeSpecTests = testGroup "TimeSpec tests" [qcNumInstance (0 :: TimeSpec), qcRealInstance (0 :: TimeSpec), qcTimeSpec]
+secondsTests = testGroup "Seconds tests" [qcNumInstance (0 :: S.Seconds), qcRealInstance (0 :: S.Seconds), qcSeconds]
+
+qcNumInstance :: (Eq a, Num a, Arbitrary a, Show a) => a -> TestTree
+qcNumInstance (s :: a) = testGroup "Num"
+  [
+    QuickCheck.testProperty "Associativity of (+)" $ \(x :: a) y z ->
+        (x + y) + z == x + (y + z)
+  , QuickCheck.testProperty "Commutativity of (+)" $ \(x :: a) y ->
+        x + y == y + x
+  , QuickCheck.testProperty "fromInteger 0 is the additive identity" $ \(x :: a) ->
+        x + fromInteger 0 == x
+  , QuickCheck.testProperty "negate gives the additive inverse" $ \(x :: a) ->
+        x + negate x == fromInteger 0
+  , QuickCheck.testProperty "fromInteger 1 is the multiplicative identity" $ \(x :: a) ->
+        x * fromInteger 1 == x && fromInteger 1 * x == x
+  , QuickCheck.testProperty "neg(neg(x)) = x" $ \(x :: a) ->
+        negate (negate x) == x
+  , QuickCheck.testProperty "x = abs(x) * signum(x)" $ \(x :: a) ->
+        x == (abs x) * (signum x)
+  ]
+
+qcRealInstance :: (Real a, Arbitrary a, Show a) => a -> TestTree
+qcRealInstance (s :: a) = testGroup "Real"
+  [
+    QuickCheck.testProperty "integer addition is correct" $ \ x y ->
+      toRational (x + y) == toRational (fromInteger x + fromInteger y :: a)
+  , QuickCheck.testProperty "integer subtraction is correct" $ \ x y ->
+      toRational (x - y) == toRational (fromInteger x - fromInteger y :: a)
+  , QuickCheck.testProperty "integer multiplication is correct" $ \ x y ->
+      toRational (x * y) == toRational (fromInteger x * fromInteger y :: a)
+  , QuickCheck.testProperty "random list of TimeSpecs is sorted like equivalent list of rationals" $ \(x :: [a]) ->
+      map toRational (sort x) == sort (map toRational x)
+  ]
+
+qcTimeSpec :: TestTree
+qcTimeSpec = testGroup "TimeSpec-specific"
+  [
+    -- fails with Seconds on 0.000000001 * -1.000000002 * -2.000000001
+    QuickCheck.testProperty "Associativity of (*)" $ \(x :: TimeSpec) y z ->
+        (x * y) * z == x * (y * z)
+    -- fails with Seconds on [-0.999999999,0.000000001,-1.000000001]
+  , QuickCheck.testProperty "Distributivity of (*) with respect to (+)" $ \(a :: TimeSpec) b c ->
+        a * (b + c) == (a * b) + (a * c) && (b + c) * a == (b * a) + (c * a)
+  , QuickCheck.testProperty "TimeSpec Quot-rem division equality" $ \(x :: TimeSpec) y ->
+      y == 0 || x == y * quot x y + rem x y
+  , QuickCheck.testProperty "TimeSpec Rem is within bounds" $ \(x :: TimeSpec) y ->
+      let r = rem x y in y == 0 || r == fromInteger 0 || abs r < abs y
+  , QuickCheck.testProperty "TimeSpec quotRem agrees with quot and rem" $ \(x :: TimeSpec) y ->
+      let (q,r) = quotRem x y in
+        y == 0 || (q == quot x y && r == rem x y)
+  , QuickCheck.testProperty "TimeSpec Div-mod division equality" $ \(x :: TimeSpec) y ->
+      y == 0 || x == y * div x y + mod x y
+  , QuickCheck.testProperty "TimeSpec Mod is within bounds" $ \(x :: TimeSpec) y ->
+      let r = mod x y in y == 0 || (r == fromInteger 0 || abs r < abs y)
+  , QuickCheck.testProperty "TimeSpec divMod agrees with div and mod" $ \(x :: TimeSpec) y ->
+      let (q,r) = divMod x y in
+        y == 0 || (q == div x y && r == mod x y)
+  , QuickCheck.testProperty "TimeSpec toInteger . fromInteger is the identity" $ \x ->
+      x == toInteger (fromInteger x :: TimeSpec)
+  , QuickCheck.testProperty "TimeSpec fromInteger . toInteger is the identity" $ \(x :: TimeSpec) ->
+      x == fromInteger (toInteger x)
+  , QuickCheck.testProperty "TimeSpec division agrees with Integer" $ \(x :: TimeSpec) y ->
+      y == 0 || toInteger (x `div` y) == toInteger x `div` toInteger y
+  , QuickCheck.testProperty "TimeSpec quot agrees with Integer" $ \(x :: TimeSpec) y ->
+      y == 0 || toInteger (x `quot` y) == toInteger x `quot` toInteger y
   ]
 
-qcOrdInstance = testGroup "QuickCheck"
+qcSeconds :: TestTree
+qcSeconds = testGroup "Seconds-specific"
   [
-    QuickCheck.testProperty "random list of TimeSpecs is sorted like equivalent list of integers" $ \ x -> sort (x :: [TimeSpec]) == map (fromInteger) (sort (map toNanoSecs x))
+    QuickCheck.testProperty "Seconds multiplication is Nano multiplication" $ \x y ->
+      let nano = toRational $ (x :: Nano) * (y :: Nano)
+          seconds = toRational $ (realToFrac x) * (realToFrac y :: Seconds)
+      in  nano == seconds
+  , QuickCheck.testProperty "Seconds truncate is Nano truncate" $ \(x :: Nano) ->
+      let nano = truncate x :: Integer
+          seconds = truncate (realToFrac x :: Seconds)
+      in  nano == seconds
+  , QuickCheck.testProperty "Seconds / is Nano /" $ \(x :: Nano) (y :: Nano) ->
+      let nano = toRational $ x / y
+          seconds = toRational (realToFrac x / realToFrac y :: Seconds)
+      in y == 0 || nano == seconds
+  , QuickCheck.testProperty "Seconds recip is Nano recip" $ \(x :: Nano) ->
+      let nano = toRational $ recip x
+          seconds = toRational (recip $ realToFrac x :: Seconds)
+      in x == 0 || nano == seconds
   ]