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