diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..722bd5f --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2009-2012, Cetin Sert +Copyright (c) 2010, Eugene Kirpichov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Clock.hsc b/System/Clock.hsc new file mode 100644 index 0000000..297607b --- /dev/null +++ b/System/Clock.hsc @@ -0,0 +1,288 @@ +-- | High-resolution, realtime clock and timer functions for Posix +-- systems. This module is being developed according to IEEE Std +-- 1003.1-2008: , +-- + +{-# 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 + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Int +import Data.Word +import Data.Typeable (Typeable) +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import GHC.Generics (Generic) + +#if defined(_WIN32) +# include "hs_clock_win32.c" +#elif defined(__MACH__) && defined(__APPLE__) +# include "hs_clock_darwin.c" +#else +# include +-- 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 +# endif +#endif + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +-- | 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. (The only suspend-aware +-- monotonic is CLOCK_BOOTTIME on Linux.) +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 + -- possible clock jump shall be implementation defined. For this clock, + -- the value returned by 'getTime' represents the amount of time (in + -- seconds and nanoseconds) since an unspecified point in the past (for + -- example, system start-up time, or the Epoch). This point does not + -- change after system start-up time. Note that the absolute value of the + -- 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. + = 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 + -- seconds and nanoseconds) since the Epoch. + | Realtime + + -- | The identifier of the CPU-time clock associated with the calling + -- 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. + | ThreadCPUTime + +#if defined (CLOCK_MONOTONIC_RAW) + -- | (since Linux 2.6.28; Linux-specific) + -- Similar to CLOCK_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). + | MonotonicRaw +#endif + +#if defined (CLOCK_BOOTTIME) + -- | (since Linux 2.6.39; Linux-specific) + -- Identical to CLOCK_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 + -- CLOCK_REALTIME, which may have discontinuities if the + -- time is changed using settimeofday(2). + | Boottime +#endif + +#if defined (CLOCK_MONOTONIC_COARSE) + -- | (since Linux 2.6.32; Linux-specific) + -- A faster but less precise version of CLOCK_MONOTONIC. + -- Use when you need very fast, but not fine-grained timestamps. + | MonotonicCoarse +#endif + +#if defined (CLOCK_REALTIME_COARSE) + -- | (since Linux 2.6.32; Linux-specific) + -- A faster but less precise version of CLOCK_REALTIME. + -- Use when you need very fast, but not fine-grained timestamps. + | 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__) && defined(__APPLE__) +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 () +#else +foreign import ccall clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO () +foreign import ccall clock_getres :: #{type clockid_t} -> Ptr TimeSpec -> IO () +#endif + +#if defined(_WIN32) +#elif defined(__MACH__) && defined(__APPLE__) +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 + +#if defined (CLOCK_MONOTONIC_RAW) +clockToConst MonotonicRaw = #const CLOCK_MONOTONIC_RAW +#endif + +#if defined (CLOCK_BOOTTIME) +clockToConst Boottime = #const CLOCK_BOOTTIME +#endif + +#if defined (CLOCK_MONOTONIC_COARSE) +clockToConst MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE +#endif + +#if defined (CLOCK_REALTIME_COARSE) +clockToConst RealtimeCoarse = #const CLOCK_REALTIME_COARSE +#endif + +#endif + +allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a +allocaAndPeek f = alloca $ \ptr -> f ptr >> peek ptr + +-- | The 'getTime' function shall return the current value for the +-- specified clock. +getTime :: Clock -> IO TimeSpec + +-- | 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 TimeSpec + +#if defined(_WIN32) +getTime Monotonic = allocaAndPeek hs_clock_win32_gettime_monotonic +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__) && defined(__APPLE__) +getTime clk = allocaAndPeek $! hs_clock_darwin_gettime $! clockToConst clk +#else +getTime clk = allocaAndPeek $! clock_gettime $! clockToConst clk +#endif + +#if defined(_WIN32) +getRes Monotonic = allocaAndPeek hs_clock_win32_getres_monotonic +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__) && defined(__APPLE__) +getRes clk = allocaAndPeek $! hs_clock_darwin_getres $! clockToConst clk +#else +getRes clk = allocaAndPeek $! clock_getres $! clockToConst clk +#endif + +-- | TimeSpec structure +data TimeSpec = TimeSpec + { sec :: {-# UNPACK #-} !Int64 -- ^ seconds + , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds + } deriving (Generic, Read, Show, Typeable) + +#if defined(_WIN32) +instance Storable TimeSpec where + sizeOf _ = sizeOf (undefined :: Int64) * 2 + alignment _ = alignment (undefined :: Int64) + poke ptr ts = do + pokeByteOff ptr 0 (sec ts) + pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts) + peek ptr = do + TimeSpec + <$> peekByteOff ptr 0 + <*> peekByteOff ptr (sizeOf (undefined :: Int64)) +#else +instance Storable TimeSpec where + sizeOf _ = #{size struct timespec} + alignment _ = #{alignment struct timespec} + poke ptr ts = do + let xs :: #{type time_t} = fromIntegral $ sec ts + xn :: #{type long} = fromIntegral $ nsec ts + #{poke struct timespec, tv_sec} ptr (xs) + #{poke struct timespec, tv_nsec} ptr (xn) + peek ptr = do + xs :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr + xn :: #{type long} <- #{peek struct timespec, tv_nsec} ptr + return $ TimeSpec (fromIntegral xs) (fromIntegral xn) +#endif + +s2ns :: Num a => a +s2ns = 10^9 + +normalize :: TimeSpec -> TimeSpec +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 (xsi_ysi) (xni_yni) + where xsi_ysi = fromInteger $! xsi*ysi + xni_yni = fromInteger $! (xni*yni + (xni*ysi + xsi*yni) * s2ns) `div` s2ns + xsi = toInteger xs + ysi = toInteger ys + xni = toInteger xn + yni = toInteger yn +-- let xsi = toInteger xs -- convert to arbitraty Integer type to avoid int overflow +-- xni = toInteger xn +-- ysi = toInteger ys +-- yni = toInteger yn -- seconds -- nanoseconds +-- in normalize $! TimeSpec (fromInteger $! xsi * ysi) (fromInteger $! (xni * yni + (xni * ysi + xsi * yni) * s2ns) `div` s2ns) + + 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 + fromInteger x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns + +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 (normalize -> TimeSpec xs xn) (normalize -> TimeSpec ys yn) | EQ == os = compare xn yn + | otherwise = os + where os = compare xs ys + +-- | 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 (TimeSpec s n) = toInteger s * s2ns + toInteger n diff --git a/cbits/hs_clock_darwin.c b/cbits/hs_clock_darwin.c new file mode 100644 index 0000000..6b80900 --- /dev/null +++ b/cbits/hs_clock_darwin.c @@ -0,0 +1,29 @@ +#ifdef __MACH__ +#include +#include +#include + +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__ */ diff --git a/cbits/hs_clock_win32.c b/cbits/hs_clock_win32.c new file mode 100644 index 0000000..5dcc2a9 --- /dev/null +++ b/cbits/hs_clock_win32.c @@ -0,0 +1,108 @@ +#ifdef _WIN32 +#include + +#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS) + #define U64(x) x##Ui64 +#else + #define U64(x) x##ULL +#endif + +#define DELTA_EPOCH_IN_100NS U64(116444736000000000) + +static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency) +{ + return (long)((1e9 * subsecond_time) / frequency); +} + +static ULONGLONG to_quad_100ns(FILETIME ft) +{ + ULARGE_INTEGER li; + li.LowPart = ft.dwLowDateTime; + li.HighPart = ft.dwHighDateTime; + return li.QuadPart; +} + +static void to_timespec_from_100ns(ULONGLONG t_100ns, long long *t) +{ + t[0] = (long)(t_100ns / 10000000UL); + t[1] = 100*(long)(t_100ns % 10000000UL); +} + +void hs_clock_win32_gettime_monotonic(long long* t) +{ + LARGE_INTEGER time; + LARGE_INTEGER frequency; + QueryPerformanceCounter(&time); + QueryPerformanceFrequency(&frequency); + // seconds + t[0] = time.QuadPart / frequency.QuadPart; + // nanos = + t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart); +} + +void hs_clock_win32_gettime_realtime(long long* t) +{ + FILETIME ft; + ULONGLONG tmp; + + GetSystemTimeAsFileTime(&ft); + + tmp = to_quad_100ns(ft); + tmp -= DELTA_EPOCH_IN_100NS; + + to_timespec_from_100ns(tmp, t); +} + +void hs_clock_win32_gettime_processtime(long long* t) +{ + FILETIME creation_time, exit_time, kernel_time, user_time; + ULONGLONG time; + + GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time); + // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117 + + time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time); + to_timespec_from_100ns(time, t); +} + +void hs_clock_win32_gettime_threadtime(long long* t) +{ + FILETIME creation_time, exit_time, kernel_time, user_time; + ULONGLONG time; + + GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time); + // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117 + + time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time); + to_timespec_from_100ns(time, t); +} + +void hs_clock_win32_getres_monotonic(long long* t) +{ + LARGE_INTEGER frequency; + QueryPerformanceFrequency(&frequency); + + ULONGLONG resolution = U64(1000000000)/frequency.QuadPart; + t[0] = resolution / U64(1000000000); + t[1] = resolution % U64(1000000000); +} + +void hs_clock_win32_getres_realtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +void hs_clock_win32_getres_processtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +void hs_clock_win32_getres_threadtime(long long* t) +{ + t[0] = 0; + t[1] = 100; +} + +#endif /* _WIN32 */ diff --git a/clock.cabal b/clock.cabal new file mode 100644 index 0000000..7530db1 --- /dev/null +++ b/clock.cabal @@ -0,0 +1,97 @@ +name: clock +version: 0.7.2 +stability: stable +synopsis: High-resolution clock functions: monotonic, realtime, cputime. +description: A package for convenient access to high-resolution clock and + timer functions of different operating systems via a unified API. + . + POSIX code and surface API was developed by Cetin Sert in 2009. + . + Windows code was contributed by Eugene Kirpichov in 2010. + . + FreeBSD code was contributed by Finn Espen Gundersen on 2013-10-14. + . + OS X code was contributed by Gerolf Seitz on 2013-10-15. + . + Derived @Generic@, @Typeable@ and other instances for @Clock@ and @TimeSpec@ was contributed by Mathieu Boespflug on 2014-09-17. + . + Corrected dependency listing for @GHC < 7.6@ was contributed by Brian McKenna on 2014-09-30. + . + Windows code corrected by Dimitri Sabadie on 2015-02-09. + . + Added @timeSpecAsNanoSecs@ as observed widely-used by Chris Done on 2015-01-06, exported correctly on 2015-04-20. + . + Imported Control.Applicative operators correctly for Haskell Platform on Windows on 2015-04-21. + . + 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. + . + [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-2016, 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 +license: BSD3 +license-file: LICENSE +author: Cetin Sert , Corsis Research +maintainer: Cetin Sert , Corsis Research +homepage: https://github.com/corsis/clock +bug-reports: https://github.com/corsis/clock/issues +category: System +build-type: Simple +cabal-version: >= 1.8 + + +source-repository head + type: git + location: git://github.com/corsis/clock.git + + +flag llvm + description: compile via LLVM + default : False + + +library + if impl (ghc < 7.6) + build-depends: base >= 4.4 && <= 5, ghc-prim + build-depends: base >= 2 && <= 5 + exposed-modules: System.Clock + extensions: DeriveGeneric + DeriveDataTypeable + ForeignFunctionInterface + ScopedTypeVariables + ViewPatterns + if os(darwin) + c-sources: cbits/hs_clock_darwin.c + if os(windows) + c-sources: cbits/hs_clock_win32.c + include-dirs: cbits + ghc-options: -O3 -Wall + + if flag(llvm) + ghc-options: -fllvm -optlo-O3 + + +test-suite test +-- default-language: +-- Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: + base >= 4 && < 5 + , tasty >= 0.10 + , tasty-quickcheck + , clock diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 index 0000000..f92872a --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,59 @@ +import Test.Tasty +import Test.Tasty.QuickCheck as QuickCheck +import Data.Fixed +import Data.List +-- import Test.Tasty.HUnit as HUnit +import System.Clock + +instance Arbitrary TimeSpec where + arbitrary = do + sec <- arbitrarySizedIntegral + nan <- arbitrarySizedIntegral + return $ TimeSpec sec nan + +main = defaultMain (adjustOption (QuickCheckTests 100000 +) $ tests) + +tests :: TestTree +tests = testGroup "All tests" [numInstanceTests, eqOrdInstancesTests] + +numInstanceTests = testGroup "Num class tests" [ + -- let's make at least 100,000 tests + qcNumInstance + ] + +eqOrdInstancesTests = testGroup "Eq and Ord instance tests" [ + -- let's make at least 100,000 tests + qcEqOrdInstance + ] + +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 == timeSpecAsNanoSecs (fromInteger x + fromInteger y) + , QuickCheck.testProperty "integer substraction equals TimeSpec addition" $ + \ x y -> x - y == timeSpecAsNanoSecs (fromInteger x - fromInteger y) + , QuickCheck.testProperty + "rational multiplication equals TimeSpec multiplication" $ + \ x y -> + let + rationalMul = truncate ((x :: Nano) * (y :: Nano) * (10^9)) + timespecMul = timeSpecAsNanoSecs ( + 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 + ] + +qcEqOrdInstance = testGroup "QuickCheck" + [ + QuickCheck.testProperty + "random list of TimeSpecs is sorted like equivalent list of integers" $ + \ x -> + sort (x :: [TimeSpec]) + == + map (fromInteger) (sort (map timeSpecAsNanoSecs x)) + ]