module System.Posix.Clock (
TimeSpec,
timeSpecSeconds,
timeSpecNanos,
mkTimeSpec,
timeSpecV,
timeSpecToInt64,
Clock(..),
monotonicClock,
realtimeClock,
processTimeClock,
threadTimeClock,
getProcessClock,
getClockResolution,
getClockTime,
setClockTime,
clockSleep,
clockSleepAbs,
) where
import Data.Int
import Data.Word
import Data.Ratio (numerator)
import Data.List (unfoldr)
import Control.Applicative ((<$>), (<*>))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (with)
import Foreign.C.Types (CInt, CULong, CTime)
import Foreign.C.Error (getErrno, eINTR, throwErrno, throwErrnoIfMinus1_)
import System.Posix.Types (ProcessID)
import Unsafe.Coerce (unsafeCoerce)
nsPerSecond ∷ Num α ⇒ α
nsPerSecond = 1000000000
minSecsInInt, minNsInInt ∷ Int
(minSecsInInt, minNsInInt) = (minBound ∷ Int) `divMod` nsPerSecond
maxSecsInInt, maxNsInInt ∷ Int
(maxSecsInInt, maxNsInInt) = (maxBound ∷ Int) `divMod` nsPerSecond
data TimeSpec = TimeSpec { timeSpecSeconds ∷ CTime
, timeSpecNanos ∷ CULong
} deriving (Eq, Show)
mkTimeSpec ∷ CTime → CULong → TimeSpec
mkTimeSpec s ns | ns < nsPerSecond = TimeSpec s ns
| otherwise = TimeSpec (s + fromIntegral q) r
where (q, r) = ns `quotRem` nsPerSecond
timeSpecV ∷ TimeSpec → (CTime, CULong)
timeSpecV (TimeSpec s ns) = (s, ns)
instance Ord TimeSpec where
(TimeSpec s1 ns1) `compare` (TimeSpec s2 ns2) =
case s1 `compare` s2 of
EQ → ns1 `compare` ns2
x → x
instance Bounded TimeSpec where
minBound = TimeSpec (fromIntegral (minBound ∷ Int32)) 0
maxBound = TimeSpec (fromIntegral (maxBound ∷ Int32))
(nsPerSecond 1)
instance Num TimeSpec where
(TimeSpec s1 ns1) * (TimeSpec s2 ns2) =
mkTimeSpec (s1 * s2 * nsPerSecond +
s1 * (fromIntegral ns2) + s2 * (fromIntegral ns1) +
(fromIntegral q)) $ fromIntegral r
where (q, r) = ((fromIntegral ns1 ∷ Word64) *
(fromIntegral ns2 ∷ Word64)) `quotRem` nsPerSecond
(TimeSpec s1 ns1) + (TimeSpec s2 ns2) = mkTimeSpec (s1 + s2) (ns1 + ns2)
(TimeSpec s1 ns1) (TimeSpec s2 ns2) =
if ns1 < ns2 then TimeSpec (s1 s2 1) (nsPerSecond ns2 + ns1)
else TimeSpec (s1 s2) (ns1 ns2)
negate (TimeSpec s ns) = mkTimeSpec ((s) 1) (nsPerSecond ns)
abs ts@(TimeSpec s _) = if s >= 0 then ts else negate ts
signum (TimeSpec s ns) | s < 0 = TimeSpec (1) (nsPerSecond 1)
| otherwise = TimeSpec 0 $ signum ns
fromInteger i = TimeSpec (fromInteger s) (fromInteger ns)
where (s, ns) = i `divMod` nsPerSecond
instance Real TimeSpec where
toRational (TimeSpec s ns) = toRational s * nsPerSecond + toRational ns
instance Enum TimeSpec where
succ (TimeSpec s ns) | ns == nsPerSecond 1 = TimeSpec (succ s) 0
| otherwise = TimeSpec s (succ ns)
pred (TimeSpec s ns) | ns == 0 = TimeSpec (pred s) (nsPerSecond 1)
| otherwise = TimeSpec s (ns 1)
toEnum i = TimeSpec (fromIntegral s) (fromIntegral ns)
where (s, ns) = i `divMod` nsPerSecond
fromEnum (TimeSpec s ns) =
if s' < minSecs || (s' == minSecs && ns < minNs) ||
s' > maxSecs || (s' == maxSecs && ns > maxNs)
then error "TimeSpec.fromEnum"
else fromIntegral s' * nsPerSecond + fromIntegral ns
where s', minSecs, maxSecs ∷ Int32
s' = unsafeCoerce s
minSecs = fromIntegral minSecsInInt
maxSecs = fromIntegral maxSecsInInt
minNs, maxNs ∷ CULong
minNs = fromIntegral minNsInInt
maxNs = fromIntegral maxNsInInt
enumFrom x = enumFromTo x maxBound
enumFromThen x y = enumFromThenTo x y bound
where bound | y >= x = maxBound
| otherwise = minBound
enumFromTo x y
| y >= x = unfoldr (\z → if z == y then Nothing else Just (z, z + 1)) x
| otherwise = unfoldr (\z → if z == y then Nothing else Just (z, z 1)) x
enumFromThenTo x n y
| d >= 0 =
if y < x
then []
else unfoldr (\z → if z > y then Nothing else Just (z, z + d)) x
| otherwise =
if y > x
then []
else unfoldr (\z → if z < y then Nothing else Just (z, z d)) x
where d = n x
instance Integral TimeSpec where
toInteger (TimeSpec s ns) = (numerator $ toRational s) * nsPerSecond +
toInteger ns
quotRem tsN tsD = (fromInteger q, fromInteger r)
where (q, r) = quotRem (toInteger tsN) (toInteger tsD)
timeSpecToInt64 ∷ TimeSpec → Int64
timeSpecToInt64 (TimeSpec s ns) =
(unsafeCoerce s ∷ Int64) * nsPerSecond +
fromIntegral ns
instance Storable TimeSpec where
alignment _ = 4
sizeOf _ = (8)
peek p = TimeSpec <$> (\hsc_ptr -> peekByteOff hsc_ptr 0) p
<*> (\hsc_ptr -> peekByteOff hsc_ptr 4) p
poke p (TimeSpec seconds nanoseconds) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p seconds
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p nanoseconds
newtype Clock = Clock Int32 deriving (Eq, Ord, Show, Storable)
monotonicClock :: Clock
monotonicClock = Clock 1
realtimeClock :: Clock
realtimeClock = Clock 0
processTimeClock :: Clock
processTimeClock = Clock 2
threadTimeClock :: Clock
threadTimeClock = Clock 3
getProcessClock ∷ ProcessID → IO Clock
getProcessClock pid =
alloca $ \p → do
throwErrnoIfMinus1_ "getProcClock" $ c_clock_getcpuclockid pid p
peek p
getClockResolution ∷ Clock → IO TimeSpec
getClockResolution clock =
alloca $ \p → do
throwErrnoIfMinus1_ "getClockResolution" $ c_clock_getres clock p
peek p
getClockTime ∷ Clock → IO TimeSpec
getClockTime clock =
alloca $ \p → do
throwErrnoIfMinus1_ "getClockTime" $ c_clock_gettime clock p
peek p
setClockTime ∷ Clock → TimeSpec → IO ()
setClockTime clock ts =
with ts $ throwErrnoIfMinus1_ "setClockTime" . c_clock_settime clock
clockSleep ∷ Clock → TimeSpec → IO TimeSpec
clockSleep clock ts =
with ts $ \pTs →
alloca $ \pLeft → do
result ← c_clock_nanosleep clock 0 pTs pLeft
if result == 0
then return 0
else do
errno ← getErrno
if errno == eINTR
then peek pLeft
else throwErrno "clockSleep"
clockSleepAbs ∷ Clock → TimeSpec → IO ()
clockSleepAbs clock ts =
with ts $ \p →
throwErrnoIfMinus1_ "clockSleepAbs" $
c_clock_nanosleep clock 1 p nullPtr
foreign import ccall unsafe "clock_getcpuclockid"
c_clock_getcpuclockid ∷ ProcessID → Ptr Clock → IO CInt
foreign import ccall unsafe "clock_getres"
c_clock_getres ∷ Clock → Ptr TimeSpec → IO CInt
foreign import ccall unsafe "clock_gettime"
c_clock_gettime ∷ Clock → Ptr TimeSpec → IO CInt
foreign import ccall unsafe "clock_settime"
c_clock_settime ∷ Clock → Ptr TimeSpec → IO CInt
foreign import ccall unsafe "clock_nanosleep"
c_clock_nanosleep ∷ Clock → CInt → Ptr TimeSpec → Ptr TimeSpec → IO CInt