-- -- Implementation of Haskell 98's Time module. Suitable for use -- with Hugs98. -- module Time ( ClockTime(..) -- non-standard, report says its abstract. -- instances: Eq, Ord -- instances: Show (non-standard) , Month( January , February , March , April , May , June , July , August , September , October , November , December ) -- instances: Eq, Ord, Enum, Bounded -- instances: Ix, Read, Show , Day( Sunday , Monday , Tuesday , Wednesday , Thursday , Friday , Saturday) -- instances: Eq, Ord, Enum, Bounded -- instances: Ix, Read, Show , CalendarTime( CalendarTime , ctYear , ctMonth , ctDay , ctHour , ctMin , ctSec --added 2003-08-26 , ctPicosec , ctWDay , ctYDay , ctTZName , ctTZ , ctIsDST ) -- instances: Eq, Ord, Read, Show , TimeDiff( TimeDiff , tdYear , tdMonth , tdDay , tdHour , tdMin , tdSec , tdPicosec ) -- instances: Eq, Ord, Read, Show , getClockTime -- :: IO ClockTime , addToClockTime -- :: TimeDiff -> ClockTime -> ClockTime , diffClockTimes -- :: ClockTime -> ClockTime -> TimeDiff , toCalendarTime -- :: ClockTime -> IO CalendarTime , toUTCTime -- :: ClockTime -> CalendarTime , toClockTime -- :: CalendarTime -> ClockTime , calendarTimeToString -- :: CalendarTime -> String , formatCalendarTime -- :: TimeLocale -> String -> CalendarTime -> String -- NON-STANDARD (but also provided by GHC impl) , noTimeDiff -- :: TimeDiff ) where import Locale import Char ( intToDigit ) import IOExts ( unsafePerformIO ) import Ix ( Ix ) data ClockTime = TOD Integer -- secs Integer -- micro (10^-6) secs [0, 999999] deriving ( Eq, Ord ) -- Definitions of Month, Day, ClockTime, TimeDiff - straight out of the report: data Month = January | February | March | April | May | June | July | August | September | October | November | December deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) data Day = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) data CalendarTime = CalendarTime { ctYear :: Int , ctMonth :: Month , ctDay, ctHour, ctMin, ctSec :: Int , ctPicosec :: Integer , ctWDay :: Day , ctYDay :: Int , ctTZName :: String , ctTZ :: Int , ctIsDST :: Bool } deriving (Eq, Ord, Read, Show) data TimeDiff = TimeDiff { tdYear, tdMonth, tdDay :: Int , tdHour, tdMin :: Int --modified 2003-08-26 , tdSec, tdPicosec :: Integer --modified 2003-08-26 } deriving (Eq, Ord, Read, Show) noTimeDiff=TimeDiff 0 0 0 0 0 0 0 precision = 1000000 --added 2003-08-26 getClockTime :: IO ClockTime getClockTime = do (s,micros) <- getClockTimePrim return (TOD (fromIntegral s) (fromIntegral micros)) primitive getClockTimePrim :: IO (Int,Int) toClockTime :: CalendarTime -> ClockTime toClockTime (CalendarTime yr mon mday hour min sec _ _ _ _ tz _) = unsafePerformIO $ do --modified 2003-08-26 s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz 0 --modified 2003-08-26 return (TOD (fromIntegral s) 0) primitive toClockTimePrim :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO Int toUTCTime :: ClockTime -> CalendarTime toUTCTime ct = unsafePerformIO (toCalTime True ct) toCalendarTime :: ClockTime -> IO CalendarTime toCalendarTime = toCalTime False toCalTime :: Bool -> ClockTime -> IO CalendarTime toCalTime toUTC (TOD s msecs) | (s > fromIntegral (maxBound :: Int)) || (s < fromIntegral (minBound :: Int)) = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++ "clock secs out of range") | otherwise = do (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <- toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s) return (CalendarTime{ ctYear=1900+year , ctMonth=toEnum mon , ctDay=mday , ctHour=hour , ctMin=min , ctSec=sec , ctPicosec=msecs*1000*1000 , ctWDay=toEnum wday , ctYDay=yday , ctTZName=(if toUTC then "UTC" else zone) , ctTZ=(if toUTC then 0 else off) , ctIsDST=not toUTC && (isdst/=0) }) primitive toCalTimePrim :: Int -> Int -> IO (Int,Int,Int,Int,Int,Int,Int,Int,Int,String,Int) -- non-standard Show instance, but worth it..? (provided by GHC too). instance Show ClockTime where show ct = calendarTimeToString (unsafePerformIO (toCalendarTime ct)) --adds days, hours, minutes and seconds first and months and years after that 2003-08-26 addToClockTime :: TimeDiff -> ClockTime -> ClockTime addToClockTime (TimeDiff year mon day hour min sec psec) (TOD csecs msecs) = let (r_yr, r_mon) = mon `divMod` 12 --modified 2003-08-26 psecToMSec ps = ps `div` precision --modified 2003-08-26 secOff = --rhs modified 2003-08-26 sec + 60 * (toInteger min + 60 * (toInteger hour + 24 * toInteger day)) + exSec (exSec,msecs') = (msecs + psecToMSec psec) `quotRem` precision --modified 2003-08-26 new_mon = fromEnum (ctMonth cal) + r_mon (yr_diff , month') --declaration rewritten 2003-08-26 = new_mon `divMod` 12 year' = ctYear cal + year + r_yr + yr_diff cal = toUTCTime(TOD (csecs + secOff) msecs') in toClockTime cal{ctMonth=toEnum month', ctYear=year'} --modified 2003-08-26 diffClockTimes :: ClockTime -> ClockTime -> TimeDiff diffClockTimes (TOD s1 ms1) (TOD s2 ms2) --rhs rewritten 2003-08-26 = let (carry , frac) = (ms1 - ms2) `divMod` precision in noTimeDiff{ tdSec = s1 - s2 + carry , tdPicosec= 1000 * 1000 * frac } -- formatting CalendarTimes. calendarTimeToString :: CalendarTime -> String calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec wday yday tzname _ _) = doFmt fmt where doFmt ('%':c:cs) = decode c ++ doFmt cs doFmt (c:cs) = c : doFmt cs doFmt "" = "" decode 'A' = fst (wDays l !! fromEnum wday) decode 'a' = snd (wDays l !! fromEnum wday) decode 'B' = fst (months l !! fromEnum mon) decode 'b' = snd (months l !! fromEnum mon) decode 'h' = snd (months l !! fromEnum mon) decode 'C' = show2 (year `quot` 100) decode 'c' = doFmt (dateTimeFmt l) decode 'D' = doFmt "%m/%d/%y" decode 'd' = show2 day decode 'e' = show2' day decode 'H' = show2 hour decode 'I' = show2 (to12 hour) decode 'j' = show3 yday decode 'k' = show2' hour decode 'l' = show2' (to12 hour) decode 'M' = show2 min decode 'm' = show2 (fromEnum mon+1) decode 'n' = "\n" decode 'p' = (if hour < 12 then fst else snd) (amPm l) decode 'R' = doFmt "%H:%M" decode 'r' = doFmt (time12Fmt l) decode 'T' = doFmt "%H:%M:%S" decode 't' = "\t" decode 'S' = show2 sec decode 's' = show (case toClockTime ct of { (TOD s _) -> s }) decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) decode 'u' = show (let n = fromEnum wday in if n == 0 then 7 else n) decode 'V' = let (week, days) = (yday + 7 - if fromEnum wday > 0 then fromEnum wday - 1 else 6) `divMod` 7 in show2 (if days >= 4 then week+1 else if week == 0 then 53 else week) decode 'W' = show2 ((yday + 7 - if fromEnum wday > 0 then fromEnum wday - 1 else 6) `div` 7) decode 'w' = show (fromEnum wday) decode 'X' = doFmt (timeFmt l) decode 'x' = doFmt (dateFmt l) decode 'Y' = show year decode 'y' = show2 (year `rem` 100) decode 'Z' = tzname decode '%' = "%" decode c = [c] show2, show2', show3 :: Int -> String show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) to12 :: Int -> Int to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'