packages feed

clock 0.4.6.0 → 0.8.4

raw patch · 9 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# 0.8.3++- Dropped support for GHC < 7.8.+- Tested with GHC 7.8 - 9.2.+- TODO: new module `System.Clock.Seconds`+- TODO: new functions+- TODO: other changes
LICENSE view
@@ -1,5 +1,4 @@-Copyright (c) 2009-2012, Cetin Sert-Copyright (c) 2010, Eugene Kirpichov+Copyright (c) 2009-2022, Clock Contributors  All rights reserved.
System/Clock.hsc view
@@ -3,20 +3,31 @@ --   1003.1-2008: <http://www.opengroup.org/onlinepubs/9699919799/>, --   <http://www.opengroup.org/onlinepubs/9699919799/functions/clock_getres.html#> +{-# LANGUAGE CApiFFI #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- To allow importing Data.Int and Data.Word indiscriminately on all platforms,+-- since we can't systematically predict what typedef's expand to.+{-# OPTIONS_GHC -fno-warn-unused-imports #-}  module System.Clock   ( Clock(..)   , TimeSpec(..)   , getTime   , getRes+  , fromNanoSecs+  , toNanoSecs   , diffTimeSpec   , timeSpecAsNanoSecs+  , normalize+  , s2ns   ) where  import Control.Applicative ((<$>), (<*>)) import Data.Int+import Data.Word+import Data.Ratio import Data.Typeable (Typeable)+import Foreign.C import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Alloc@@ -24,23 +35,28 @@  #if defined(_WIN32) #  include "hs_clock_win32.c"-#elif defined(__MACH__)-#  include "hs_clock_darwin.c"+#  define HS_CLOCK_HAVE_PROCESS_CPUTIME+#  define HS_CLOCK_HAVE_THREAD_CPUTIME #else #  include <time.h>--- Due to missing define in FreeBSD 9.0 and 9.1--- (http://lists.freebsd.org/pipermail/freebsd-stable/2013-September/075095.html).-#  ifndef CLOCK_PROCESS_CPUTIME_ID-#    define CLOCK_PROCESS_CPUTIME_ID 15+#  ifdef CLOCK_PROCESS_CPUTIME_ID+#    define HS_CLOCK_HAVE_PROCESS_CPUTIME #  endif+#  ifdef CLOCK_THREAD_CPUTIME_ID+#    define HS_CLOCK_HAVE_THREAD_CPUTIME+#  endif+import System.Posix.Types #endif -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#if __GLASGOW_HASKELL__ < 800+#  let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif  -- | Clock types. A clock may be system-wide (that is, visible to all processes) --   or per-process (measuring time that is meaningful only within a process).---   All implementations shall support CLOCK_REALTIME.+--   All implementations shall support 'Realtime'. data Clock+     -- | The identifier for the system-wide monotonic clock, which is defined as     --   a clock measuring real time, whose value cannot be set via     --   @clock_settime@ and which cannot have negative clock jumps. The maximum@@ -52,53 +68,136 @@     --   monotonic clock is meaningless (because its origin is arbitrary), and     --   thus there is no need to set it. Furthermore, realtime applications can     --   rely on the fact that the value of this clock is never set.+    --   (Identical to 'Boottime' since Linux 4.17, see https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/commit/?id=d6ed449afdb38f89a7b38ec50e367559e1b8f71f)+    --  @CLOCK_MONOTONIC@ (macOS - @SYSTEM_CLOCK@)   = Monotonic+     -- | The identifier of the system-wide clock measuring real time. For this-    --   clock, the value returned by getTime represents the amount of time (in+    --   clock, the value returned by 'getTime' represents the amount of time (in     --   seconds and nanoseconds) since the Epoch.+    -- @CLOCK_REALTIME@ (macOS - @CALENDAR_CLOCK@, Windows - @GetSystemTimeAsFileTime@)   | Realtime++#ifdef HS_CLOCK_HAVE_PROCESS_CPUTIME     -- | The identifier of the CPU-time clock associated with the calling-    --   process. For this clock, the value returned by getTime represents the+    --   process. For this clock, the value returned by 'getTime' represents the     --   amount of execution time of the current process.   | ProcessCPUTime-  -- | The identifier of the CPU-time clock associated with the calling OS-  --   thread. For this clock, the value returned by getTime represents the-  --   amount of execution time of the current OS thread.+#endif++#ifdef HS_CLOCK_HAVE_THREAD_CPUTIME+    -- | The identifier of the CPU-time clock associated with the calling OS+    --   thread. For this clock, the value returned by 'getTime' represents the+    --   amount of execution time of the current OS thread.   | ThreadCPUTime+#endif++#if defined (CLOCK_MONOTONIC_RAW)+    -- | (since Linux 2.6.28, macOS 10.12)+    --   Similar to 'Monotonic', but provides access to a+    --   raw hardware-based time that is not subject to NTP+    --   adjustments or the incremental adjustments performed by+    --   adjtime(3).+    --   @CLOCK_MONOTONIC_RAW@ (Windows - @QueryPerformanceCounter@, @QueryPerformanceFrequency@)+  | MonotonicRaw+#endif++#if defined (CLOCK_BOOTTIME)+    -- | (since Linux 2.6.39; Linux-specific)+    --   Identical to `Monotonic`, except it also includes+    --   any time that the system is suspended. This allows+    --   applications to get a suspend-aware monotonic clock+    --   without having to deal with the complications of 'Realtime',+    --   which may have discontinuities if the time is changed+    --   using settimeofday(2).+    --   (since Linux 4.17; identical to 'Monotonic')+    --   @CLOCK_BOOTTIME@+  | Boottime+#endif++#if defined (CLOCK_MONOTONIC_COARSE)+    -- | (since Linux 2.6.32; Linux-specific)+    --   A faster but less precise version of 'Monotonic'.+    --   Use when you need very fast, but not fine-grained timestamps.+    --   @CLOCK_MONOTONIC_COARSE@+  | MonotonicCoarse+#endif++#if defined (CLOCK_REALTIME_COARSE)+    -- | (since Linux 2.6.32; Linux-specific)+    --   A faster but less precise version of 'Realtime'.+    --   Use when you need very fast, but not fine-grained timestamps.+    --   @CLOCK_REALTIME_COARSE@+  | RealtimeCoarse+#endif+   deriving (Eq, Enum, Generic, Read, Show, Typeable)  #if defined(_WIN32)-foreign import ccall hs_clock_win32_gettime_monotonic :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_gettime_realtime :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_gettime_processtime :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_gettime_threadtime :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_getres_monotonic :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_getres_realtime :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_getres_processtime :: Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_win32_getres_threadtime :: Ptr TimeSpec -> IO ()-#elif defined(__MACH__)-foreign import ccall hs_clock_darwin_gettime :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()-foreign import ccall hs_clock_darwin_getres  :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_monotonic :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_realtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_processtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_threadtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_monotonic :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_realtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_processtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_threadtime :: Ptr TimeSpec -> IO () #else-foreign import ccall clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO ()-foreign import ccall clock_getres  :: #{type clockid_t} -> Ptr TimeSpec -> IO ()+#if MIN_VERSION_base(4,10,0)+type ClockId = CClockId+#else+type ClockId = #{type clockid_t} #endif -#if defined(_WIN32)-#elif defined(__MACH__)-clockToConst :: Clock -> #{type clock_id_t}-clockToConst Monotonic = #const SYSTEM_CLOCK-clockToConst Realtime = #const CALENDAR_CLOCK-clockToConst ProcessCPUTime = #const SYSTEM_CLOCK-clockToConst ThreadCPUTime = #const SYSTEM_CLOCK-#else-clockToConst :: Clock -> #{type clockid_t}-clockToConst Monotonic = #const CLOCK_MONOTONIC-clockToConst Realtime = #const CLOCK_REALTIME-clockToConst ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID-clockToConst ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID+foreign import ccall unsafe clock_gettime :: ClockId -> Ptr TimeSpec -> IO CInt+foreign import ccall unsafe clock_getres  :: ClockId -> Ptr TimeSpec -> IO CInt++foreign import capi unsafe "time.h value CLOCK_MONOTONIC" clock_MONOTONIC :: ClockId+foreign import capi unsafe "time.h value CLOCK_REALTIME" clock_REALTIME :: ClockId+#if defined (CLOCK_PROCESS_CPUTIME_ID)+foreign import capi unsafe "time.h value CLOCK_PROCESS_CPUTIME_ID" clock_PROCESS_CPUTIME_ID :: ClockId #endif+#if defined (CLOCK_THREAD_CPUTIME_ID)+foreign import capi unsafe "time.h value CLOCK_THREAD_CPUTIME_ID" clock_THREAD_CPUTIME_ID :: ClockId+#endif+#if defined (CLOCK_MONOTONIC_RAW)+foreign import capi unsafe "time.h value CLOCK_MONOTONIC_RAW" clock_MONOTONIC_RAW :: ClockId+#endif+#if defined (CLOCK_BOOTTIME)+foreign import capi unsafe "time.h value CLOCK_BOOTTIME" clock_BOOTTIME :: ClockId+#endif+#if defined (CLOCK_MONOTONIC_COARSE)+foreign import capi unsafe "time.h value CLOCK_MONOTONIC_COARSE" clock_MONOTONIC_COARSE :: ClockId+#endif+#if defined (CLOCK_REALTIME_COARSE)+foreign import capi unsafe "time.h value CLOCK_REALTIME_COARSE" clock_REALTIME_COARSE :: ClockId+#endif+#endif +#if !defined(_WIN32)+clockToConst :: Clock -> ClockId+clockToConst Monotonic = clock_MONOTONIC+clockToConst  Realtime = clock_REALTIME+#if defined (CLOCK_PROCESS_CPUTIME_ID)+clockToConst ProcessCPUTime = clock_PROCESS_CPUTIME_ID+#endif+#if defined (CLOCK_THREAD_CPUTIME_ID)+clockToConst  ThreadCPUTime = clock_THREAD_CPUTIME_ID+#endif+#if defined (CLOCK_MONOTONIC_RAW)+clockToConst    MonotonicRaw = clock_MONOTONIC_RAW+#endif+#if defined (CLOCK_BOOTTIME)+clockToConst        Boottime = clock_BOOTTIME+#endif+#if defined (CLOCK_MONOTONIC_COARSE)+clockToConst MonotonicCoarse = clock_MONOTONIC_COARSE+#endif+#if defined (CLOCK_REALTIME_COARSE)+clockToConst  RealtimeCoarse = clock_REALTIME_COARSE+#endif+#endif+ allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a allocaAndPeek f = alloca $ \ptr -> f ptr >> peek ptr @@ -116,10 +215,8 @@ getTime Realtime = allocaAndPeek hs_clock_win32_gettime_realtime getTime ProcessCPUTime = allocaAndPeek hs_clock_win32_gettime_processtime getTime ThreadCPUTime = allocaAndPeek hs_clock_win32_gettime_threadtime-#elif defined(__MACH__)-getTime clk = allocaAndPeek $ hs_clock_darwin_gettime $ clockToConst clk #else-getTime clk = allocaAndPeek $ clock_gettime $ clockToConst clk+getTime clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_gettime" . clock_gettime (clockToConst clk) #endif  #if defined(_WIN32)@@ -127,17 +224,15 @@ getRes Realtime = allocaAndPeek hs_clock_win32_getres_realtime getRes ProcessCPUTime = allocaAndPeek hs_clock_win32_getres_processtime getRes ThreadCPUTime = allocaAndPeek hs_clock_win32_getres_threadtime-#elif defined(__MACH__)-getRes clk = allocaAndPeek $ hs_clock_darwin_getres $ clockToConst clk #else-getRes clk = allocaAndPeek $ clock_getres $ clockToConst clk+getRes clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_getres" . clock_getres (clockToConst clk) #endif  -- | TimeSpec structure data TimeSpec = TimeSpec   { sec  :: {-# UNPACK #-} !Int64 -- ^ seconds   , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds-  } deriving (Eq, Generic, Read, Show, Typeable)+  } deriving (Generic, Read, Show, Typeable)  #if defined(_WIN32) instance Storable TimeSpec where@@ -165,41 +260,73 @@       return $ TimeSpec (fromIntegral xs) (fromIntegral xn) #endif +s2ns :: Num a => a+s2ns = 10^9+ normalize :: TimeSpec -> TimeSpec-normalize (TimeSpec xs xn) =-    let (q, r) = xn `divMod` (10^9)-    in TimeSpec (xs + q) r+normalize (TimeSpec xs xn) | xn < 0 || xn >= s2ns = TimeSpec (xs + q)  r+                           | otherwise            = TimeSpec  xs      xn+                             where (q, r) = xn `divMod` s2ns  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)-  (TimeSpec xs xn) * (TimeSpec ys yn) =-      normalize $ TimeSpec (xs * ys) (xn * yn)-  negate (TimeSpec xs xn) =-      normalize $ TimeSpec (negate xs) (negate xn)-  abs (TimeSpec xs xn) =-      normalize $ TimeSpec (abs xs) (signum xs * xn)-  signum (normalize -> TimeSpec xs yn)-    | signum xs == 0 = TimeSpec 0 (signum yn)-    | otherwise = TimeSpec 0 (signum xs)-  fromInteger x =-      -- For range, compute div, mod over integers, not any bounded type.-      let (q, r) = x `divMod` (10^9)-      in TimeSpec (fromInteger q) (fromInteger r)+  (TimeSpec xs xn) + (TimeSpec ys yn) = normalize $! TimeSpec (xs + ys) (xn + yn)+  (TimeSpec xs xn) - (TimeSpec ys yn) = normalize $! TimeSpec (xs - ys) (xn - yn)+  (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 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+  succ x = x + 1+  pred x = x - 1+  toEnum x = normalize $ TimeSpec 0 (fromIntegral x)+  fromEnum = fromEnum . toInteger++instance Real TimeSpec where+  toRational x = toInteger x % 1++instance Integral TimeSpec where+  toInteger = toNanoSecs+  quot (toInteger-> t1) (toInteger-> t2) = fromInteger $! quot t1 t2+  rem (toInteger-> t1) (toInteger-> t2) = fromInteger $! rem t1 t2+  div (toInteger-> t1) (toInteger-> t2) = fromInteger $! div t1 t2+  mod (toInteger-> t1) (toInteger-> t2) = fromInteger $! mod t1 t2+  divMod (toInteger-> t1) (toInteger-> t2) =+    let (q,r)=divMod t1 t2 in (fromInteger $! q, fromInteger $! r)+  quotRem (toInteger-> t1) (toInteger-> t2) =+    let (q,r)=quotRem t1 t2 in (fromInteger $! q, fromInteger $! r)++instance Eq TimeSpec where+  (normalize -> TimeSpec xs xn) == (normalize -> TimeSpec ys yn) | True == es = xn == yn+                                                                 | otherwise  = es+                                                                   where   es = xs == ys+ instance Ord TimeSpec where-  compare (TimeSpec xs xn) (TimeSpec ys yn)-    | EQ == ordering = compare xn yn-    | otherwise = ordering-    where-      ordering = compare xs ys+  compare (normalize -> TimeSpec xs xn) (normalize -> TimeSpec ys yn) | EQ ==  os = compare xn yn+                                                                      | 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+++-- | TimeSpec to nano seconds.+toNanoSecs :: TimeSpec -> Integer+toNanoSecs   (TimeSpec  (toInteger -> s) (toInteger -> n)) = s * s2ns + n+ -- | Compute the absolute difference. diffTimeSpec :: TimeSpec -> TimeSpec -> TimeSpec diffTimeSpec ts1 ts2 = abs (ts1 - ts2) +{-# DEPRECATED timeSpecAsNanoSecs "Use toNanoSecs instead! Replaced timeSpecAsNanoSecs with the same signature TimeSpec -> Integer" #-} -- | TimeSpec as nano seconds. timeSpecAsNanoSecs :: TimeSpec -> Integer-timeSpecAsNanoSecs t = toInteger (sec t) * 1000000000 + toInteger (nsec t)+timeSpecAsNanoSecs   (TimeSpec s n) = toInteger s * s2ns + toInteger n
+ System/Clock/Seconds.hs view
@@ -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
+ bench/benchmarks.hs view
@@ -0,0 +1,26 @@+{-# language CPP #-}+module Main (main) where++import Criterion.Main+import System.Clock++#if MIN_VERSION_base(4,11,0)+import GHC.Clock+#endif++main :: IO ()+main = defaultMain [+    bgroup "getTime" [+        bench "Monotonic" $ whnfIO (getTime Monotonic)+      , bench "Realtime" $ whnfIO (getTime Realtime)+      , bench "ProcessCPUTime" $ whnfIO (getTime ProcessCPUTime)+      , bench "ThreadCPUTime" $ whnfIO (getTime ThreadCPUTime)+      , bench "MonotonicRaw" $ whnfIO (getTime MonotonicRaw)+      , bench "Boottime" $ whnfIO (getTime Boottime)+      , bench "MonotonicCoarse" $ whnfIO (getTime MonotonicCoarse)+      , bench "RealtimeCoarse" $ whnfIO (getTime RealtimeCoarse)+      ]+#if MIN_VERSION_base(4,11,0)+  , bench "GHC.Clock.getMonotonicTimeNSec" $ whnfIO getMonotonicTimeNSec+#endif+  ]
− cbits/hs_clock_darwin.c 
@@ -1,29 +0,0 @@-#ifdef __MACH__-#include <time.h>-#include <mach/clock.h>-#include <mach/mach.h>--void hs_clock_darwin_gettime(clock_id_t clock, struct timespec *ts)-{-	// OS X does not have clock_gettime, use clock_get_time-	// see http://stackoverflow.com/questions/11680461/monotonic-clock-on-osx-	clock_serv_t cclock;-	mach_timespec_t mts;-	host_get_clock_service(mach_host_self(), clock, &cclock);-	clock_get_time(cclock, &mts);-	mach_port_deallocate(mach_task_self(), cclock);-	ts->tv_sec = mts.tv_sec;-	ts->tv_nsec = mts.tv_nsec;-}--void hs_clock_darwin_getres(clock_id_t clock, struct timespec *ts)-{-	clock_serv_t cclock;-	int nsecs;-	mach_msg_type_number_t count;-	host_get_clock_service(mach_host_self(), clock, &cclock);-	clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count);-	mach_port_deallocate(mach_task_self(), cclock);-}--#endif	/* __MACH__ */
cbits/hs_clock_win32.c view
@@ -28,12 +28,22 @@     t[1] = 100*(long)(t_100ns % 10000000UL); } +/* See https://ghc.haskell.org/trac/ghc/ticket/15094 */+#if defined(_WIN32) && !defined(_WIN64)+__attribute__((optimize("-fno-expensive-optimizations")))+#endif void hs_clock_win32_gettime_monotonic(long long* t) {    LARGE_INTEGER time;-   LARGE_INTEGER frequency;+   static LARGE_INTEGER frequency;+   static int hasFreq = 0;+    QueryPerformanceCounter(&time);-   QueryPerformanceFrequency(&frequency);+   if (!hasFreq)+   {+      hasFreq = 1;+      QueryPerformanceFrequency(&frequency);+   }    // seconds    t[0] = time.QuadPart / frequency.QuadPart;    // nanos =
clock.cabal view
@@ -1,5 +1,6 @@+cabal-version: >= 1.10 name:          clock-version:       0.4.6.0+version:       0.8.4 stability:     stable synopsis:      High-resolution clock functions: monotonic, realtime, cputime. description:   A package for convenient access to high-resolution clock and@@ -23,28 +24,56 @@                .                Imported Control.Applicative operators correctly for Haskell Platform on Windows on 2015-04-21.                .-               GNU/HURD build failure reported by Pino Toscano, patched by Joachim Breitner on 2015-05-07.+               Unit tests and instance fixes by Christian Burger on 2015-06-25.                .+               Removal of fromInteger : Integer -> TimeSpec by Cetin Sert on 2015-12-15.+               .+               New Linux-specific Clocks: MonotonicRaw, Boottime, MonotonicCoarse, RealtimeCoarse by Cetin Sert on 2015-12-15.+               .+               Reintroduction fromInteger : Integer -> TimeSpec by Cetin Sert on 2016-04-05.+               .+               Fixes for older Linux build failures introduced by new Linux-specific clocks by Mario Longobardi on 2016-04-18.+               .+               Refreshment release in 2019-04 after numerous contributions.+               .+               Refactoring for Windows, Mac implementation consistence by Alexander Vershilov on 2021-01-16.+               .                [Version Scheme]                Major-@/R/@-ewrite . New-@/F/@-unctionality . @/I/@-mprovementAndBugFixes . @/P/@-ackagingOnly                .                * @PackagingOnly@ changes are made for quality assurance reasons. -copyright:     Copyright © Cetin Sert 2009-2013, Eugene Kirpichov 2010, Finn Espen Gundersen 2013, Gerolf Seitz 2013, Mathieu Boespflug 2014, Chris Done 2015, Dimitri Sabadie 2015+copyright:     Copyright © Cetin Sert 2009-2023, Eugene Kirpichov 2010, Finn Espen Gundersen 2013, Gerolf Seitz 2013, Mathieu Boespflug 2014 2015, Chris Done 2015, Dimitri Sabadie 2015, Christian Burger 2015, Mario Longobardi 2016, Alexander Vershilov 2021. license:       BSD3 license-file:  LICENSE-author:        Cetin Sert <cetin@corsis.eu>, Corsis Research-maintainer:    Cetin Sert <cetin@corsis.eu>, Corsis Research+author:        Cetin Sert <cetin@elefunc.com>, Elefunc, Inc.+maintainer:    Cetin Sert <cetin@elefunc.com>, Elefunc, Inc. homepage:      https://github.com/corsis/clock bug-reports:   https://github.com/corsis/clock/issues category:      System build-type:    Simple-cabal-version: >= 1.6 +tested-with:+  GHC == 9.6.1+  GHC == 9.4.4+  GHC == 9.2.7+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2+  GHC == 7.10.3+  GHC == 7.8.4 +extra-source-files:+  CHANGELOG.md++ source-repository head     type:      git-    location:  git://github.com/corsis/clock.git+    location:  https://github.com/corsis/clock.git   flag llvm@@ -53,21 +82,53 @@   library-    if impl (ghc < 7.6)-      build-depends:       base >= 4.4 && <= 5, ghc-prim-    build-depends:       base >= 2 && <= 5+    build-depends:       base >= 4.7 && < 5+     exposed-modules:     System.Clock-    extensions:          DeriveGeneric+                         System.Clock.Seconds++    default-language:    Haskell2010+    default-extensions:  DeriveGeneric                          DeriveDataTypeable                          ForeignFunctionInterface                          ScopedTypeVariables                          ViewPatterns-    if os(darwin)-      c-sources:         cbits/hs_clock_darwin.c+                         GeneralizedNewtypeDeriving     if os(windows)       c-sources:         cbits/hs_clock_win32.c     include-dirs:        cbits-    ghc-options:         -O2 -Wall+    ghc-options:         -O3 -Wall      if flag(llvm)       ghc-options:       -fllvm -optlo-O3+++test-suite test+    default-language:    Haskell2010+    default-extensions:  ScopedTypeVariables+                         GeneralizedNewtypeDeriving+                         StandaloneDeriving+    type:+      exitcode-stdio-1.0+    hs-source-dirs:+      tests+    main-is:+      test.hs+    build-depends:+        base+      , tasty >= 0.10+      , tasty-quickcheck+      , clock++benchmark benchmarks+    default-language: Haskell2010+    type:+      exitcode-stdio-1.0+    hs-source-dirs:+      bench+    main-is:+      benchmarks.hs+    build-depends:+        base+      , criterion+      , clock
+ tests/test.hs view
@@ -0,0 +1,109 @@+import Test.Tasty+import Test.Tasty.QuickCheck as QuickCheck+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++deriving instance Arbitrary Seconds++main = defaultMain (localOption (QuickCheckTests 100000) $ tests)++tests :: TestTree+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+  ]++qcSeconds :: TestTree+qcSeconds = testGroup "Seconds-specific"+  [+    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+  ]