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