Remove an unnecessary fromIntegral
[packages/old-time.git] / System / Time.hsc
1 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
2 -- XXX with some combinations of #defines we get warnings, e.g.
3 -- Warning: Defined but not used: `throwAwayReturnPointer'
4
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module      :  System.Time
8 -- Copyright   :  (c) The University of Glasgow 2001
9 -- License     :  BSD-style (see the file libraries/old-time/LICENSE)
10 -- 
11 -- Maintainer  :  libraries@haskell.org
12 -- Stability   :  provisional
13 -- Portability :  portable
14 --
15 -- The standard time library from Haskell 98.  This library is
16 -- deprecated, please look at @Data.Time@ in the @time@ package
17 -- instead.
18 --
19 -- "System.Time" provides functionality for clock times, including
20 -- timezone information (i.e, the functionality of \"@time.h@\",
21 -- adapted to the Haskell environment).  It follows RFC 1129 in its
22 -- use of Coordinated Universal Time (UTC).
23 --
24 -----------------------------------------------------------------------------
25
26 {-
27 Haskell 98 Time of Day Library
28 ------------------------------
29
30 2000/06/17 <michael.weber@post.rwth-aachen.de>:
31 RESTRICTIONS:
32   * min./max. time diff currently is restricted to
33     [minBound::Int, maxBound::Int]
34
35   * surely other restrictions wrt. min/max bounds
36
37
38 NOTES:
39   * printing times
40
41     `showTime' (used in `instance Show ClockTime') always prints time
42     converted to the local timezone (even if it is taken from
43     `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
44     honors the tzone & tz fields and prints UTC or whatever timezone
45     is stored inside CalendarTime.
46
47     Maybe `showTime' should be changed to use UTC, since it would
48     better correspond to the actual representation of `ClockTime'
49     (can be done by replacing localtime(3) by gmtime(3)).
50
51
52 BUGS:
53   * add proper handling of microsecs, currently, they're mostly
54     ignored
55
56   * `formatFOO' case of `%s' is currently broken...
57
58
59 TODO:
60   * check for unusual date cases, like 1970/1/1 00:00h, and conversions
61     between different timezone's etc.
62
63   * check, what needs to be in the IO monad, the current situation
64     seems to be a bit inconsistent to me
65
66   * check whether `isDst = -1' works as expected on other arch's
67     (Solaris anyone?)
68
69   * add functions to parse strings to `CalendarTime' (some day...)
70
71   * implement padding capabilities ("%_", "%-") in `formatFOO'
72
73   * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
74 -}
75
76 module System.Time
77      (
78         -- * Clock times
79
80         ClockTime(..) -- non-standard, lib. report gives this as abstract
81         -- instance Eq, Ord
82         -- instance Show (non-standard)
83
84      ,  getClockTime
85
86         -- * Time differences
87
88      ,  TimeDiff(..)
89      ,  noTimeDiff      -- non-standard (but useful when constructing TimeDiff vals.)
90      ,  diffClockTimes
91      ,  addToClockTime
92
93      ,  normalizeTimeDiff -- non-standard
94      ,  timeDiffToString  -- non-standard
95      ,  formatTimeDiff    -- non-standard
96
97         -- * Calendar times
98
99      ,  CalendarTime(..)
100      ,  Month(..)
101      ,  Day(..)
102      ,  toCalendarTime
103      ,  toUTCTime
104      ,  toClockTime
105      ,  calendarTimeToString
106      ,  formatCalendarTime
107
108      ) where
109
110 #ifdef __GLASGOW_HASKELL__
111 #include "HsTime.h"
112 #endif
113
114 #ifdef __NHC__
115 #include <time.h>
116 #  if defined(__sun) || defined(__CYGWIN32__)
117 #    define HAVE_TZNAME 1
118 #  else
119 #    define HAVE_TM_ZONE 1
120 #  endif
121 import Ix
122 #endif
123
124 import Prelude
125
126 import Data.Ix
127 import System.Locale
128 import Foreign hiding (unsafePerformIO)
129 import System.IO.Unsafe (unsafePerformIO)
130
131 #ifdef __HUGS__
132 import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim )
133 #else
134 import Foreign.C
135 #endif
136
137 -- One way to partition and give name to chunks of a year and a week:
138
139 -- | A month of the year.
140
141 data Month
142  = January   | February | March    | April
143  | May       | June     | July     | August
144  | September | October  | November | December
145  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
146
147 -- | A day of the week.
148
149 data Day 
150  = Sunday   | Monday | Tuesday | Wednesday
151  | Thursday | Friday | Saturday
152  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
153
154 -- | A representation of the internal clock time.
155 -- Clock times may be compared, converted to strings, or converted to an
156 -- external calendar time 'CalendarTime' for I\/O or other manipulations.
157
158 data ClockTime = TOD Integer Integer
159                 -- ^ Construct a clock time.  The arguments are a number
160                 -- of seconds since 00:00:00 (UTC) on 1 January 1970,
161                 -- and an additional number of picoseconds.
162                 --
163                 -- In Haskell 98, the 'ClockTime' type is abstract.
164                deriving (Eq, Ord)
165
166 -- When a ClockTime is shown, it is converted to a CalendarTime in the current
167 -- timezone and then printed.  FIXME: This is arguably wrong, since we can't
168 -- get the current timezone without being in the IO monad.
169
170 instance Show ClockTime where
171     showsPrec _ t = showString (calendarTimeToString 
172                                  (unsafePerformIO (toCalendarTime t)))
173
174 {-
175 The numeric fields have the following ranges.
176
177 \begin{verbatim}
178 Value         Range             Comments
179 -----         -----             --------
180
181 year    -maxInt .. maxInt       [Pre-Gregorian dates are inaccurate]
182 day           1 .. 31
183 hour          0 .. 23
184 min           0 .. 59
185 sec           0 .. 61           [Allows for two leap seconds]
186 picosec       0 .. (10^12)-1    [This could be over-precise?]
187 yday          0 .. 365          [364 in non-Leap years]
188 tz       -43200 .. 50400        [Variation from UTC in seconds]
189 \end{verbatim}
190 -}
191
192 -- | 'CalendarTime' is a user-readable and manipulable
193 -- representation of the internal 'ClockTime' type.
194
195 data CalendarTime 
196  = CalendarTime  {
197        ctYear    :: Int         -- ^ Year (pre-Gregorian dates are inaccurate)
198      , ctMonth   :: Month       -- ^ Month of the year
199      , ctDay     :: Int         -- ^ Day of the month (1 to 31)
200      , ctHour    :: Int         -- ^ Hour of the day (0 to 23)
201      , ctMin     :: Int         -- ^ Minutes (0 to 59)
202      , ctSec     :: Int         -- ^ Seconds (0 to 61, allowing for up to
203                                 -- two leap seconds)
204      , ctPicosec :: Integer     -- ^ Picoseconds
205      , ctWDay    :: Day         -- ^ Day of the week
206      , ctYDay    :: Int         -- ^ Day of the year
207                                 -- (0 to 364, or 365 in leap years)
208      , ctTZName  :: String      -- ^ Name of the time zone
209      , ctTZ      :: Int         -- ^ Variation from UTC in seconds
210      , ctIsDST   :: Bool        -- ^ 'True' if Daylight Savings Time would
211                                 -- be in effect, and 'False' otherwise
212  }
213  deriving (Eq,Ord,Read,Show)
214
215 -- | records the difference between two clock times in a user-readable way.
216
217 data TimeDiff
218  = TimeDiff {
219      tdYear    :: Int,
220      tdMonth   :: Int,
221      tdDay     :: Int,
222      tdHour    :: Int,
223      tdMin     :: Int,
224      tdSec     :: Int,
225      tdPicosec :: Integer -- not standard
226    }
227    deriving (Eq,Ord,Read,Show)
228
229 -- | null time difference.
230
231 noTimeDiff :: TimeDiff
232 noTimeDiff = TimeDiff 0 0 0 0 0 0 0
233
234 -- -----------------------------------------------------------------------------
235 -- | returns the current time in its internal representation.
236
237 realToInteger :: Real a => a -> Integer
238 realToInteger ct = round (realToFrac ct :: Double)
239   -- CTime, CClock, CUShort etc are in Real but not Fractional, 
240   -- so we must convert to Double before we can round it
241
242 getClockTime :: IO ClockTime
243 #ifdef __HUGS__
244 getClockTime = do
245   (sec,usec) <- getClockTimePrim
246   return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000))
247
248 #elif HAVE_GETTIMEOFDAY
249 getClockTime = do
250   allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
251     throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
252     sec  <- (#peek struct timeval,tv_sec)  p_timeval :: IO CTime
253     usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime
254     return (TOD (realToInteger sec) ((realToInteger usec) * 1000000))
255  
256 #elif HAVE_FTIME
257 getClockTime = do
258   allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
259   ftime p_timeb
260   sec  <- (#peek struct timeb,time) p_timeb :: IO CTime
261   msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort
262   return (TOD (realToInteger sec) (fromIntegral msec * 1000000000))
263
264 #else /* use POSIX time() */
265 getClockTime = do
266     secs <- time nullPtr -- can't fail, according to POSIX
267     return (TOD (realToInteger secs) 0)
268
269 #endif
270
271 -- -----------------------------------------------------------------------------
272 -- | @'addToClockTime' d t@ adds a time difference @d@ and a
273 -- clock time @t@ to yield a new clock time.  The difference @d@
274 -- may be either positive or negative.
275
276 addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime
277 addToClockTime (TimeDiff year mon day hour minute sec psec)
278                (TOD c_sec c_psec) = 
279         let
280           sec_diff = toInteger sec +
281                      60 * toInteger minute +
282                      3600 * toInteger hour +
283                      24 * 3600 * toInteger day
284           (d_sec, d_psec) = (c_psec + psec) `quotRem` 1000000000000
285           cal      = toUTCTime (TOD (c_sec + sec_diff + d_sec) d_psec)
286           new_mon  = fromEnum (ctMonth cal) + r_mon 
287           month' = fst tmp
288           yr_diff = snd tmp
289           tmp
290             | new_mon < 0  = (toEnum (12 + new_mon), (-1))
291             | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
292             | otherwise    = (toEnum new_mon, 0)
293             
294           (r_yr, r_mon) = mon `quotRem` 12
295
296           year' = ctYear cal + year + r_yr + yr_diff
297         in
298         toClockTime cal{ctMonth=month', ctYear=year'}
299
300 -- | @'diffClockTimes' t1 t2@ returns the difference between two clock
301 -- times @t1@ and @t2@ as a 'TimeDiff'.
302
303 diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff
304 -- diffClockTimes is meant to be the dual to `addToClockTime'.
305 -- If you want to have the TimeDiff properly splitted, use
306 -- `normalizeTimeDiff' on this function's result
307 --
308 -- CAVEAT: see comment of normalizeTimeDiff
309 diffClockTimes (TOD sa pa) (TOD sb pb) =
310     noTimeDiff{ tdSec     = fromIntegral (sa - sb) 
311                 -- FIXME: can handle just 68 years...
312               , tdPicosec = pa - pb
313               }
314
315
316 -- | converts a time difference to normal form.
317
318 normalizeTimeDiff :: TimeDiff -> TimeDiff
319 -- FIXME: handle psecs properly
320 -- FIXME: ?should be called by formatTimeDiff automagically?
321 --
322 -- when applied to something coming out of `diffClockTimes', you loose
323 -- the duality to `addToClockTime', since a year does not always have
324 -- 365 days, etc.
325 --
326 -- apply this function as late as possible to prevent those "rounding"
327 -- errors
328 normalizeTimeDiff td =
329   let
330       rest0 = toInteger (tdSec td)
331                + 60 * (toInteger (tdMin td)
332                     + 60 * (toInteger (tdHour td)
333                          + 24 * (toInteger (tdDay td)
334                               + 30 * toInteger (tdMonth td)
335                               + 365 * toInteger (tdYear td))))
336
337       (diffYears,  rest1)    = rest0 `quotRem` (365 * 24 * 3600)
338       (diffMonths, rest2)    = rest1 `quotRem` (30 * 24 * 3600)
339       (diffDays,   rest3)    = rest2 `quotRem` (24 * 3600)
340       (diffHours,  rest4)    = rest3 `quotRem` 3600
341       (diffMins,   diffSecs) = rest4 `quotRem` 60
342   in
343       td{ tdYear  = fromInteger diffYears
344         , tdMonth = fromInteger diffMonths
345         , tdDay   = fromInteger diffDays
346         , tdHour  = fromInteger diffHours
347         , tdMin   = fromInteger diffMins
348         , tdSec   = fromInteger diffSecs
349         }
350
351 #ifndef __HUGS__
352 -- -----------------------------------------------------------------------------
353 -- How do we deal with timezones on this architecture?
354
355 -- The POSIX way to do it is through the global variable tzname[].
356 -- But that's crap, so we do it The BSD Way if we can: namely use the
357 -- tm_zone and tm_gmtoff fields of struct tm, if they're available.
358
359 zone   :: Ptr CTm -> IO (Ptr CChar)
360 gmtoff :: Ptr CTm -> IO CLong
361 #if HAVE_TM_ZONE
362 zone x      = (#peek struct tm,tm_zone) x
363 gmtoff x    = (#peek struct tm,tm_gmtoff) x
364
365 #else /* ! HAVE_TM_ZONE */
366 # if HAVE_TZNAME || defined(_WIN32)
367 #  if cygwin32_HOST_OS
368 #   define tzname _tzname
369 #  endif
370 #  ifndef mingw32_HOST_OS
371 foreign import ccall unsafe "time.h &tzname" tzname :: Ptr CString
372 #  else
373 foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong
374 foreign import ccall unsafe "__hscore_tzname"   tzname :: Ptr CString
375 #  endif
376 zone x = do 
377   dst <- (#peek struct tm,tm_isdst) x
378   if dst then peekElemOff tzname 1 else peekElemOff tzname 0
379 # else /* ! HAVE_TZNAME */
380 -- We're in trouble. If you should end up here, please report this as a bug.
381 #  error "Don't know how to get at timezone name on your OS."
382 # endif /* ! HAVE_TZNAME */
383
384 -- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
385 # if HAVE_DECL_ALTZONE
386 foreign import ccall "&altzone"  altzone  :: Ptr CTime
387 foreign import ccall "&timezone" timezone :: Ptr CTime
388 gmtoff x = do 
389   dst <- (#peek struct tm,tm_isdst) x
390   tz <- if dst then peek altzone else peek timezone
391   return (-fromIntegral (realToInteger tz))
392 # else /* ! HAVE_DECL_ALTZONE */
393
394 #if !defined(mingw32_HOST_OS)
395 foreign import ccall "time.h &timezone" timezone :: Ptr CLong
396 #endif
397
398 -- Assume that DST offset is 1 hour ...
399 gmtoff x = do 
400   dst <- (#peek struct tm,tm_isdst) x
401   tz  <- peek timezone
402    -- According to the documentation for tzset(), 
403    --   http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html
404    -- timezone offsets are > 0 west of the Prime Meridian.
405    --
406    -- This module assumes the interpretation of tm_gmtoff, i.e., offsets
407    -- are > 0 East of the Prime Meridian, so flip the sign.
408   return (- (if dst then tz - 3600 else tz))
409 # endif /* ! HAVE_DECL_ALTZONE */
410 #endif  /* ! HAVE_TM_ZONE */
411 #endif /* ! __HUGS__ */
412
413 -- -----------------------------------------------------------------------------
414 -- | converts an internal clock time to a local time, modified by the
415 -- timezone and daylight savings time settings in force at the time
416 -- of conversion.  Because of this dependence on the local environment,
417 -- 'toCalendarTime' is in the 'IO' monad.
418
419 toCalendarTime :: ClockTime -> IO CalendarTime
420 #ifdef __HUGS__
421 toCalendarTime =  toCalTime False
422 #elif HAVE_LOCALTIME_R
423 toCalendarTime =  clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False
424 #else
425 toCalendarTime =  clockToCalendarTime_static localtime False
426 #endif
427
428 -- | converts an internal clock time into a 'CalendarTime' in standard
429 -- UTC format.
430
431 toUTCTime :: ClockTime -> CalendarTime
432 #ifdef __HUGS__
433 toUTCTime      =  unsafePerformIO . toCalTime True
434 #elif HAVE_GMTIME_R
435 toUTCTime      =  unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True
436 #else
437 toUTCTime      =  unsafePerformIO . clockToCalendarTime_static gmtime True
438 #endif
439
440 #ifdef __HUGS__
441 toCalTime :: Bool -> ClockTime -> IO CalendarTime
442 toCalTime toUTC (TOD s psecs)
443   | (s > fromIntegral (maxBound :: Int)) || 
444     (s < fromIntegral (minBound :: Int))
445   = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++
446            "clock secs out of range")
447   | otherwise = do
448     (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <- 
449                 toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s)
450     return (CalendarTime{ ctYear=1900+year
451                         , ctMonth=toEnum mon
452                         , ctDay=mday
453                         , ctHour=hour
454                         , ctMin=min
455                         , ctSec=sec
456                         , ctPicosec=psecs
457                         , ctWDay=toEnum wday
458                         , ctYDay=yday
459                         , ctTZName=(if toUTC then "UTC" else zone)
460                         , ctTZ=(if toUTC then 0 else off)
461                         , ctIsDST=not toUTC && (isdst/=0)
462                         })
463 #else /* ! __HUGS__ */
464 throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm))
465                        -> (Ptr CTime -> Ptr CTm -> IO (       ))
466 throwAwayReturnPointer fun x y = fun x y >> return ()
467
468 #if !HAVE_LOCALTIME_R || !HAVE_GMTIME_R
469 clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
470          -> IO CalendarTime
471 clockToCalendarTime_static fun is_utc (TOD secs psec) = do
472   with (fromIntegral secs :: CTime)  $ \ p_timer -> do
473     p_tm <- fun p_timer         -- can't fail, according to POSIX
474     clockToCalendarTime_aux is_utc p_tm psec
475 #endif
476
477 #if HAVE_LOCALTIME_R || HAVE_GMTIME_R
478 clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime
479          -> IO CalendarTime
480 clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do
481   with (fromIntegral secs :: CTime)  $ \ p_timer -> do
482     allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
483       fun p_timer p_tm
484       clockToCalendarTime_aux is_utc p_tm psec
485 #endif
486
487 clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime
488 clockToCalendarTime_aux is_utc p_tm psec = do
489     sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
490     minute <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
491     hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
492     mday  <-  (#peek struct tm,tm_mday ) p_tm :: IO CInt
493     mon   <-  (#peek struct tm,tm_mon  ) p_tm :: IO CInt
494     year  <-  (#peek struct tm,tm_year ) p_tm :: IO CInt
495     wday  <-  (#peek struct tm,tm_wday ) p_tm :: IO CInt
496     yday  <-  (#peek struct tm,tm_yday ) p_tm :: IO CInt
497     isdst <-  (#peek struct tm,tm_isdst) p_tm :: IO CInt
498     zone' <-  zone p_tm
499     tz    <-  gmtoff p_tm
500     
501     tzname' <- peekCString zone'
502     
503     let month  | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
504                | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
505     
506     return (CalendarTime 
507                 (1900 + fromIntegral year) 
508                 month
509                 (fromIntegral mday)
510                 (fromIntegral hour)
511                 (fromIntegral minute)
512                 (fromIntegral sec)
513                 psec
514                 (toEnum (fromIntegral wday))
515                 (fromIntegral yday)
516                 (if is_utc then "UTC" else tzname')
517                 (if is_utc then 0     else fromIntegral tz)
518                 (if is_utc then False else isdst /= 0))
519 #endif /* ! __HUGS__ */
520
521 -- | converts a 'CalendarTime' into the corresponding internal
522 -- 'ClockTime', ignoring the contents of the  'ctWDay', 'ctYDay',
523 -- 'ctTZName' and 'ctIsDST' fields.
524
525 toClockTime :: CalendarTime -> ClockTime
526 #ifdef __HUGS__
527 toClockTime (CalendarTime yr mon mday hour min sec psec
528                           _wday _yday _tzname tz _isdst) =
529   unsafePerformIO $ do
530     s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz
531     return (TOD (fromIntegral s) psec)
532 #else /* ! __HUGS__ */
533 toClockTime (CalendarTime year mon mday hour minute sec psec
534                           _wday _yday _tzname tz _isdst) =
535
536      -- `isDst' causes the date to be wrong by one hour...
537      -- FIXME: check, whether this works on other arch's than Linux, too...
538      -- 
539      -- so we set it to (-1) (means `unknown') and let `mktime' determine
540      -- the real value...
541     let isDst = -1 :: CInt in   -- if _isdst then (1::Int) else 0
542
543     if psec < 0 || psec > 999999999999 then
544         error "Time.toClockTime: picoseconds out of range"
545     else if tz < -43200 || tz > 50400 then
546         error "Time.toClockTime: timezone offset out of range"
547     else
548       unsafePerformIO $ do
549       allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
550         (#poke struct tm,tm_sec  ) p_tm (fromIntegral sec  :: CInt)
551         (#poke struct tm,tm_min  ) p_tm (fromIntegral minute :: CInt)
552         (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
553         (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
554         (#poke struct tm,tm_mon  ) p_tm (fromIntegral (fromEnum mon) :: CInt)
555         (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt)
556         (#poke struct tm,tm_isdst) p_tm isDst
557         t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
558                 (mktime p_tm)
559         -- 
560         -- mktime expects its argument to be in the local timezone, but
561         -- toUTCTime makes UTC-encoded CalendarTime's ...
562         -- 
563         -- Since there is no any_tz_struct_tm-to-time_t conversion
564         -- function, we have to fake one... :-) If not in all, it works in
565         -- most cases (before, it was the other way round...)
566         -- 
567         -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
568         -- to compensate, we add the timezone difference to mktime's
569         -- result.
570         -- 
571         gmtoffset <- gmtoff p_tm
572         let res = realToInteger t - fromIntegral tz + fromIntegral gmtoffset
573         return (TOD res psec)
574 #endif /* ! __HUGS__ */
575
576 -- -----------------------------------------------------------------------------
577 -- Converting time values to strings.
578
579 -- | formats calendar times using local conventions.
580
581 calendarTimeToString  :: CalendarTime -> String
582 calendarTimeToString  =  formatCalendarTime defaultTimeLocale "%c"
583
584 -- | formats calendar times using local conventions and a formatting string.
585 -- The formatting string is that understood by the ISO C @strftime()@
586 -- function.
587
588 formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
589 formatCalendarTime l fmt cal@(CalendarTime year mon day hour minute sec _
590                                        wday yday tzname' _ _) =
591         doFmt fmt
592   where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
593         doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
594         doFmt ('%':c:cs)   = decode c ++ doFmt cs
595         doFmt (c:cs) = c : doFmt cs
596         doFmt "" = ""
597
598         decode 'A' = fst (wDays l  !! fromEnum wday) -- day of the week, full name
599         decode 'a' = snd (wDays l  !! fromEnum wday) -- day of the week, abbrev.
600         decode 'B' = fst (months l !! fromEnum mon)  -- month, full name
601         decode 'b' = snd (months l !! fromEnum mon)  -- month, abbrev
602         decode 'h' = snd (months l !! fromEnum mon)  -- ditto
603         decode 'C' = show2 (year `quot` 100)         -- century
604         decode 'c' = doFmt (dateTimeFmt l)           -- locale's data and time format.
605         decode 'D' = doFmt "%m/%d/%y"
606         decode 'd' = show2 day                       -- day of the month
607         decode 'e' = show2' day                      -- ditto, padded
608         decode 'H' = show2 hour                      -- hours, 24-hour clock, padded
609         decode 'I' = show2 (to12 hour)               -- hours, 12-hour clock
610         decode 'j' = show3 yday                      -- day of the year
611         decode 'k' = show2' hour                     -- hours, 24-hour clock, no padding
612         decode 'l' = show2' (to12 hour)              -- hours, 12-hour clock, no padding
613         decode 'M' = show2 minute                    -- minutes
614         decode 'm' = show2 (fromEnum mon+1)          -- numeric month
615         decode 'n' = "\n"
616         decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
617         decode 'R' = doFmt "%H:%M"
618         decode 'r' = doFmt (time12Fmt l)
619         decode 'T' = doFmt "%H:%M:%S"
620         decode 't' = "\t"
621         decode 'S' = show2 sec                       -- seconds
622         decode 's' = let TOD esecs _ = toClockTime cal in show esecs
623                                                      -- number of secs since Epoch.
624         decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
625         decode 'u' = show (let n = fromEnum wday in  -- numeric day of the week (1=Monday, 7=Sunday)
626                            if n == 0 then 7 else n)
627         decode 'V' =                                 -- week number (as per ISO-8601.)
628             let (week, days) =                       -- [yep, I've always wanted to be able to display that too.]
629                    (yday + 7 - if fromEnum wday > 0 then 
630                                fromEnum wday - 1 else 6) `divMod` 7
631             in  show2 (if days >= 4 then
632                           week+1 
633                        else if week == 0 then 53 else week)
634
635         decode 'W' =                                 -- week number, weeks starting on monday
636             show2 ((yday + 7 - if fromEnum wday > 0 then 
637                                fromEnum wday - 1 else 6) `div` 7)
638         decode 'w' = show (fromEnum wday)            -- numeric day of the week, weeks starting on Sunday.
639         decode 'X' = doFmt (timeFmt l)               -- locale's preferred way of printing time.
640         decode 'x' = doFmt (dateFmt l)               -- locale's preferred way of printing dates.
641         decode 'Y' = show year                       -- year, including century.
642         decode 'y' = show2 (year `rem` 100)          -- year, within century.
643         decode 'Z' = tzname'                         -- timezone name
644         decode '%' = "%"
645         decode c   = [c]
646
647
648 show2, show2', show3 :: Int -> String
649 show2 x
650  | x' < 10   = '0': show x'
651  | otherwise = show x'
652  where x' = x `rem` 100
653
654 show2' x
655  | x' < 10   = ' ': show x'
656  | otherwise = show x'
657  where x' = x `rem` 100
658
659 show3 x = show (x `quot` 100) ++ show2 (x `rem` 100)
660
661 to12 :: Int -> Int
662 to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
663
664 -- Useful extensions for formatting TimeDiffs.
665
666 -- | formats time differences using local conventions.
667
668 timeDiffToString :: TimeDiff -> String
669 timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
670
671 -- | formats time differences using local conventions and a formatting string.
672 -- The formatting string is that understood by the ISO C @strftime()@
673 -- function.
674
675 formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
676 formatTimeDiff l fmt (TimeDiff year month day hour minute sec _)
677  = doFmt fmt
678   where 
679    doFmt ""         = ""
680    doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
681    doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
682    doFmt ('%':c:cs) = decode c ++ doFmt cs
683    doFmt (c:cs)     = c : doFmt cs
684
685    decode spec =
686     case spec of
687       'B' -> fst (months l !! fromEnum month)
688       'b' -> snd (months l !! fromEnum month)
689       'h' -> snd (months l !! fromEnum month)
690       'c' -> defaultTimeDiffFmt
691       'C' -> show2 (year `quot` 100)
692       'D' -> doFmt "%m/%d/%y"
693       'd' -> show2 day
694       'e' -> show2' day
695       'H' -> show2 hour
696       'I' -> show2 (to12 hour)
697       'k' -> show2' hour
698       'l' -> show2' (to12 hour)
699       'M' -> show2 minute
700       'm' -> show2 (fromEnum month + 1)
701       'n' -> "\n"
702       'p' -> (if hour < 12 then fst else snd) (amPm l)
703       'R' -> doFmt "%H:%M"
704       'r' -> doFmt (time12Fmt l)
705       'T' -> doFmt "%H:%M:%S"
706       't' -> "\t"
707       'S' -> show2 sec
708       's' -> show2 sec -- Implementation-dependent, sez the lib doc..
709       'X' -> doFmt (timeFmt l)
710       'x' -> doFmt (dateFmt l)
711       'Y' -> show year
712       'y' -> show2 (year `rem` 100)
713       '%' -> "%"
714       c   -> [c]
715
716    defaultTimeDiffFmt =
717        foldr (\ (v,s) rest -> 
718                   (if v /= 0 
719                      then show v ++ ' ':(addS v s)
720                        ++ if null rest then "" else ", "
721                      else "") ++ rest
722              )
723              ""
724              (zip [year, month, day, hour, minute, sec] (intervals l))
725
726    addS v s = if abs v == 1 then fst s else snd s
727
728 #ifndef __HUGS__
729 -- -----------------------------------------------------------------------------
730 -- Foreign time interface (POSIX)
731
732 type CTm = () -- struct tm
733
734 #if HAVE_LOCALTIME_R
735 foreign import ccall unsafe "HsTime.h __hscore_localtime_r"
736     localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
737 #else
738 foreign import ccall unsafe "time.h localtime"
739     localtime   :: Ptr CTime -> IO (Ptr CTm)
740 #endif
741 #if HAVE_GMTIME_R
742 foreign import ccall unsafe "HsTime.h __hscore_gmtime_r"
743     gmtime_r    :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
744 #else
745 foreign import ccall unsafe "time.h gmtime"
746     gmtime      :: Ptr CTime -> IO (Ptr CTm)
747 #endif
748 foreign import ccall unsafe "time.h mktime"
749     mktime      :: Ptr CTm   -> IO CTime
750
751 #if HAVE_GETTIMEOFDAY
752 type CTimeVal = ()
753 type CTimeZone = ()
754 foreign import ccall unsafe "HsTime.h __hscore_gettimeofday"
755     gettimeofday :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt
756 #elif HAVE_FTIME
757 type CTimeB = ()
758 #ifndef mingw32_HOST_OS
759 foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO CInt
760 #else
761 foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO ()
762 #endif
763 #else
764 foreign import ccall unsafe "time.h time" time :: Ptr CTime -> IO CTime
765 #endif
766 #endif /* ! __HUGS__ */