diff --git a/Data/Hourglass.hs b/Data/Hourglass.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Data.Hourglass +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Types and methods for time manipulation. +-- +-- The most basic type for time representation is Elapsed, which +-- represent a number of elapsed seconds since the unix epoch. +-- +-- Every other defined types can be convert to and from Elapsed type: +-- +-- > timeGetElapsed (Date 1 2 3) :: Elapsed +-- > timeFromElapsed 123 :: DateTime +-- +-- Local time is represented by any other time types (Elapsed, Date, DateTime, ..), +-- but augmented by a Timezone offset in minutes. +-- +-- > localTime (Date 2014 May 4) 600 -- local time at UTC+10 of May 4th 2014 +-- +module Data.Hourglass + ( module Data.Hourglass.Time + , module Data.Hourglass.Types + , module Data.Hourglass.Format + , module Data.Hourglass.Local + , module Data.Hourglass.Zone + -- * Calendar misc functions + , isLeapYear + , getWeekDay + , getDayOfTheYear + ) where + +import Data.Hourglass.Time +import Data.Hourglass.Format +import Data.Hourglass.Types +import Data.Hourglass.Local +import Data.Hourglass.Zone +import Data.Hourglass.Calendar (isLeapYear, getWeekDay, getDayOfTheYear) diff --git a/Data/Hourglass/Calendar.hs b/Data/Hourglass/Calendar.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Calendar.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Data.Hourglass.Calendar +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Misc calendar functions +-- +module Data.Hourglass.Calendar + ( isLeapYear + , getWeekDay + , getDayOfTheYear + , dateToUnixEpoch + , dateFromUnixEpoch + , todToSeconds + , dateTimeToUnixEpoch + , dateTimeFromUnixEpoch + , dateTimeFromUnixEpochP + ) where + +import Data.Hourglass.Types +import Data.Hourglass.Internal + +-- | Return if this year is a leap year (366 days) +-- or not (365 days in a year) +isLeapYear :: Int -> Bool +isLeapYear year + | year `mod` 4 /= 0 = False + | year `mod` 100 /= 0 = True + | year `mod` 400 == 0 = True + | otherwise = False + +-- | Return the day of the week a specific date fall in +getWeekDay :: Date -> WeekDay +getWeekDay date = toEnum (d `mod` 7) + where d = daysOfDate date + +-- | return the number of days until the beggining of the month specified for a specific year. +daysUntilMonth :: Int -> Month -> Int +daysUntilMonth y m + | isLeapYear y = leapYears !! fromEnum m + | otherwise = normalYears !! fromEnum m + where normalYears = [ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 ] + leapYears = [ 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366 ] + +{- +-- | Return the number of days in a month. +daysInMonth :: Int -> Month -> Int +daysInMonth y m + | m == February && isLeapYear y = 29 + | otherwise = days !! fromEnum m + where days = [31,28,31,30,31,30,31,31,30,31,30,31] +-} + +-- | return the day of the year where Jan 1 is 0 +-- +-- between 0 and 364. 365 for leap years +getDayOfTheYear :: Date -> Int +getDayOfTheYear (Date y m d) = daysUntilMonth y m + d + +-- | return the number of days before Jan 1st of the year +daysBeforeYear :: Int -> Int +daysBeforeYear year = y * 365 + (y `div` 4) - (y `div` 100) + (y `div` 400) + where y = year - 1 + +-- | Return the number of day since 1 january 1 +daysOfDate :: Date -> Int +daysOfDate (Date y m d) = daysBeforeYear y + daysUntilMonth y m + d + +-- | Return the number of seconds to unix epoch of a date considering hour=0,minute=0,second=0 +dateToUnixEpoch :: Date -> Elapsed +dateToUnixEpoch date = Elapsed $ Seconds (fromIntegral (daysOfDate date - epochDays) * secondsPerDay) + where epochDays = 719163 + secondsPerDay = 86400 + +-- | Return the Date associated with the unix epoch +dateFromUnixEpoch :: Elapsed -> Date +dateFromUnixEpoch e = dtDate $ dateTimeFromUnixEpoch e + +-- | Return the number of seconds from a time structure +todToSeconds :: TimeOfDay -> Seconds +todToSeconds (TimeOfDay h m s _) = + fromIntegral h * 3600 + fromIntegral m * 60 + fromIntegral s + +-- | Return the number of seconds to unix epoch of a date time +dateTimeToUnixEpoch :: DateTime -> Elapsed +dateTimeToUnixEpoch (DateTime d t) = dateToUnixEpoch d + Elapsed (todToSeconds t) diff --git a/Data/Hourglass/Diff.hs b/Data/Hourglass/Diff.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Diff.hs @@ -0,0 +1,151 @@ +-- | +-- Module : Data.Hourglass.Diff +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- time arithmetic methods +-- +module Data.Hourglass.Diff + ( TimeDiff(..) + , normalizeTimeDiff + , dateTimeAdd + , elapsedTimeAddSeconds + , elapsedTimeAddSecondsP + , elapsedTimeAdd + , elapsedTimeAddP + ) where + +import Data.Int +import Data.Monoid +import Data.Hourglass.Types +import Data.Hourglass.Calendar + +-- | A simple Time difference structure. +-- +-- A null time difference can be created with 'mempty' and +-- the structures can be combined with 'mappend' or 'mconcat'. +-- +-- Example: +-- +-- > mempty { timeDiffMonths = 1 } `mappend` mempty { timeDiffSeconds = 24 } +-- +data TimeDiff = TimeDiff + { timeDiffYears :: Int -- ^ number of years + , timeDiffMonths :: Int -- ^ number of months + , timeDiffDays :: Int -- ^ number of days + , timeDiffHours :: Int -- ^ number of hours + , timeDiffMinutes :: Int -- ^ number of minutes + , timeDiffSeconds :: Int -- ^ number of seconds + , timeDiffNs :: Int -- ^ number of nanoseconds + } deriving (Show,Eq) + +-- | simplify a time difference +toSimplerTimeDiff :: TimeDiff -> (Int, Int, Seconds, NanoSeconds) +toSimplerTimeDiff (TimeDiff y m d h mi s ns) = + (y, m, Seconds accSecs, NanoSeconds ns') + where accSecs = (((i64 d * 24) + i64 h) * 60 + i64 mi) * 60 + i64 s + i64 sacc + (sacc, ns') = ns `divMod` 1000000000 + + i64 :: Int -> Int64 + i64 = fromIntegral + +instance Monoid TimeDiff where + mempty = TimeDiff 0 0 0 0 0 0 0 + mappend (TimeDiff f1 f2 f3 f4 f5 f6 f7) (TimeDiff g1 g2 g3 g4 g5 g6 g7) = + TimeDiff (f1+g1) (f2+g2) (f3+g3) (f4+g4) (f5+g5) (f6+g6) (f7+g7) + +-- | Normalize all constant bounded fields, +-- i.e. all except days since we don't know to which +-- months they apply. +normalizeTimeDiff :: TimeDiff -> TimeDiff +normalizeTimeDiff (TimeDiff y m d h mi s ns) = + TimeDiff y' m' (d+dacc) h' mi' s' ns' + where + y' = y + macc + (macc, m') = m `divMod` 12 + (dacc, h') = (h+hacc) `divMod` 24 + (hacc, mi') = (mi+miacc) `divMod` 60 + (miacc, s') = (s+sacc) `divMod` 60 + (sacc, ns') = ns `divMod` 1000000000 + +-- | relatively add some years and months to a date +dateTimeAddYM :: DateTime -> (Int, Int) -> DateTime +dateTimeAddYM (DateTime (Date y m d) tod) (yDiff, mDiff) = + DateTime (Date (y+yDiff+yDiffAcc) (toEnum mNew) d) tod + where + (yDiffAcc,mNew) = (fromEnum m + mDiff) `divMod` 12 + +-- | add to a DateTime +dateTimeAdd :: DateTime -> TimeDiff -> DateTime +dateTimeAdd dt td = + dateTimeFromUnixEpoch $ elapsedTimeAdd (dateTimeToUnixEpoch dt) td + +-- | add a (year,month,seconds) to an Elapsed +elapsedTimeAddSimple :: Elapsed -> (Int, Int, Seconds) -> Elapsed +elapsedTimeAddSimple e (y,m,secs) + | y == 0 && m == 0 = e' + | otherwise = + let dt = dateTimeFromUnixEpoch e' + in dateTimeToUnixEpoch $ dateTimeAddYM dt (y, m) + where e' = e + Elapsed secs + +-- | Add a number of seconds to an Elapsed type +elapsedTimeAddSeconds :: Elapsed -> Seconds -> Elapsed +elapsedTimeAddSeconds (Elapsed s1) s2 = Elapsed (s1+s2) + +-- | Add a number of seconds to an ElapsedP type +elapsedTimeAddSecondsP :: ElapsedP -> Seconds -> ElapsedP +elapsedTimeAddSecondsP (ElapsedP (Elapsed s1) ns1) s2 = ElapsedP (Elapsed (s1+s2)) ns1 + +-- | add a time difference +elapsedTimeAdd :: Elapsed -> TimeDiff -> Elapsed +elapsedTimeAdd e td = elapsedTimeAddSimple e (y,m,secs) + where (y,m,secs,_) = toSimplerTimeDiff td + +-- | add a time difference with nanoseconds precisions +elapsedTimeAddP :: ElapsedP -> TimeDiff -> ElapsedP +elapsedTimeAddP (ElapsedP e (NanoSeconds ns)) td = ElapsedP e' ns' + where (y,m,secs,ns') = toSimplerTimeDiff td' + e' = elapsedTimeAddSimple e (y,m,secs) + td' = td { timeDiffNs = timeDiffNs td + ns } + +{- disabled for warning purpose. to be implemented + +-- | Duration string to time diff +-- +-- +-- +-- * P is the duration designator (historically called "period") placed at the start of the duration representation. +-- +-- * Y is the year designator that follows the value for the number of years. +-- +-- * M is the month designator that follows the value for the number of months. +-- +-- * W is the week designator that follows the value for the number of weeks. +-- +-- * D is the day designator that follows the value for the number of days. +-- +-- * T is the time designator that precedes the time components of the representation. +-- +-- * H is the hour designator that follows the value for the number of hours. +-- +-- * M is the minute designator that follows the value for the number of minutes. +-- +-- * S is the second designator that follows the value for the number of seconds. +-- +timeDiffFromDuration :: String -> TimeDiff +timeDiffFromDuration _ = undefined + +-- | Human description string to time diff +-- +-- examples: +-- +-- * "1 day" +-- +-- * "2 months, 5 days and 1 second" +-- +timeDiffFromDescription :: String -> TimeDiff +timeDiffFromDescription _ = undefined +-} diff --git a/Data/Hourglass/Epoch.hs b/Data/Hourglass/Epoch.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Epoch.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Data.Hourglass.Epoch +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Epoch tracking +-- +module Data.Hourglass.Epoch + ( + -- * computer time tracking with various epoch + ElapsedSince(..) + , ElapsedSinceP(..) + -- * Epoch + , Epoch(..) + -- ** standard and usual epochs + , UnixEpoch(..) + , WindowsEpoch(..) + ) where + +import Data.Data +import Control.DeepSeq +import Data.Hourglass.Types +import Data.Hourglass.Time + +-- | A number of seconds elapsed since an epoch. +newtype ElapsedSince epoch = ElapsedSince Seconds + deriving (Show,Read,Eq,Ord,Num,Data,Typeable,NFData) + +-- | A number of seconds and nanoseconds elapsed since an epoch. +data ElapsedSinceP epoch = ElapsedSinceP {-# UNPACK #-} !(ElapsedSince epoch) + {-# UNPACK #-} !NanoSeconds + deriving (Show,Read,Eq,Ord,Data,Typeable) + +instance NFData (ElapsedSinceP e) where rnf e = e `seq` () + +instance Num (ElapsedSinceP e) where + (ElapsedSinceP e1 ns1) + (ElapsedSinceP e2 ns2) = ElapsedSinceP (e1+e2) (ns1+ns2) + (ElapsedSinceP e1 ns1) - (ElapsedSinceP e2 ns2) = ElapsedSinceP (e1-e2) (ns1-ns2) + (ElapsedSinceP e1 ns1) * (ElapsedSinceP e2 ns2) = ElapsedSinceP (e1*e2) (ns1*ns2) + negate (ElapsedSinceP e ns) = ElapsedSinceP (negate e) ns + abs (ElapsedSinceP e ns) = ElapsedSinceP (abs e) ns + signum (ElapsedSinceP e ns) = ElapsedSinceP (signum e) ns + fromInteger i = ElapsedSinceP (ElapsedSince (fromIntegral i)) 0 + +-- FIXME instance Real (ElapsedSinceP e) + +-- | epoch related. +-- +-- We use the well known Unix epoch as the +-- reference timezone for doing conversion between epochs. +-- +-- Each methods of this typeclass should not use the actual value, +-- but only get the information needed from the type itself. +class Epoch epoch where + -- | The name of this epoch + epochName :: epoch -> String + + -- | number of seconds of difference with 1st January 1970. + -- + -- a negative number means that this epoch start before + -- the unix epoch. + epochDiffToUnix :: epoch -> Seconds + +-- | Unix Epoch, starting 1st January 1970 +data UnixEpoch = UnixEpoch + deriving (Show,Eq) + +instance Epoch UnixEpoch where + epochName _ = "unix" + epochDiffToUnix _ = 0 + +-- | Windows Epoch, starting 1st January 1601 +data WindowsEpoch = WindowsEpoch + deriving (Show,Eq) + +instance Epoch WindowsEpoch where + epochName _ = "windows" + epochDiffToUnix _ = -11644473600 + +instance Epoch epoch => Timeable (ElapsedSince epoch) where + timeGetElapsedP es = ElapsedP (Elapsed e) 0 + where ElapsedSince e = convertEpoch es :: ElapsedSince UnixEpoch + timeGetElapsed es = Elapsed e + where ElapsedSince e = convertEpoch es :: ElapsedSince UnixEpoch + timeGetNanoSeconds _ = 0 + +instance Epoch epoch => Time (ElapsedSince epoch) where + timeFromElapsedP (ElapsedP (Elapsed e) _) = + convertEpoch (ElapsedSince e :: ElapsedSince UnixEpoch) + +instance Epoch epoch => Timeable (ElapsedSinceP epoch) where + timeGetElapsedP es = ElapsedP (Elapsed e) ns + where ElapsedSinceP (ElapsedSince e) ns = convertEpochP es :: ElapsedSinceP UnixEpoch + timeGetNanoSeconds (ElapsedSinceP _ ns) = ns +instance Epoch epoch => Time (ElapsedSinceP epoch) where + timeFromElapsedP (ElapsedP (Elapsed e) ns) = convertEpochP (ElapsedSinceP (ElapsedSince e) ns :: ElapsedSinceP UnixEpoch) + +-- | Convert Elapsed seconds to another epoch with explicit epochs specified +convertEpochWith :: (Epoch e1, Epoch e2) => (e1,e2) -> ElapsedSince e1 -> ElapsedSince e2 +convertEpochWith (e1,e2) (ElapsedSince s1) = ElapsedSince (s1 + diff) + where diff = d1 - d2 + d1 = epochDiffToUnix e1 + d2 = epochDiffToUnix e2 + +-- | Convert Elapsed seconds to another epoch. +-- +-- the actual epochs need to be known somehow by the context, otherwise this function +-- will yield a compilation errors as the epoch are not chosen. +-- +-- If you want to force specific epoch conversion, use convertEpochWith +convertEpoch :: (Epoch e1, Epoch e2) => ElapsedSince e1 -> ElapsedSince e2 +convertEpoch = convertEpochWith (undefined, undefined) + +-- | Convert Precise Elapsed seconds to another epoch with explicit epochs specified +convertEpochPWith :: (Epoch e1, Epoch e2) => (e1,e2) -> ElapsedSinceP e1 -> ElapsedSinceP e2 +convertEpochPWith es (ElapsedSinceP e1 n1) = ElapsedSinceP (convertEpochWith es e1) n1 + +-- | Convert Elapsed seconds to another epoch. +-- +-- the actual epochs need to be known somehow by the context, otherwise this function +-- will yield a compilation errors as the epoch are not chosen. +-- +-- If you want to force specific epoch conversion, use convertEpochWith +convertEpochP :: (Epoch e1, Epoch e2) => ElapsedSinceP e1 -> ElapsedSinceP e2 +convertEpochP = convertEpochPWith (undefined, undefined) diff --git a/Data/Hourglass/Format.hs b/Data/Hourglass/Format.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Format.hs @@ -0,0 +1,297 @@ +-- | +-- Module : Data.Hourglass.Format +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Time formatting : printing and parsing +-- +-- Built-in format strings +-- +{-# LANGUAGE FlexibleInstances #-} +module Data.Hourglass.Format + ( + -- * Parsing and Printing + -- ** Format strings + TimeFormatElem(..) + , TimeFormatFct(..) + , TimeFormatString(..) + , TimeFormat(..) + -- ** Common built-in formats + , ISO8601_Date(..) + , ISO8601_DateAndTime(..) + -- ** Format methods + , timePrint + , timeParse + , timeParseE + ) where + +import Data.Hourglass.Types +import Data.Hourglass.Time +import Data.Hourglass.Calendar +import Data.Hourglass.Local +import Data.Hourglass.Utils +import Data.Char (isDigit) + +-- | All the various formatter that can be part +-- of a time format string +data TimeFormatElem = + Format_Year2 -- ^ 2 digit years (70 is 1970, 69 is 2069) + | Format_Year4 -- ^ 4 digits years + | Format_Year -- ^ any digits years + | Format_Month -- ^ months (1 to 12) + | Format_Month2 -- ^ months padded to 2 chars (01 to 12) + | Format_MonthName_Short -- ^ name of the month short ('Jan', 'Feb' ..) + | Format_DayYear -- ^ day of the year (1 to 365, 366 for leap years) + | Format_Day -- ^ day of the month (1 to 31) + | Format_Day2 -- ^ day of the month (01 to 31) + | Format_Hour -- ^ hours (0 to 23) + | Format_Minute -- ^ minutes (0 to 59) + | Format_Second -- ^ seconds (0 to 59, 60 for leap seconds) + | Format_UnixSecond -- ^ number of seconds since 1 jan 1970. unix epoch. + {- + | Format_MilliSecond + | Format_MicroSecond + | Format_NanoSecond -} + | Format_TimezoneName -- ^ timezone name (e.g. GMT, PST). not implemented yet + -- | Format_TimezoneOffset -- ^ timeoffset offset (+02:00) + | Format_TzHM_Colon -- ^ timeoffset offset with colon (+02:00) + | Format_TzHM -- ^ timeoffset offset (+0200) + | Format_Tz_Offset -- ^ timeoffset in minutes + | Format_Spaces -- ^ one or many space-like chars + | Format_Text Char -- ^ a verbatim char + | Format_Fct TimeFormatFct + deriving (Show,Eq) + +-- | A generic format function composed of a parser and a printer. +data TimeFormatFct = TimeFormatFct + { timeFormatFctName :: String + , timeFormatParse :: DateTime -> String -> Either String (DateTime, String) + , timeFormatPrint :: DateTime -> String + } + +instance Show TimeFormatFct where + show f = timeFormatFctName f +instance Eq TimeFormatFct where + t1 == t2 = timeFormatFctName t1 == timeFormatFctName t2 + +-- | A time format string, composed of list of 'TimeFormatElem' +newtype TimeFormatString = TimeFormatString [TimeFormatElem] + deriving (Show,Eq) + +-- | A generic class for anything that can be considered a Time Format string. +class TimeFormat format where + toFormat :: format -> TimeFormatString + +-- | ISO8601 Date format string. +-- +-- e.g. 2014-04-05 +data ISO8601_Date = ISO8601_Date + deriving (Show,Eq) + +-- | ISO8601 Date and Time format string. +-- +-- e.g. 2014-04-05T17:25:04+00:00 +-- 2014-04-05T17:25:04Z +data ISO8601_DateAndTime = ISO8601_DateAndTime + deriving (Show,Eq) + +instance TimeFormat [TimeFormatElem] where + toFormat = TimeFormatString + +instance TimeFormat TimeFormatString where + toFormat = id + +instance TimeFormat String where + toFormat = TimeFormatString . toFormatElem + where toFormatElem [] = [] + toFormatElem ('Y':'Y':'Y':'Y':r) = Format_Year4 : toFormatElem r + toFormatElem ('Y':'Y':r) = Format_Year2 : toFormatElem r + toFormatElem ('M':'M':r) = Format_Month2 : toFormatElem r + toFormatElem ('M':'o':'n':r) = Format_MonthName_Short : toFormatElem r + toFormatElem ('M':'I':r) = Format_Minute : toFormatElem r + toFormatElem ('M':r) = Format_Month : toFormatElem r + toFormatElem ('D':'D':r) = Format_Day2 : toFormatElem r + toFormatElem ('H':r) = Format_Hour : toFormatElem r + toFormatElem ('S':r) = Format_Second : toFormatElem r + ----------------------------------------------------------- + toFormatElem ('E':'P':'O':'C':'H':r) = Format_UnixSecond : toFormatElem r + ----------------------------------------------------------- + toFormatElem ('T':'Z':'H':'M':r) = Format_TzHM : toFormatElem r + toFormatElem ('T':'Z':'H':':':'M':r) = Format_TzHM_Colon : toFormatElem r + toFormatElem ('T':'Z':'O':'F':'S':r) = Format_Tz_Offset : toFormatElem r + ----------------------------------------------------------- + toFormatElem ('\\':c:r) = Format_Text c : toFormatElem r + toFormatElem (' ':r) = Format_Spaces : toFormatElem r + toFormatElem (c:r) = Format_Text c : toFormatElem r + +instance TimeFormat ISO8601_Date where + toFormat _ = TimeFormatString [Format_Year,dash,Format_Month2,dash,Format_Day2] + where dash = Format_Text '-' + +instance TimeFormat ISO8601_DateAndTime where + toFormat _ = TimeFormatString + [Format_Year,dash,Format_Month2,dash,Format_Day2 -- date + ,Format_Text 'T' + ,Format_Hour,colon,Format_Minute,colon,Format_Second -- time + ,Format_TzHM_Colon -- timezone offset with colon +HH:MM + ] + where dash = Format_Text '-' + colon = Format_Text ':' + +-- | Pretty print time to a string. +-- +-- The actual output is determined by the format used. +timePrint :: (TimeFormat format, Timeable t) + => format -- ^ the format to use for printing + -> t -- ^ the time to print + -> String -- ^ the resulting string +timePrint fmt t = concatMap fmtToString fmtElems + where fmtToString Format_Year = show (dateYear date) + fmtToString Format_Year4 = pad4 (dateYear date) + fmtToString Format_Year2 = pad2 (dateYear date-1900) + fmtToString Format_Month2 = pad2 (fromEnum (dateMonth date)+1) + fmtToString Format_Month = show (fromEnum (dateMonth date)+1) + fmtToString Format_MonthName_Short = take 3 $ show (dateMonth date) + fmtToString Format_Day2 = pad2 (dateDay date) + fmtToString Format_Day = show (dateDay date) + fmtToString Format_Hour = pad2 (todHour tm) + fmtToString Format_Minute = pad2 (todMin tm) + fmtToString Format_Second = pad2 (todSec tm) + fmtToString Format_UnixSecond = show unixSecs + fmtToString Format_TimezoneName = "" -- + fmtToString Format_Tz_Offset = show tz + fmtToString Format_TzHM = show tzOfs + fmtToString Format_TzHM_Colon = + let (tzH, tzM) = abs tz `divMod` 60 + sign = if tz < 0 then "-" else "+" + in sign ++ pad2 tzH ++ ":" ++ pad2 tzM + fmtToString Format_Spaces = " " + fmtToString (Format_Text c) = [c] + fmtToString f = error ("implemented printing format: " ++ show f) + + (TimeFormatString fmtElems) = toFormat fmt + + (Elapsed (Seconds unixSecs)) = timeGetElapsed t + (DateTime date tm) = timeGetDateTimeOfDay t + tzOfs@(TimezoneOffset tz) = maybe (TimezoneOffset 0) id $ timeGetTimezone t + + -- format a number to 4 stricly + --pad4t v = pad4 (v `mod` 10000) + +-- | Try parsing a string as time using the format explicitely specified +-- +-- On failure, the parsing function returns the reason of the failure. +-- If parsing is successful, return the date parsed with the remaining unparsed string +timeParseE :: TimeFormat format + => format -- ^ the format to use for parsing + -> String -- ^ the string to parse + -> Either (TimeFormatElem, String) (LocalTime DateTime, String) +timeParseE fmt timeString = loop ini fmtElems timeString + where (TimeFormatString fmtElems) = toFormat fmt + + loop acc [] s = Right (acc, s) + loop _ (x:_) [] = Left (x, "empty") + loop acc (x:xs) s = + case processOne acc x s of + Left err -> Left (x, err) + Right (nacc, s') -> loop nacc xs s' + + processOne _ _ [] = Left "empty" + processOne acc (Format_Text c) (x:xs) + | c == x = Right (acc, xs) + | otherwise = Left ("unexpected char, got: " ++ show c) + + processOne acc Format_Year s = + onSuccess (\y -> modDate (setYear y) acc) $ isNumber s + processOne acc Format_Year4 s = + onSuccess (\y -> modDate (setYear y) acc) $ is4Digit s + processOne acc Format_Year2 s = onSuccess + (\y -> let year = if y < 70 then y + 2000 else y + 1900 in modDate (setYear year) acc) + $ is2Digit s + processOne acc Format_Month2 s = + onSuccess (\m -> modDate (setMonth $ toEnum ((m - 1) `mod` 12)) acc) $ is2Digit s + processOne acc Format_Day2 s = + onSuccess (\d -> modDate (setDay d) acc) $ is2Digit s + processOne acc Format_Hour s = + onSuccess (\h -> modTime (setHour h) acc) $ is2Digit s + processOne acc Format_Minute s = + onSuccess (\mi -> modTime (setMin mi) acc) $ is2Digit s + processOne acc Format_Second s = + onSuccess (\sec -> modTime (setSec sec) acc) $ is2Digit s + processOne acc Format_UnixSecond s = + onSuccess (\sec -> + let newDate = dateTimeFromUnixEpochP $ flip ElapsedP 0 $ Elapsed $ Seconds sec + in modDT (const newDate) acc) $ isNumber s + processOne acc Format_TzHM_Colon (c:s) = + parseHMSign True acc c s + processOne acc Format_TzHM (c:s) = + parseHMSign False acc c s + + -- catch all for unimplemented format. + processOne _ f _ = error ("unimplemened parsing format: " ++ show f) + + parseHMSign expectColon acc signChar afterSign = + case signChar of + '+' -> parseHM False expectColon afterSign acc + '-' -> parseHM True expectColon afterSign acc + _ -> parseHM False expectColon (signChar:afterSign) acc + + parseHM isNeg True (h1:h2:':':m1:m2:xs) acc + | allDigits [h1,h2,m1,m2] = let tz = toTZ isNeg h1 h2 m1 m2 + in Right (modTZ (const tz) acc, xs) + | otherwise = Left ("not digits chars: " ++ show [h1,h2,m1,m2]) + parseHM isNeg False (h1:h2:m1:m2:xs) acc + | allDigits [h1,h2,m1,m2] = let tz = toTZ isNeg h1 h2 m1 m2 + in Right (modTZ (const tz) acc, xs) + | otherwise = Left ("not digits chars: " ++ show [h1,h2,m1,m2]) + parseHM _ _ _ _ = Left ("invalid timezone format") + + toTZ isNeg h1 h2 m1 m2 = TimezoneOffset ((if isNeg then negate else id) minutes) + where minutes = (read [h1,h2] * 60) + read [m1,m2] + + onSuccess f (Right (v, s')) = Right (f v, s') + onSuccess _ (Left s) = Left s + + is4Digit (a:b:c:d:s) + | allDigits [a,b,c,d] = Right (read (a:b:c:d:[]), s) + | otherwise = Left ("not digits chars: " ++ show [a,b,c,d]) + is4Digit _ = Left ("not enough chars") + + is2Digit (a:b:s) + | isDigit a && isDigit b = Right (read (a:b:[]), s) + | otherwise = Left ("not digits chars: " ++ show [a,b]) + is2Digit _ = Left ("not enough chars") + + isNumber :: (Read a, Num a) => String -> Either String (a, String) + isNumber s = + case span isDigit s of + ("",s2) -> Left ("no digits chars:" ++ s2) + (s1,s2) -> Right (read s1, s2) + + allDigits = and . map isDigit + + ini = LocalTime (DateTime (Date 0 (toEnum 0) 0) (TimeOfDay 0 0 0 0)) (TimezoneOffset 0) + + modDT f (LocalTime dt tz) = LocalTime (f dt) tz + modDate f (LocalTime (DateTime d tp) tz) = LocalTime (DateTime (f d) tp) tz + modTime f (LocalTime (DateTime d tp) tz) = LocalTime (DateTime d (f tp)) tz + modTZ f (LocalTime dtp tz) = LocalTime dtp (f tz) + + setYear y (Date _ m d) = Date y m d + setMonth m (Date y _ d) = Date y m d + setDay d (Date y m _) = Date y m d + setHour h (TimeOfDay _ m s ns) = TimeOfDay h m s ns + setMin m (TimeOfDay h _ s ns) = TimeOfDay h m s ns + setSec s (TimeOfDay h m _ ns) = TimeOfDay h m s ns + +-- | Try parsing a string as time using the format explicitely specified +-- +-- The error handling is simplified in this case, for more elaborate need +-- use 'timeParseE'. +timeParse :: TimeFormat format + => format -- ^ the format to use for parsing + -> String -- ^ the string to parse + -> Maybe (LocalTime DateTime) +timeParse fmt s = either (const Nothing) (Just . fst) $ timeParseE fmt s diff --git a/Data/Hourglass/Internal.hs b/Data/Hourglass/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Internal.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Data.Hourglass.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- System lowlevel functions +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} + +module Data.Hourglass.Internal + ( dateTimeFromUnixEpochP + , dateTimeFromUnixEpoch + , systemGetTimezone + , systemGetElapsed + , systemGetElapsedP + ) where + +#ifdef WINDOWS +import Data.Hourglass.Internal.Win +#else +import Data.Hourglass.Internal.Unix +#endif diff --git a/Data/Hourglass/Internal/Unix.hs b/Data/Hourglass/Internal/Unix.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Internal/Unix.hs @@ -0,0 +1,150 @@ +-- | +-- Module : Data.Hourglass.Internal.Unix +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Time lowlevel helpers for the unix operating system +-- +-- depend on localtime_r and gmtime_r. +-- Some obscure unix system might not support them. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +module Data.Hourglass.Internal.Unix + ( dateTimeFromUnixEpochP + , dateTimeFromUnixEpoch + , systemGetTimezone + , systemGetElapsed + , systemGetElapsedP + ) where + +import Control.Applicative +import Foreign.C.Types +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Data.Hourglass.Types +import System.IO.Unsafe + +-- | convert a unix epoch precise to DateTime +dateTimeFromUnixEpochP :: ElapsedP -> DateTime +dateTimeFromUnixEpochP (ElapsedP e ns) = fromCP ns $ rawGmTime e + +-- | convert a unix epoch to DateTime +dateTimeFromUnixEpoch :: Elapsed -> DateTime +dateTimeFromUnixEpoch e = fromC $ rawGmTime e + +-- | return the timezone offset in minutes +systemGetTimezone :: IO TimezoneOffset +systemGetTimezone = TimezoneOffset . fromIntegral . flip div 60 <$> localTime 0 + +---------------------------------------------------------------------------------------- +-- | return the current elapsedP +systemGetElapsedP :: IO ElapsedP +systemGetElapsedP = allocaBytesAligned sofTimespec 8 $ \ptr -> do + c_clock_get ptr + toElapsedP <$> peek (castPtr ptr) <*> peekByteOff (castPtr ptr) sofCTime + where sofTimespec = sofCTime + sofCLong + sofCTime = sizeOf (0 :: CTime) + sofCLong = sizeOf (0 :: CLong) + toElapsedP :: CTime -> CLong -> ElapsedP + toElapsedP (CTime sec) nsec = ElapsedP (Elapsed $ Seconds (fromIntegral sec)) (fromIntegral nsec) + +-- | return the current elapsed +systemGetElapsed :: IO Elapsed +systemGetElapsed = allocaBytesAligned sofTimespec 8 $ \ptr -> do + c_clock_get ptr + toElapsed <$> peek (castPtr ptr) + where sofTimespec = sizeOf (0 :: CTime) + sizeOf (0 :: CLong) + toElapsed :: CTime -> Elapsed + toElapsed (CTime sec) = Elapsed $ Seconds (fromIntegral sec) + +foreign import ccall unsafe "hourglass_clock_calendar" + c_clock_get :: Ptr CLong -> IO () + +foreign import ccall unsafe "gmtime_r" + c_gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) + +foreign import ccall unsafe "localtime_r" + c_localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) + +-- | Return a global time's struct tm based on the number of elapsed second since unix epoch. +rawGmTime :: Elapsed -> CTm +rawGmTime (Elapsed (Seconds s)) = unsafePerformIO callTime + where callTime = + alloca $ \ctmPtr -> do + alloca $ \ctimePtr -> do + poke ctimePtr ctime + r <- c_gmtime_r ctimePtr ctmPtr + if r == nullPtr + then error "gmTime failed" + else peek ctmPtr + ctime = fromIntegral s +{-# NOINLINE rawGmTime #-} + +-- | Return a local time's gmtoff (seconds east of UTC) +-- +-- use the ill defined gmtoff (at offset 40) that might or might not be +-- available for your platform. worst case scenario it's not initialized +-- properly. +localTime :: Elapsed -> IO CLong +localTime (Elapsed (Seconds s)) = callTime + where callTime = + alloca $ \ctmPtr -> do + alloca $ \ctimePtr -> do + poke ctimePtr ctime + r <- c_localtime_r ctimePtr ctmPtr + if r == nullPtr + then error "localTime failed" + else peekByteOff ctmPtr 40 + ctime = fromIntegral s + +-- | Represent the beginning of struct tm +data CTm = CTm + { ctmSec :: CInt + , ctmMin :: CInt + , ctmHour :: CInt + , ctmMDay :: CInt + , ctmMon :: CInt + , ctmYear :: CInt + } deriving (Show,Eq) + +-- | Convert a C structure to a DateTime structure +fromC :: CTm -> DateTime +fromC ctm = DateTime date time + where date = Date + { dateYear = fromIntegral $ ctmYear ctm + 1900 + , dateMonth = toEnum $ fromIntegral $ ctmMon ctm + , dateDay = fromIntegral $ ctmMDay ctm + } + time = TimeOfDay + { todHour = fromIntegral $ ctmHour ctm + , todMin = fromIntegral $ ctmMin ctm + , todSec = fromIntegral $ ctmSec ctm + , todNSec = 0 + } + +-- | Similar to 'fromC' except with nanosecond precision +fromCP :: NanoSeconds -> CTm -> DateTime +fromCP ns ctm = DateTime d (t { todNSec = ns }) + where (DateTime d t) = fromC ctm + +instance Storable CTm where + alignment _ = 8 + sizeOf _ = 60 -- account for 9 ints, alignment + 2 unsigned long at end. + peek ptr = do + CTm <$> peekByteOff intPtr 0 + <*> peekByteOff intPtr 4 + <*> peekByteOff intPtr 8 + <*> peekByteOff intPtr 12 + <*> peekByteOff intPtr 16 + <*> peekByteOff intPtr 20 + where intPtr = castPtr ptr + poke ptr (CTm f0 f1 f2 f3 f4 f5) = do + mapM_ (uncurry (pokeByteOff intPtr)) + [(0,f0), (4,f1), (8,f2), (12,f3), (16,f4), (20,f5)] + --pokeByteOff (castPtr ptr) 36 f9 + where intPtr = castPtr ptr diff --git a/Data/Hourglass/Internal/Win.hs b/Data/Hourglass/Internal/Win.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Internal/Win.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Data.Hourglass.Internal.Win +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Time lowlevel helpers binding to Windows +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Data.Hourglass.Internal.Win + ( dateTimeFromUnixEpochP + , dateTimeFromUnixEpoch + , systemGetTimezone + , systemGetElapsed + , systemGetElapsedP + ) where + +import System.IO.Unsafe +import System.Win32.Time +import Data.Hourglass.Types +import Data.Int (Int64) + +unixDiff :: Int64 +unixDiff = 11644473600 + +toFileTime :: Elapsed -> FILETIME +toFileTime (Elapsed (Seconds s)) = FILETIME val + where val = fromIntegral (s + unixDiff) * 10000000 + +toElapsedP :: FILETIME -> ElapsedP +toElapsedP (FILETIME w) = ElapsedP (Elapsed $ Seconds s) (NanoSeconds ns) + where (sWin, hundredNs) = w `divMod` 10000000 + ns = fromIntegral (hundredNs * 100) + s = fromIntegral sWin - unixDiff + +toElapsed :: FILETIME -> Elapsed +toElapsed (FILETIME w) = Elapsed (Seconds s) + where s = fromIntegral (fst (w `divMod` 10000000)) - unixDiff + +callSystemTime :: Elapsed -> SYSTEMTIME +callSystemTime e = unsafePerformIO (fileTimeToSystemTime (toFileTime e)) +{-# NOINLINE callSystemTime #-} + +dateTimeFromUnixEpochP :: ElapsedP -> DateTime +dateTimeFromUnixEpochP (ElapsedP e ns) = toDateTime $ callSystemTime e + where toDateTime (SYSTEMTIME wY wM _ wD wH wMin wS _) = + DateTime (Date (fi wY) (toEnum $ fi $ wM - 1) (fi wD)) + (TimeOfDay (fi wH) (fi wMin) (fi wS) ns) + fi = fromIntegral + +dateTimeFromUnixEpoch :: Elapsed -> DateTime +dateTimeFromUnixEpoch e = toDateTime $ callSystemTime e + where toDateTime (SYSTEMTIME wY wM _ wD wH wMin wS _) = + DateTime (Date (fi wY) (toEnum $ fi $ wM - 1) (fi wD)) + (TimeOfDay (fi wH) (fi wMin) (fi wS) 0) + fi = fromIntegral + +systemGetTimezone :: IO TimezoneOffset +systemGetTimezone = do + (_,tzInfo) <- getTimeZoneInformation + return $ TimezoneOffset $ getTzOffset tzInfo + where getTzOffset tzInfo = fromIntegral (tziBias tzInfo - tziDaylightBias tzInfo) + +systemGetElapsedP :: IO ElapsedP +systemGetElapsedP = toElapsedP `fmap` getSystemTimeAsFileTime + +systemGetElapsed :: IO Elapsed +systemGetElapsed = toElapsed `fmap` getSystemTimeAsFileTime diff --git a/Data/Hourglass/Local.hs b/Data/Hourglass/Local.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Local.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : Data.Hourglass.Local +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Local time = global time + timezone +-- +module Data.Hourglass.Local + ( + -- * Local time + -- ** Local time type + LocalTime(..) + -- ** Local time creation and manipulation + , localTime + , localTimeToGlobal + , localTimeSetTimezone + , localTimeConvert + ) where + +import Data.Hourglass.Types +import Data.Hourglass.Time +import Data.Hourglass.Diff + +-- | Local time representation +-- +-- this is a loca time representation augmented by a timezone +-- to get back to a global time, the timezoneOffset needed to be added to the local time. +data LocalTime t = LocalTime + { localTimeUnwrap :: t -- ^ unwrap the LocalTime value. the time value is local. + , localTimeGetTimezone :: TimezoneOffset -- ^ get the timezone associated with LocalTime + } + +-- FIXME add instance Read too. + +instance Show t => Show (LocalTime t) where + show (LocalTime t tz) = show t ++ show tz +instance Eq t => Eq (LocalTime t) where + LocalTime t1 tz1 == LocalTime t2 tz2 = tz1 == tz2 && t1 == t2 + +instance (Ord t, Time t) => Ord (LocalTime t) where + compare l1@(LocalTime g1 tz1) l2@(LocalTime g2 tz2) = + case compare tz1 tz2 of + EQ -> compare g1 g2 + _ -> let t1 = localTimeToGlobal l1 + t2 = localTimeToGlobal l2 + in compare t1 t2 + +instance Functor LocalTime where + fmap f (LocalTime t tz) = LocalTime (f t) tz + +instance Time t => Timeable (LocalTime t) where + timeGetElapsedP (LocalTime t _) = timeGetElapsedP t + timeGetElapsed (LocalTime t _) = timeGetElapsed t + timeGetTimezone (LocalTime _ tz) = Just tz + timeGetNanoSeconds (LocalTime t _) = timeGetNanoSeconds t + +-- | Create a local time type from a timezone and a time type. +-- +-- the time value is converted to represent local time +localTime :: Time t => TimezoneOffset -> t -> LocalTime t +localTime tz t = LocalTime (timeConvert t') tz + where currentTz = maybe (TimezoneOffset 0) id $ timeGetTimezone t + t' = elapsedTimeAddSecondsP (timeGetElapsedP t) diffTz + diffTz = timezoneOffsetToSeconds tz - timezoneOffsetToSeconds currentTz + +-- | Get back a global time value +localTimeToGlobal :: Time t => LocalTime t -> t +localTimeToGlobal (LocalTime local tz) = timeConvert $ elapsedTimeAddSecondsP (timeGetElapsedP local) tzSecs + where tzSecs = negate $ timezoneOffsetToSeconds tz + +-- | Change the timezone, and adjust the local value to represent the new local value. +localTimeSetTimezone :: Time t => TimezoneOffset -> LocalTime t -> LocalTime t +localTimeSetTimezone tz currentLocal@(LocalTime t currentTz) + | diffTz == 0 = currentLocal + | otherwise = LocalTime (timeConvert t') tz + where t' = elapsedTimeAddSecondsP (timeGetElapsedP t) diffTz + diffTz = timezoneOffsetToSeconds tz - timezoneOffsetToSeconds currentTz + +-- | convert the local time representation to another time representation determined by context. +localTimeConvert :: (Time t1, Time t2) => LocalTime t1 -> LocalTime t2 +localTimeConvert = fmap timeConvert diff --git a/Data/Hourglass/Time.hs b/Data/Hourglass/Time.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Time.hs @@ -0,0 +1,198 @@ +-- | +-- Module : Data.Hourglass.Time +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- generic time representation interface to allow +-- arbitrary conversion between different time representation +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +module Data.Hourglass.Time + ( + -- * Generic time classes + Time(..) + , Timeable(..) + + -- * Elapsed time + , Elapsed(..) + , ElapsedP(..) + + -- * Generic conversion + , timeConvert + + -- * Date and Time + , timeGetDate + , timeGetDateTimeOfDay + , timeGetTimeOfDay + + -- * Arithmetic + , TimeDiff(..) + , timeAdd + , timeDiff + , timeDiffP + ) where + +import Data.Data () +import Data.Hourglass.Types +import Data.Hourglass.Calendar +import Data.Hourglass.Diff +import Foreign.C.Types (CTime(..)) + +-- | Timeable represent every type that can be made to look like time types. +-- +-- * can be converted to ElapsedP and Elapsed +-- +-- * optionally have a timezone associated +-- +-- * have nanoseconds accessor (which can return 0 when the type is not more precise than seconds) +-- +class Timeable t where + -- | convert a time representation to the number of elapsed seconds and nanoseconds to a specific epoch + timeGetElapsedP :: t -> ElapsedP + + -- | convert a time representation to the number of elapsed seconds to a specific epoch. + -- + -- defaults to timeGetElapsedP unless defined explicitely by an instance + timeGetElapsed :: t -> Elapsed + timeGetElapsed t = e where ElapsedP e _ = timeGetElapsedP t + + -- | return the number of optional nanoseconds. + -- + -- If the underlaying type is not precise enough to record nanoseconds + -- (or any variant between seconds and nanoseconds), 0 should be returned + -- + -- defaults to 'timeGetElapsedP' unless defined explicitely by an instance, + -- for efficiency reason, it's a good idea to override this methods if + -- you know the type is not more precise than Seconds. + timeGetNanoSeconds :: t -> NanoSeconds + timeGetNanoSeconds t = ns where ElapsedP _ ns = timeGetElapsedP t + + -- | return the time zone offset in minute. + -- + -- If the time is not a local time representation (offseted by timezone), + -- then Nothing should be returned. + timeGetTimezone :: t -> Maybe TimezoneOffset + timeGetTimezone _ = Nothing + +-- | Represent time types that can be created from other time types. +-- +-- Every conversion happens throught ElapsedP or Elapsed types. +class Timeable t => Time t where + -- | convert from a number of elapsed seconds and nanoseconds to another time representation + timeFromElapsedP :: ElapsedP -> t + + -- | convert from a number of elapsed seconds and nanoseconds to another time representation + -- + -- defaults to timeFromElapsedP unless defined explicitely by an instance. + timeFromElapsed :: Elapsed -> t + timeFromElapsed e = timeFromElapsedP (ElapsedP e 0) + +instance Timeable CTime where + timeGetElapsedP c = ElapsedP (timeGetElapsed c) 0 + timeGetElapsed (CTime c) = Elapsed (Seconds $ fromIntegral c) + timeGetNanoSeconds _ = 0 +instance Time CTime where + timeFromElapsedP (ElapsedP e _) = timeFromElapsed e + timeFromElapsed (Elapsed (Seconds c)) = CTime (fromIntegral c) + +instance Timeable Elapsed where + timeGetElapsedP e = ElapsedP e 0 + timeGetElapsed e = e + timeGetNanoSeconds _ = 0 +instance Time Elapsed where + timeFromElapsedP (ElapsedP e _) = e + timeFromElapsed e = e + +instance Timeable ElapsedP where + timeGetElapsedP e = e + timeGetNanoSeconds (ElapsedP _ ns) = ns +instance Time ElapsedP where + timeFromElapsedP e = e + +instance Timeable Date where + timeGetElapsedP d = timeGetElapsedP (DateTime d (TimeOfDay 0 0 0 0)) +instance Time Date where + timeFromElapsedP (ElapsedP elapsed _) = d + where (DateTime d _) = dateTimeFromUnixEpoch elapsed + +instance Timeable DateTime where + timeGetElapsedP d = ElapsedP (dateTimeToUnixEpoch d) (timeGetNanoSeconds d) + timeGetElapsed d = dateTimeToUnixEpoch d + timeGetNanoSeconds (DateTime _ (TimeOfDay _ _ _ ns)) = ns +instance Time DateTime where + timeFromElapsedP elapsed = dateTimeFromUnixEpochP elapsed + +-- | Convert one time representation into another one +-- +-- The return type need to be infer by the context. +-- +-- If the context cannot be infer through this, some specialized functions +-- are available for built-in types: +-- +-- * 'timeGetDate' +-- +-- * 'timeGetDateTimeOfDay' +-- +-- * 'timeGetElapsed', 'timeGetElapsedP' +timeConvert :: (Timeable t1, Time t2) => t1 -> t2 +timeConvert t1 = timeFromElapsedP (timeGetElapsedP t1) + +{-# RULES "timeConvert/ID" timeConvert = id #-} +{-# RULES "timeConvert/ElapsedP" timeConvert = timeGetElapsedP #-} +{-# RULES "timeConvert/Elapsed" timeConvert = timeGetElapsed #-} + +-- | Get the calendar Date (year-month-day) from a time representation +-- +-- specialization of 'timeConvert' +timeGetDate :: Timeable t => t -> Date +timeGetDate t = d where (DateTime d _) = timeGetDateTimeOfDay t + +{-# RULES "timeGetDate/ID" timeGetDate = id #-} +{-# RULES "timeGetDate/DateTime" timeGetDate = dtDate #-} + +-- | Get the day time (hours:minutes:seconds) from a time representation +-- +-- specialization of 'timeConvert' +timeGetTimeOfDay :: Timeable t => t -> TimeOfDay +timeGetTimeOfDay t = tod where (DateTime _ tod) = timeGetDateTimeOfDay t + +{-# RULES "timeGetTimeOfDay/Date" timeGetTimeOfDay = const (TimeOfDay 0 0 0 0) #-} +{-# RULES "timeGetTimeOfDay/DateTime" timeGetTimeOfDay = dtTime #-} + +-- | Get the date and time of day from a time representation +-- +-- specialization of 'timeConvert' +timeGetDateTimeOfDay :: Timeable t => t -> DateTime +timeGetDateTimeOfDay t = dateTimeFromUnixEpochP $ timeGetElapsedP t + +{-# RULES "timeGetDateTimeOfDay/ID" timeGetDateTimeOfDay = id #-} +{-# RULES "timeGetDateTimeOfDay/Date" timeGetDateTimeOfDay = flip DateTime (TimeOfDay 0 0 0 0) #-} + +-- | add some values with time units to a time representation and returns this new time representation +-- +-- example: +-- +-- > t1 `timeAdd` mempty { timeDiffHours = 12 } +timeAdd :: Time t => t -> TimeDiff -> t +timeAdd t td = timeFromElapsedP $ elapsedTimeAddP (timeGetElapsedP t) td + +-- | Get the difference in seconds between two time representation +-- +-- effectively: +-- +-- > t2 `timeDiff` t1 = t2 - t1 +timeDiff :: (Timeable t1, Timeable t2) => t1 -> t2 -> Seconds +timeDiff t1 t2 = sec where (Elapsed sec) = timeGetElapsed t1 - timeGetElapsed t2 + +-- | Get the difference in seconds and nanoseconds between two time representation +-- +-- effectively: +-- +-- > @t2 `timeDiffP` t1 = t2 - t1 +timeDiffP :: (Timeable t1, Timeable t2) => t1 -> t2 -> (Seconds, NanoSeconds) +timeDiffP t1 t2 = (sec, ns) + where (ElapsedP (Elapsed sec) ns) = timeGetElapsedP t1 - timeGetElapsedP t2 diff --git a/Data/Hourglass/Types.hs b/Data/Hourglass/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Types.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Data.Hourglass.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- +-- Basic times units and types. +-- +-- While pratically some units could hold infinite values, for practical +-- and efficient purpose they are limited to int64 types for seconds +-- and int types for years. +-- +-- Most units use the unix epoch referential, but by no means reduce portability. +-- the unix referencial works under the Windows platform or any other platforms. +-- +module Data.Hourglass.Types + ( + -- * Time units + NanoSeconds(..) + , Seconds(..) + -- * Time enumeration + , Month(..) + , WeekDay(..) + -- * Timezone + , TimezoneOffset(..) + , timezoneOffsetToSeconds + -- * Computer friendly format + -- ** Unix elapsed + , Elapsed(..) + , ElapsedP(..) + -- * Human friendly format + -- ** Calendar time + , Date(..) + , TimeOfDay(..) + , DateTime(..) + ) where + +import Data.Int +import Data.Data +import Data.Ratio +import Control.DeepSeq +import Data.Hourglass.Utils (pad2) + +-- | Nanoseconds +newtype NanoSeconds = NanoSeconds Int + deriving (Read,Eq,Ord,Num,Data,Typeable,NFData) + +instance Show NanoSeconds where + show (NanoSeconds v) = shows v "ns" + +-- | Number of seconds without a referencial. +-- +-- Can hold a number between [-2^63,2^63-1], which should +-- be good for some billions of years. +-- +-- However, because of limitation in the calendar conversion +-- currently used, seconds should be in the range [-2^55,2^55-1], +-- which is good for only 1 billion of year. +newtype Seconds = Seconds Int64 + deriving (Read,Eq,Ord,Num,Data,Typeable,NFData) + +instance Show Seconds where + show (Seconds s) = shows s "s" + +-- | A number of seconds elapsed since the unix epoch. +newtype Elapsed = Elapsed Seconds + deriving (Read,Eq,Ord,Num,Data,Typeable,NFData) + +instance Show Elapsed where + show (Elapsed s) = show s + +-- | A number of seconds and nanoseconds elapsed since the unix epoch. +data ElapsedP = ElapsedP {-# UNPACK #-} !Elapsed {-# UNPACK #-} !NanoSeconds + deriving (Read,Eq,Ord,Data,Typeable) + +instance Show ElapsedP where + show (ElapsedP e ns) = shows e ('.' : show ns) + +instance NFData ElapsedP where rnf e = e `seq` () + +instance Num ElapsedP where + (ElapsedP e1 ns1) + (ElapsedP e2 ns2) = ElapsedP (e1+e2) (ns1+ns2) + (ElapsedP e1 ns1) - (ElapsedP e2 ns2) = ElapsedP (e1-e2) (ns1-ns2) + (ElapsedP e1 ns1) * (ElapsedP e2 ns2) = ElapsedP (e1*e2) (ns1*ns2) + negate (ElapsedP e ns) = ElapsedP (negate e) ns + abs (ElapsedP e ns) = ElapsedP (abs e) ns + signum (ElapsedP e ns) = ElapsedP (signum e) ns + fromInteger i = ElapsedP (Elapsed (fromIntegral i)) 0 + +instance Real ElapsedP where + -- FIXME + toRational (ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns)) = + fromIntegral s + (1000000000 % fromIntegral ns) + +-- | Month of the year +data Month = + January + | February + | March + | April + | May + | June + | July + | August + | September + | October + | November + | December + deriving (Show,Eq,Ord,Enum,Data,Typeable) + +-- | Day of the week +-- +-- the enumeration starts on Sunday. +data WeekDay = + Sunday + | Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + deriving (Show,Read,Eq,Ord,Enum,Data,Typeable) + +-- | Offset against UTC in minutes +-- +-- * a positive number represent a location East of UTC. +-- +-- * a negative number represent a location West of UTC. +-- +-- LocalTime t (-300) = t represent a time at UTC-5 +-- LocalTime t (+480) = t represent a time at UTC+8 +-- +newtype TimezoneOffset = TimezoneOffset + { timezoneOffsetToMinutes :: Int -- ^ return the number of minutes + } deriving (Eq,Ord,Data,Typeable) + +-- | Return the number of seconds associated with a timezone +timezoneOffsetToSeconds :: TimezoneOffset -> Seconds +timezoneOffsetToSeconds (TimezoneOffset ofs) = Seconds (fromIntegral ofs * 60) + +instance Show TimezoneOffset where + show (TimezoneOffset tz) = + concat [(if tz < 0 then "-" else "+"), pad2 tzH, pad2 tzM] + where (tzH, tzM) = abs tz `divMod` 60 + +-- | human date representation using common calendar +data Date = Date + { dateYear :: {-# UNPACK #-} !Int -- ^ year (Common Era) + , dateMonth :: !Month -- ^ month of the year + , dateDay :: {-# UNPACK #-} !Int -- ^ day of the month, between 1 to 31 + } deriving (Show,Eq,Ord,Data,Typeable) + +instance NFData Date where + rnf (Date y m d) = y `seq` m `seq` d `seq` () + +-- | human time representation of hour, minutes, seconds in a day. +data TimeOfDay = TimeOfDay + { todHour :: {-# UNPACK #-} !Int -- ^ hours, between 0 and 23 + , todMin :: {-# UNPACK #-} !Int -- ^ minutes, between 0 and 59 + , todSec :: {-# UNPACK #-} !Int -- ^ seconds, between 0 and 59. 60 when having leap second */ + , todNSec :: {-# UNPACK #-} !NanoSeconds -- ^ nanoseconds, between 0 and 999999999 */ + } deriving (Show,Eq,Ord,Data,Typeable) + +instance NFData TimeOfDay where + rnf (TimeOfDay h m s ns) = h `seq` m `seq` s `seq` ns `seq` () + +-- | Date and Time +data DateTime = DateTime + { dtDate :: Date + , dtTime :: TimeOfDay + } deriving (Show,Eq,Ord,Data,Typeable) + +instance NFData DateTime where + rnf (DateTime d t) = rnf d `seq` rnf t `seq` () diff --git a/Data/Hourglass/Utils.hs b/Data/Hourglass/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Utils.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Data.Hourglass.Utils +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- some padding / formatting functions +-- +module Data.Hourglass.Utils where + +-- | pad a number to 2 digits +pad2 :: (Show a, Ord a, Num a, Integral a) => a -> String +pad2 v | v >= 100 = pad2 (v `mod` 100) + | v >= 10 = show v + | otherwise = '0' : show v + +-- | pad a number to 4 digits +pad4 :: (Show a, Ord a, Num a, Integral a) => a -> String +pad4 v | v >= 1000 = show v + | v >= 100 = '0' : show v + | v >= 10 = '0':'0' : show v + | otherwise = '0':'0':'0': show v diff --git a/Data/Hourglass/Zone.hs b/Data/Hourglass/Zone.hs new file mode 100644 --- /dev/null +++ b/Data/Hourglass/Zone.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Data.Hourglass.Zone +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Timezone utility +-- +{-# LANGUAGE ExistentialQuantification #-} +module Data.Hourglass.Zone + ( Timezone(..) + , UTC(..) + , TimezoneMinutes(..) + ) where + +-- | standard representation for timezone +class Timezone tz where + -- | offset in minutes from UTC. valid values should be between -12*60 to +14*60 + timezoneOffset :: tz -> Int + -- | the name of the timezone. by default will be +-HH:MM encoding. + timezoneName :: tz -> String + timezoneName = tzMinutesPrint . timezoneOffset + +-- | Simple timezone containing the number of minutes difference +-- with UTC. +-- +-- Valid values should be between -12*60 to +14*60 +newtype TimezoneMinutes = TimezoneMinutes Int + deriving (Show,Eq,Ord) + +-- | Universal Time Coordinated. The generic computer "timezone". +data UTC = UTC + deriving (Show,Eq,Ord) + +instance Timezone UTC where + timezoneOffset _ = 0 + timezoneName _ = "UTC" + +instance Timezone TimezoneMinutes where + timezoneOffset (TimezoneMinutes minutes) = minutes + +-- | print a minute offset in format: +-- (+-)HH:MM +tzMinutesPrint :: Int -> String +tzMinutesPrint offset = + (if offset > 0 then '+' else '-') + : (pad0 h ++ ":" ++ pad0 m) + where (h,m) = abs offset `divMod` 60 + pad0 v + | v < 10 = ('0':show v) + | otherwise = (show v) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,74 @@ +hourglass +========= + +Hourglass is a simple time library. + +Documentation: [hourglass on hackage](http://hackage.haskell.org/package/hourglass) + +Design +------ + +One of the key design are the Timeable and Time type classes. +Time representation of the same time value are interchangeable and easy to convert +between each other. This also allow the user to define new time types that +interact with the same functions as the built-in types. + +For example: + + let dateTime0 = DateTime { dtDate = Date { dateYear = 1970, dateMonth = January, dateDay = 1 } + , dtTime = TimeOfDay {todHour = 0, todMin = 0, todSec = 0, todNSec = 0 } } + elapsed0 = Elasped 0 + + > timeGetElapsed elapsed0 == timeGetElapsed dateTime0 + True + > timeGetDate elapsed0 == timeGetDate dateTime0 + True + > timePrint "YYYY-MM" elapsed0 + "1970-01" + > timePrint "YYYY-MM" dateTime0 + "1970-01" + +Hourglass has the same limitation as your system: + +* On 32 bit linux, you can't get a date after the year 2038. +* In Windows 7, you can't get the date before the year 1601. + +Comparaison with time +--------------------- + +* getting posix time: + + ------- with time + import Data.Time.Clock.POSIX + ptime <- getPOSIXTime + + ------- with hourglass + import System.Hourglass + ptime <- getCurrentElapsed + +* getting current date year: + + ------- with time + import Data.Time.Clock + import Data.Time.Calendar + currentYear <- (\(y,_,_) -> y) . toGregorian . utcDay <$> getCurrentTime + + ------- with hourglass + import System.Hourglass + import Data.Time + currentYear <- dateYear . timeGetDate <$> getCurrentElapsed + +* creating a time representation of "4th May 1970 15:12:24" + + ------- with time + import Data.Time.Clock + import Date.Time.Calendar + + let day = fromGregorian 1970 5 4 + diffTime = secondsToDiffTime (15 * 3600 + 12 * 60 + 24) + in UTCTime day diffTime + + ------- with hourglass + import Date.Time + + DateTime (Date 1970 May 4) (TimeOfDay 15 12 24 0) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Hourglass.hs b/System/Hourglass.hs new file mode 100644 --- /dev/null +++ b/System/Hourglass.hs @@ -0,0 +1,46 @@ +-- | +-- Module : System.Hourglass +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Get the system timezone and current time value in multiple formats +-- +module System.Hourglass + ( + -- * Current time in computer friendly format + timeCurrent + , timeCurrentP + -- * Current time in human friendly DateTime format + , dateCurrent + -- * System timezone + , timezoneCurrent + ) where + +import Control.Applicative +import Data.Hourglass.Types +import Data.Hourglass.Time +import Data.Hourglass.Internal (systemGetElapsedP, systemGetElapsed, systemGetTimezone) + +-- | Get the current elapsed seconds since epoch +timeCurrent :: IO Elapsed +timeCurrent = systemGetElapsed + +-- | Get the current elapsed seconds (precise to the nanosecond) since epoch +timeCurrentP :: IO ElapsedP +timeCurrentP = systemGetElapsedP + +-- | Get the current time +-- +-- This is equivalent to: +-- +-- > timeGetDateTimeOfDay `fmap` timeCurrentP +dateCurrent :: IO DateTime +dateCurrent = timeGetDateTimeOfDay <$> timeCurrentP + +-- | Get the current timezone offset +-- +-- This include daylight saving time when in operation. +timezoneCurrent :: IO TimezoneOffset +timezoneCurrent = systemGetTimezone diff --git a/cbits/unix.c b/cbits/unix.c new file mode 100644 --- /dev/null +++ b/cbits/unix.c @@ -0,0 +1,31 @@ +/* + * lowlevel binder for macosx and + */ +#include +#ifdef __MACH__ +#include +#include +#endif + +/* on mac os X, clock_gettime doesn't exists, but + * http://stackoverflow.com/questions/5167269/clock-gettime-alternative-in-mac-os-x + * + * we ignore errors as it's very very unlikely considering the hardcoded ID + * and the fact that haskell should call this code. + */ +void hourglass_clock_calendar(struct timespec *timespec) +{ +#ifdef MACH + clock_serv_t cclock; + mach_timespec_t mts; + + host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); + clock_get_time(cclock, &mts); + mach_port_deallocate(mach_task_self(), cclock); + + timespec->tv_sec = mts.tv_sec; + timespec->tv_nsec = mts.tv_nsec; +#else + clock_gettime(CLOCK_REALTIME, timespec); +#endif +} diff --git a/hourglass.cabal b/hourglass.cabal new file mode 100644 --- /dev/null +++ b/hourglass.cabal @@ -0,0 +1,86 @@ +Name: hourglass +Version: 0.1.0 +Synopsis: simple performant time related library +Description: + Simple time library focusing on simple but powerful and performant API + . + The backbone of the library are the Timeable and Time type classes. + . + Each Timeable instances can be converted to type that has a Time instances, + and thus are different representations of current time. +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: vincent@snarc.org +Category: Time +Stability: experimental +Build-Type: Simple +Homepage: http://github.com/vincenthz/hs-hourglass +Cabal-Version: >=1.10 +extra-source-files: README.md + +Library + Exposed-modules: Data.Hourglass + , Data.Hourglass.Types + , Data.Hourglass.Epoch + , System.Hourglass + Other-modules: Data.Hourglass.Time + , Data.Hourglass.Format + , Data.Hourglass.Diff + , Data.Hourglass.Local + , Data.Hourglass.Calendar + , Data.Hourglass.Zone + , Data.Hourglass.Internal + , Data.Hourglass.Utils + Build-depends: base >= 4 && < 5 + , deepseq + ghc-options: -Wall -fwarn-tabs + Default-Language: Haskell2010 + if os(windows) + cpp-options: -DWINDOWS + Build-depends: Win32 + Other-modules: Data.Hourglass.Internal.Win + else + Other-modules: Data.Hourglass.Internal.Unix + c-sources: cbits/unix.c + +Test-Suite test-hourglass + type: exitcode-stdio-1.0 + hs-source-dirs: tests + Main-is: Tests.hs + Build-Depends: base >= 3 && < 5 + , mtl + , QuickCheck >= 2 + , HUnit + , test-framework + , test-framework-quickcheck2 + , test-framework-hunit + , hourglass + , deepseq + -- to test against some other reference + , time + , old-locale + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + Default-Language: Haskell2010 + if os(windows) + cpp-options: -DWINDOWS + +Benchmark bench-hourglass + hs-source-dirs: tests + Main-Is: Bench.hs + type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Build-depends: base >= 4 && < 5 + , bytestring + , criterion + , mtl + , deepseq + , hourglass + -- to benchmark against other reference + , time + , old-locale + +source-repository head + type: git + location: git://github.com/vincenthz/hs-hourglass diff --git a/tests/Bench.hs b/tests/Bench.hs new file mode 100644 --- /dev/null +++ b/tests/Bench.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ViewPatterns #-} +module Main (main) where + +import Criterion.Main +import Data.Hourglass +import TimeDB + +import Data.List (intercalate) +import qualified Data.Time.Calendar as T +import qualified Data.Time.Clock as T +import qualified Data.Time.Clock.POSIX as T +import qualified System.Locale as T + +timeToTuple :: T.UTCTime -> (Int, Int, Int, Int, Int, Int) +timeToTuple utcTime = (fromIntegral y, m, d, h, mi, sec) + where (y,m,d) = T.toGregorian (T.utctDay utcTime) + daytime = floor $ T.utctDayTime utcTime + (dt, sec)= daytime `divMod` 60 + (h , mi) = dt `divMod` 60 + --(DateTimeP (Date y m d) (TimeOfDayP (TimeOfDay h mi sec) _)) = localTimeToGlobal localtime + +elapsedToPosixTime :: Elapsed -> T.POSIXTime +elapsedToPosixTime (Elapsed (Seconds s)) = fromIntegral s + +timePosixDict :: [ (Elapsed, T.POSIXTime) ] +timePosixDict = + [ (Elapsed 0, 0) + , (Elapsed 1000000, 1000000) + , (Elapsed 9000099, 9000099) + , (Elapsed 1398232846, 1398232846) -- currentish time (at the time of writing) + , (Elapsed 5134000099, 5134000099) + , (Elapsed 10000000000000, 10000000000000) -- year 318857 .. + ] + +dateDict :: [ (Int, Int, Int, Int, Int, Int) ] +dateDict = + [ (1970, 1, 1, 1, 1, 1) + , (2014, 5, 5, 5, 5, 5) + , (2114, 11, 5, 5, 5, 5) + ] + +-- T.posixSecondsToUTCTime timePosix + +main = defaultMain + [ bgroup "highlevel" $ concatMap toHighLevel timePosixDict + , bgroup "to-calendar" $ concatMap toCalendar timePosixDict + , bgroup "to-posix" $ concatMap toPosix dateDict + ] + where toHighLevel (posixHourglass, posixTime) = + [ bench (show $ posixHourglass) $ nf timeGetDateTimeOfDay posixHourglass + , bench (show $ posixTime) $ nf T.posixSecondsToUTCTime posixTime + ] + toCalendar (posixHourglass, posixTime) = + [ bench (show $ posixHourglass) $ nf timeGetDateTimeOfDay posixHourglass + , bench (show $ posixTime) $ nf (timeToTuple . T.posixSecondsToUTCTime) posixTime + ] + toPosix v = + [ bench (n v) $ nf hourglass v + , bench (n v) $ nf time v + ] + where n (y,m,d,h,mi,s) = (intercalate "-" $ map show [y,m,d]) ++ " " ++ (intercalate ":" $ map show [h,mi,s]) + hourglass (y,m,d,h,mi,s) = timeGetElapsed $ DateTime (Date y (toEnum (m-1)) d) (TimeOfDay h mi s 0) + time (y,m,d,h,mi,s) = let day = T.fromGregorian (fromIntegral y) m d + diffTime = T.secondsToDiffTime $ fromIntegral (h * 3600 + mi * 60 + s) + in T.utcTimeToPOSIXSeconds (T.UTCTime day diffTime) + + --bench (show $ fromIntegral posixHourglass) $ nf ( diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +module Main where + +import Control.Applicative +import Data.Monoid (mempty) +--import Control.DeepSeq + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) + +import Test.HUnit hiding (Test) +import Test.QuickCheck + +import Data.Word +import Data.Int +import Data.Hourglass +import Data.Hourglass.Epoch +--import System.Hourglass + +import Foreign.Storable +import Foreign.C.Types (CTime) + +import qualified Data.Time.Calendar as T +import qualified Data.Time.Clock as T +import qualified Data.Time.Clock.POSIX as T +import qualified Data.Time.Format as T +import qualified System.Locale as T + +import qualified Control.Exception as E + +import TimeDB + +tmPosix0 :: Elapsed +tmPosix0 = fromIntegral (0 :: Word64) + +timePosix0 :: T.POSIXTime +timePosix0 = fromIntegral (0 :: Word64) + +elapsedToPosixTime :: Elapsed -> T.POSIXTime +elapsedToPosixTime (Elapsed (Seconds s)) = fromIntegral s + +dateEqual :: LocalTime DateTime -> T.UTCTime -> Bool +dateEqual localtime utcTime = + and [ fromIntegral y == y', m' == (fromEnum m + 1), d' == d + , h' == h, mi' == mi, sec' == sec ] + where (y',m',d') = T.toGregorian (T.utctDay utcTime) + daytime = floor $ T.utctDayTime utcTime + (dt', sec')= daytime `divMod` 60 + (h' , mi') = dt' `divMod` 60 + (DateTime (Date y m d) (TimeOfDay h mi sec _)) = localTimeToGlobal localtime + +-- windows native functions to convert time cannot handle time before year 1601 +#ifdef WINDOWS +loElapsed = -11644473600 -- ~ year 1601 +hiElapsed = 32503680000 +dateRange = (1800, 2202) +#else +isCTime64 = sizeOf (undefined :: CTime) == 8 +loElapsed = + if isCTime64 + then -62135596800 -- ~ year 0 + else -(2^(28 :: Int)) +hiElapsed = + if isCTime64 + then 2^(55 :: Int) -- in a future far far away + else 2^(29 :: Int) -- before the 2038 bug. +dateRange = + if isCTime64 + then (1800, 2202) + else (1960, 2036) +#endif +instance Arbitrary Seconds where + arbitrary = Seconds . toHiLo <$> arbitrary + where toHiLo v | v > loElapsed && v < hiElapsed = v + | v > hiElapsed = v `mod` hiElapsed + | v < loElapsed = v `mod` loElapsed + | otherwise = error "internal error" + +instance Arbitrary NanoSeconds where + arbitrary = NanoSeconds <$> choose (0, 100000000) +instance Arbitrary Elapsed where + arbitrary = Elapsed <$> arbitrary +instance Arbitrary TimezoneOffset where + arbitrary = TimezoneOffset <$> choose (-11*60,11*60) +instance Arbitrary TimeDiff where + arbitrary = TimeDiff <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> choose (0, 100000) +instance Arbitrary Month where + arbitrary = elements [January ..] +instance Arbitrary DateTime where + arbitrary = DateTime <$> arbitrary <*> arbitrary +instance Arbitrary Date where + arbitrary = Date <$> choose dateRange + <*> arbitrary + <*> choose (1,28) +instance Arbitrary TimeOfDay where + arbitrary = TimeOfDay <$> choose (0,23) + <*> choose (0,59) + <*> choose (0,59) + <*> arbitrary +instance (Time t, Arbitrary t) => Arbitrary (LocalTime t) where + arbitrary = localTime <$> arbitrary <*> arbitrary + +eq expected got + | expected == got = True + | otherwise = error ("expected: " ++ show expected ++ " got: " ++ show got) + +tests knowns = + [ testGroup "known" + [ testGroup "calendar conv" (map toCalendarTest $ zip [1..] (map tuple12 knowns)) + , testGroup "seconds conv" (map toSecondTest $ zip [1..] (map tuple12 knowns)) + , testGroup "weekday" (map toWeekDayTest $ zip [1..] (map tuple13 knowns)) + ] + , testGroup "conversion" + [ testProperty "calendar" $ \(e :: Elapsed) -> + e `eq` timeGetElapsed (timeGetDateTimeOfDay e) + , testProperty "win epoch" $ \(e :: Elapsed) -> + let e2 = timeConvert e :: ElapsedSince WindowsEpoch + in timePrint ISO8601_DateAndTime e `eq` timePrint ISO8601_DateAndTime e2 + ] + , testGroup "localtime" + [ testProperty "eq" $ \(l :: LocalTime Elapsed) -> + let g = localTimeToGlobal l + in l `eq` localTime (localTimeGetTimezone l) g + , testProperty "set" $ \(l :: LocalTime Elapsed, newTz) -> + let l2 = localTimeSetTimezone newTz l + in localTimeToGlobal l `eq` localTimeToGlobal l2 + ] + , testGroup "arithmetic" + [ testProperty "add-diff" $ \(e :: Elapsed, tdiff) -> + let d@(TimeDiff _ _ day h mi s _) = tdiff { timeDiffYears = 0 + , timeDiffMonths = 0 + , timeDiffNs = 0 + } + i64 = fromIntegral + accSecs = (((i64 day * 24) + i64 h) * 60 + i64 mi) * 60 + i64 s :: Int64 + e' = timeAdd e d + in Seconds accSecs `eq` timeDiff e' e + , testProperty "calendar-add-month" $ \date@(DateTime (Date y m d) _) -> + let date'@(DateTime (Date y' m' d') _) = timeAdd date (mempty { timeDiffMonths = 1 }) + in timeGetTimeOfDay date `eq` timeGetTimeOfDay date' && + (d `eq` d') && + (toEnum ((fromEnum m+1) `mod` 12) `eq` m') && + (if m == December then (y+1) `eq` y' else y `eq` y') + ] + , testGroup "formating" + [ testProperty "iso8601 date" $ \(e :: Elapsed) -> + (calTimeFormatTimeISO8601 (elapsedToPosixTime e) `eq` timePrint ISO8601_Date e) + , testProperty "unix seconds" $ \(e :: Elapsed) -> + let sTime = T.formatTime T.defaultTimeLocale "%s" (T.posixSecondsToUTCTime $ elapsedToPosixTime e) + sHg = timePrint "EPOCH" e + in sTime `eq` sHg + ] + , testGroup "parsing" + [ testProperty "iso8601 date" $ \(e :: Elapsed) -> + let fmt = calTimeFormatTimeISO8601 (elapsedToPosixTime e) + ed1 = timeParseE ISO8601_Date fmt + md2 = T.parseTime T.defaultTimeLocale fmt "%F" + in case (ed1,md2) of + (Left _, Nothing) -> error ("both cannot parse: " ++ show fmt) + (Left err, Just _) -> error ("error parsing string: " ++ show err) + (Right (d1, ""), Just d2) -> dateEqual d1 d2 + (Right (_,_), Nothing) -> True -- let (LocalTime tparsed _) = r in error ("time cannot parse: " ++ show tparsed ++ " " ++ fmt) + (Right (_, rm), _) -> error ("remaining string after parse: " ++ rm) + , testProperty "timezone" $ \tz -> + let r = timeParseE "TZHM" (show tz) in + case r of + Right (localtime, "") -> tz `eq` localTimeGetTimezone localtime + _ -> error "Cannot parse timezone" + ] + ] + where toCalendarTest :: (Int, (Elapsed, DateTime)) -> Test + toCalendarTest (i, (us, dt)) = + testCase (show i) (dt @=? timeGetDateTimeOfDay us) + toSecondTest :: (Int, (Elapsed, DateTime)) -> Test + toSecondTest (i, (us@(Elapsed (Seconds s)), dt)) = + testCase (show i ++ "-" ++ show s ++ "s") (us @=? timeGetElapsed dt) + toWeekDayTest :: (Int, (Elapsed, WeekDay)) -> Test + toWeekDayTest (i, (us, wd)) = + testCase (show i ++ "-" ++ show wd) (wd @=? getWeekDay (dtDate $ timeGetDateTimeOfDay us)) + + tuple12 (a,b,_,_) = (a,b) + tuple13 (a,_,b,_) = (a,b) + + calTimeFormatTimeISO8601 timePosix = + T.formatTime T.defaultTimeLocale "%F" (T.posixSecondsToUTCTime timePosix) + +main = do + knowns <- E.catch (map parseTimeConv . lines <$> readFile "test-time-db") + (\(_ :: E.SomeException) -> return []) + defaultMain (tests knowns)