, getClockTime
, TimeDiff(..)
+ , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.)
, diffClockTimes
, addToClockTime
#ifdef __HUGS__
import PreludeBuiltin
#else
-import PrelBase
-import PrelShow
-import PrelIOBase
-import PrelHandle
-import PrelArr
-import PrelST
-import PrelAddr
-import PrelPack ( unpackCString, new_ps_array,
- freeze_ps_array, unpackCStringBA
+import PrelGHC ( RealWorld, (>#), (<#), (==#),
+ newIntArray#, readIntArray#,
+ unsafeFreezeByteArray#,
+ int2Integer#, negateInt# )
+import PrelBase ( Int(..) )
+import PrelNum ( Integer(..), fromInt )
+import PrelIOBase ( IO(..), unsafePerformIO, stToIO, constructErrorAndFail )
+import PrelShow ( showList__ )
+import PrelPack ( unpackCString, unpackCStringBA,
+ new_ps_array, freeze_ps_array
)
+import PrelByteArr ( MutableByteArray(..) )
+import PrelHandle ( Bytes )
+import PrelAddr ( Addr )
+
#endif
import Ix
-- In fact, I think one of Int32 or Word32 would do. - ADR
data ClockTime = TOD Int64 Int64 deriving (Eq, Ord)
#else
-data ClockTime = TOD Integer Integer deriving (Eq, Ord)
+data ClockTime = TOD Integer -- Seconds since 00:00:00 on 1 Jan 1970
+ Integer -- Picoseconds with the specified second
+ deriving (Eq, Ord)
+
#endif
\end{code}
data CalendarTime
= CalendarTime {
ctYear :: Int,
- ctMonth :: Int,
+ ctMonth :: Month,
ctDay :: Int,
ctHour :: Int,
ctMin :: Int,
#endif
}
deriving (Eq,Ord,Read,Show)
+
+noTimeDiff :: TimeDiff
+noTimeDiff = TimeDiff 0 0 0 0 0 0 0
\end{code}
@getClockTime@ returns the current time in its internal representation.
return (TOD sec (nsec * 1000))
else
constructErrorAndFail "getClockTime"
- where
+
#ifdef __HUGS__
- malloc1 = primNewByteArray sizeof_int64
- cvtUnsigned arr = primReadInt64Array arr 0
+malloc1 = primNewByteArray sizeof_int64
+cvtUnsigned arr = primReadInt64Array arr 0
#else
- malloc1 = IO $ \ s# ->
- case newIntArray# 1# s# of
- (# s2#, barr# #) ->
- (# s2#, MutableByteArray bottom barr# #)
-
- -- The C routine fills in an unsigned word. We don't have
- -- `unsigned2Integer#,' so we freeze the data bits and use them
- -- for an MP_INT structure. Note that zero is still handled specially,
- -- although (J# 1# (ptr to 0#)) is probably acceptable to gmp.
-
- cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# ->
- case readIntArray# arr# 0# s# of
- (# s2#, r# #) ->
- if r# ==# 0#
- then (# s2#, 0 #)
- else case unsafeFreezeByteArray# arr# s2# of
- (# s3#, frozen# #) ->
- (# s3#, J# 1# frozen# #)
+malloc1 :: IO (MutableByteArray RealWorld Int)
+malloc1 = IO $ \ s# ->
+ case newIntArray# 1# s# of
+ (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #)
+ where
+ bot = error "Time.malloc1"
+
+ -- The C routine fills in an unsigned word. We don't have
+ -- `unsigned2Integer#,' so we freeze the data bits and use them
+ -- for an MP_INT structure. Note that zero is still handled specially,
+ -- although (J# 1# (ptr to 0#)) is probably acceptable to gmp.
+
+cvtUnsigned :: MutableByteArray RealWorld Int -> IO Integer
+cvtUnsigned (MutableByteArray _ _ arr#) = IO $ \ s# ->
+ case readIntArray# arr# 0# s# of
+ (# s2#, r# #) | r# ==# 0# -> (# s2#, 0 #)
+ | otherwise ->
+ case unsafeFreezeByteArray# arr# s2# of
+ (# s3#, frozen# #) -> (# s3#, J# 1# frozen# #)
#endif
\end{code}
\begin{code}
-#ifdef __HUGS__
addToClockTime :: TimeDiff -> ClockTime -> ClockTime
addToClockTime (TimeDiff year mon day hour min sec psec)
- (TOD c_sec c_psec) = unsafePerformIO $ do
- res <- allocWords sizeof_int64
- rc <- toClockSec year mon day hour min sec 0 res
- if rc /= (0::Int)
- then do
- diff_sec <- primReadInt64Array res 0
- let diff_psec = psec
- return (TOD (c_sec + diff_sec) (c_psec + diff_psec))
- else
- error "Time.addToClockTime: can't perform conversion of TimeDiff"
-#else
-addToClockTime :: TimeDiff -> ClockTime -> ClockTime
-addToClockTime (TimeDiff year mon day hour min sec psec)
- (TOD c_sec c_psec) = unsafePerformIO $ do
- res <- stToIO (newIntArray (0,sizeof_time_t))
- rc <- toClockSec year mon day hour min sec (0::Int) res
- if rc /= 0
- then do
- diff_sec_i <- stToIO (readIntArray res 0)
- let
- diff_sec = int2Integer (case diff_sec_i of I# i# -> i#)
- diff_psec = psec
- return (TOD (c_sec + diff_sec) (c_psec + diff_psec))
- else
- error "Time.addToClockTime: can't perform conversion of TimeDiff"
-#endif
+ (TOD c_sec c_psec) =
+ let
+ sec_diff = fromInt sec + 60 * fromInt min + 3600 * fromInt hour + 24 * 3600 * fromInt day
+ cal = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))
+
+ new_mon = fromEnum (ctMonth cal) + r_mon
+ (month', yr_diff)
+ | new_mon < 0 = (toEnum (12 + new_mon), (-1))
+ | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
+ | otherwise = (toEnum new_mon, 0)
+
+ (r_yr, r_mon) = mon `quotRem` 12
+
+ year' = ctYear cal + year + r_yr + yr_diff
+ in
+ toClockTime cal{ctMonth=month', ctYear=year'}
diffClockTimes :: ClockTime -> ClockTime -> TimeDiff
diffClockTimes tod_a tod_b =
CalendarTime year_b mon_b day_b hour_b min_b sec_b psec_b _ _ _ _ _ = toUTCTime tod_b
in
TimeDiff (year_a - year_b)
- (mon_a - mon_b)
+ (fromEnum mon_a - fromEnum mon_b)
(day_a - day_b)
(hour_a - hour_b)
(min_a - min_b)
else
unsafePerformIO ( do
res <- allocWords sizeof_int64
- rc <- toClockSec year mon mday hour min sec isDst res
+ rc <- toClockSec year (fromEnum mon) mday hour min sec isDst res
if rc /= (0::Int)
then do
tm <- primReadInt64Array res 0
zone <- get_ZONE res
tz <- get_GMTOFF res
let tzname = unpackCString zone
- return (CalendarTime (1900+year) mon mday hour min sec psec
+ month
+ | mon >= 0 && mon <= 11 = toEnum mon
+ | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon)
+
+ return (CalendarTime (1900+year) month mday hour min sec psec
(toEnum wday) yday tzname tz (isdst /= (0::Int)))
toUTCTime :: ClockTime -> CalendarTime
year <- get_tm_year res
wday <- get_tm_wday res
yday <- get_tm_yday res
- return (CalendarTime (1900+year) mon mday hour min sec psec
+ let
+ month
+ | mon >= 0 && mon <= 11 = toEnum mon
+ | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon)
+
+ return (CalendarTime (1900+year) month mday hour min sec psec
(toEnum wday) yday "UTC" 0 False)
toClockTime :: CalendarTime -> ClockTime
error "Time.toClockTime: timezone offset out of range"
else
unsafePerformIO ( do
- res <- stToIO (newIntArray (0, sizeof_time_t))
- rc <- toClockSec year mon mday hour min sec isDst res
+ res <- malloc1
+ rc <- toClockSec year (fromEnum mon) mday hour min sec isDst res
if rc /= 0
then do
- i <- stToIO (readIntArray res 0)
- return (TOD (int2Integer (case i of I# i# -> i#)) psec)
+ i <- cvtUnsigned res
+ return (TOD i psec)
else error "Time.toClockTime: can't perform conversion"
)
where
isDst = if isdst then (1::Int) else 0
#endif
-bottom :: (Int,Int)
-bottom = error "Time.bottom"
-
-- (copied from PosixUtil, for now)
-- Allocate a mutable array of characters with no indices.
allocWords (I# size#) = IO $ \ s# ->
case newIntArray# size# s# of
(# s2#, barr# #) ->
- (# s2#, MutableByteArray bot barr# #)
+ (# s2#, MutableByteArray bot bot barr# #)
where
bot = error "Time.allocWords"
#endif
\end{code}
\begin{code}
-foreign import "libHS_cbits" "get_tm_sec" get_tm_sec :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_min" get_tm_min :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_hour" get_tm_hour :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_mday" get_tm_mday :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_mon" get_tm_mon :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_year" get_tm_year :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_wday" get_tm_wday :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_yday" get_tm_yday :: MBytes -> IO Int
-foreign import "libHS_cbits" "get_tm_isdst" get_tm_isdst :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_sec" unsafe get_tm_sec :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_min" unsafe get_tm_min :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_hour" unsafe get_tm_hour :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_mday" unsafe get_tm_mday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_mon" unsafe get_tm_mon :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_year" unsafe get_tm_year :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_wday" unsafe get_tm_wday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_yday" unsafe get_tm_yday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_isdst" unsafe get_tm_isdst :: MBytes -> IO Int
-foreign import "libHS_cbits" "prim_ZONE" prim_ZONE :: Bytes -> IO Addr
-foreign import "libHS_cbits" "prim_GMTOFF" prim_GMTOFF :: Bytes -> IO Int
+foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO Addr
+foreign import "libHS_cbits" "prim_GMTOFF" unsafe prim_GMTOFF :: Bytes -> IO Int
-foreign import "libHS_cbits" "sizeof_struct_tm" sizeof_struct_tm :: Int
+foreign import "libHS_cbits" "sizeof_struct_tm" unsafe sizeof_struct_tm :: Int
#ifdef __HUGS__
-- believed to be at least 1 bit (the sign bit!) bigger than sizeof_time_t
type MBytes = MutableByteArray RealWorld Int
-foreign import "libHS_cbits" "sizeof_time_t" sizeof_time_t :: Int
+foreign import "libHS_cbits" "sizeof_time_t" unsafe sizeof_time_t :: Int
-foreign import "libHS_cbits" "prim_SETZONE" prim_SETZONE :: MBytes -> MBytes -> IO Int
+foreign import "libHS_cbits" "prim_SETZONE" unsafe prim_SETZONE :: MBytes -> MBytes -> IO ()
#ifdef __HUGS__
-foreign import "libHS_cbits" "prim_toLocalTime" prim_toLocalTime :: Int64 -> MBytes -> IO Int
-foreign import "libHS_cbits" "prim_toUTCTime" prim_toUTCTime :: Int64 -> MBytes -> IO Int
+foreign import "libHS_cbits" "prim_toLocalTime" unsafe prim_toLocalTime :: Int64 -> MBytes -> IO Int
+foreign import "libHS_cbits" "prim_toUTCTime" unsafe prim_toUTCTime :: Int64 -> MBytes -> IO Int
#else
-foreign import "libHS_cbits" "toLocalTime" prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int
-foreign import "libHS_cbits" "toUTCTime" prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int
+foreign import "libHS_cbits" "toLocalTime" unsafe prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int
+foreign import "libHS_cbits" "toUTCTime" unsafe prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int
#endif
-foreign import "libHS_cbits" "get_ZONE" get_ZONE :: MBytes -> IO Addr
-foreign import "libHS_cbits" "GMTOFF" get_GMTOFF :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO Addr
+foreign import "libHS_cbits" "GMTOFF" unsafe get_GMTOFF :: MBytes -> IO Int
-foreign import "libHS_cbits" "toClockSec"
+foreign import "libHS_cbits" "toClockSec" unsafe
toClockSec :: Int -> Int -> Int -> Int -> Int
-> Int -> Int -> MBytes -> IO Int
-foreign import "libHS_cbits" "getClockTime"
+foreign import "libHS_cbits" "getClockTime" unsafe
primGetClockTime :: MutableByteArray RealWorld Int
-> MutableByteArray RealWorld Int
-> IO Int
-foreign import "libHS_cbits" "showTime"
+foreign import "libHS_cbits" "showTime" unsafe
showTime :: Int
-> Bytes
-> Int
projects / ghc-hetmet.git / blobdiff