diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,18 @@ # Change Log +## [1.9] +- new conversion functions timeToDaysAndTimeOfDay & daysAndTimeOfDayToTime +- new DayOfWeek type +- new CalendarDiffDays and CalendarDiffTime types +- new ISO8601 module for ISO 8601 formatting & parsing +- new addLocalTime, diffLocalTime +- hide members of FormatTime and ParseTime classes +- formatting & parsing for diff types (NominalDiffTime, DiffTime, CalendarDiffDays, CalendarDiffTime) +- formatting: %Ez and %EZ for ±HH:MM format +- parseTimeM: use MonadFail constraint when supported +- parsing: reject invalid (and empty) time-zones with %z and %Z +- parsing: reject invalid hour/minute/second specifiers + ## [1.8.0.4] - Fix "show minBound" bug - haddock: example for parseTimeM diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell time package], [1.8.0.4], [ashley@semantic.org], [time]) +AC_INIT([Haskell time package], [1.9], [ashley@semantic.org], [time]) # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([lib/include/HsTime.h]) diff --git a/lib/Data/Format.hs b/lib/Data/Format.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Format.hs @@ -0,0 +1,256 @@ +module Data.Format + ( Productish(..) + , Summish(..) + , parseReader + , Format(..) + , formatShow + , formatParseM + , isoMap + , mapMFormat + , filterFormat + , clipFormat + , enumMap + , literalFormat + , specialCaseShowFormat + , specialCaseFormat + , optionalFormat + , casesFormat + , optionalSignFormat + , mandatorySignFormat + , SignOption(..) + , integerFormat + , decimalFormat + ) where + +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +import Prelude hiding (fail) +#endif +#if MIN_VERSION_base(4,8,0) +import Data.Void +#endif +import Data.Char +import Text.ParserCombinators.ReadP + + +#if MIN_VERSION_base(4,8,0) +#else +data Void +absurd :: Void -> a +absurd v = seq v $ error "absurd" +#endif + +class IsoVariant f where + isoMap :: (a -> b) -> (b -> a) -> f a -> f b + +enumMap :: (IsoVariant f,Enum a) => f Int -> f a +enumMap = isoMap toEnum fromEnum + +infixr 3 <**>, **>, <** +class IsoVariant f => Productish f where + pUnit :: f () + (<**>) :: f a -> f b -> f (a,b) + (**>) :: f () -> f a -> f a + fu **> fa = isoMap (\((),a) -> a) (\a -> ((),a)) $ fu <**> fa + (<**) :: f a -> f () -> f a + fa <** fu = isoMap (\(a,()) -> a) (\a -> (a,())) $ fa <**> fu + +infixr 2 <++> +class IsoVariant f => Summish f where + pVoid :: f Void + (<++>) :: f a -> f b -> f (Either a b) + + +parseReader :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ) => ReadP t -> String -> m t +parseReader readp s = case [ t | (t,"") <- readP_to_S readp s] of + [t] -> return t + [] -> fail $ "no parse of " ++ show s + _ -> fail $ "multiple parses of " ++ show s + +-- | A text format for a type +data Format t = MkFormat + { formatShowM :: t -> Maybe String + -- ^ Show a value in the format, if representable + , formatReadP :: ReadP t + -- ^ Read a value in the format + } + +-- | Show a value in the format, or error if unrepresentable +formatShow :: Format t -> t -> String +formatShow fmt t = case formatShowM fmt t of + Just str -> str + Nothing -> error "formatShow: bad value" + +-- | Parse a value in the format +formatParseM :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ) => Format t -> String -> m t +formatParseM format = parseReader $ formatReadP format + +instance IsoVariant Format where + isoMap ab ba (MkFormat sa ra) = MkFormat (\b -> sa $ ba b) (fmap ab ra) + +mapMFormat :: (a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b +mapMFormat amb bma (MkFormat sa ra) = MkFormat (\b -> bma b >>= sa) $ do + a <- ra + case amb a of + Just b -> return b + Nothing -> pfail + +filterFormat :: (a -> Bool) -> Format a -> Format a +filterFormat test = mapMFormat (\a -> if test a then Just a else Nothing) (\a -> if test a then Just a else Nothing) + +-- | Limits are inclusive +clipFormat :: Ord a => (a,a) -> Format a -> Format a +clipFormat (lo,hi) = filterFormat (\a -> a >= lo && a <= hi) + +instance Productish Format where + pUnit = MkFormat {formatShowM = \_ -> Just "", formatReadP = return ()} + (<**>) (MkFormat sa ra) (MkFormat sb rb) = let + sab (a, b) = do + astr <- sa a + bstr <- sb b + return $ astr ++ bstr + rab = do + a <- ra + b <- rb + return (a, b) + in MkFormat sab rab + (MkFormat sa ra) **> (MkFormat sb rb) = let + s b = do + astr <- sa () + bstr <- sb b + return $ astr ++ bstr + r = do + ra + rb + in MkFormat s r + (MkFormat sa ra) <** (MkFormat sb rb) = let + s a = do + astr <- sa a + bstr <- sb () + return $ astr ++ bstr + r = do + a <- ra + rb + return a + in MkFormat s r + +instance Summish Format where + pVoid = MkFormat absurd pfail + (MkFormat sa ra) <++> (MkFormat sb rb) = let + sab (Left a) = sa a + sab (Right b) = sb b + rab = (fmap Left ra) +++ (fmap Right rb) + in MkFormat sab rab + +literalFormat :: String -> Format () +literalFormat s = MkFormat {formatShowM = \_ -> Just s, formatReadP = string s >> return ()} + +specialCaseShowFormat :: Eq a => (a,String) -> Format a -> Format a +specialCaseShowFormat (val,str) (MkFormat s r) = let + s' t | t == val = Just str + s' t = s t + in MkFormat s' r + +specialCaseFormat :: Eq a => (a,String) -> Format a -> Format a +specialCaseFormat (val,str) (MkFormat s r) = let + s' t | t == val = Just str + s' t = s t + r' = (string str >> return val) +++ r + in MkFormat s' r' + +optionalFormat :: Eq a => a -> Format a -> Format a +optionalFormat val = specialCaseFormat (val,"") + +casesFormat :: Eq a => [(a,String)] -> Format a +casesFormat pairs = let + s t = lookup t pairs + r [] = pfail + r ((v,str):pp) = (string str >> return v) <++ r pp + in MkFormat s $ r pairs + +optionalSignFormat :: (Eq t,Num t) => Format t +optionalSignFormat = casesFormat + [ + (1,""), + (1,"+"), + (0,""), + (-1,"-") + ] + +mandatorySignFormat :: (Eq t,Num t) => Format t +mandatorySignFormat = casesFormat + [ + (1,"+"), + (0,"+"), + (-1,"-") + ] + +data SignOption + = NoSign + | NegSign + | PosNegSign + +readSign :: Num t => SignOption -> ReadP (t -> t) +readSign NoSign = return id +readSign NegSign = option id $ char '-' >> return negate +readSign PosNegSign = (char '+' >> return id) +++ (char '-' >> return negate) + +readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t +readNumber signOpt mdigitcount allowDecimal = do + sign <- readSign signOpt + digits <- + case mdigitcount of + Just digitcount -> count digitcount $ satisfy isDigit + Nothing -> many1 $ satisfy isDigit + moredigits <- + case allowDecimal of + False -> return "" + True -> + option "" $ do + _ <- char '.' +++ char ',' + dd <- many1 (satisfy isDigit) + return $ '.' : dd + return $ sign $ read $ digits ++ moredigits + +zeroPad :: Maybe Int -> String -> String +zeroPad Nothing s = s +zeroPad (Just i) s = replicate (i - length s) '0' ++ s + +trimTrailing :: String -> String +trimTrailing "" = "" +trimTrailing "." = "" +trimTrailing s | last s == '0' = trimTrailing $ init s +trimTrailing s = s + +showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String +showNumber signOpt mdigitcount t = let + showIt str = let + (intPart, decPart) = break ((==) '.') str + in (zeroPad mdigitcount intPart) ++ trimTrailing decPart + in case show t of + ('-':str) -> + case signOpt of + NoSign -> Nothing + _ -> Just $ '-' : showIt str + str -> + Just $ case signOpt of + PosNegSign -> '+' : showIt str + _ -> showIt str + +integerFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t +integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False) + +decimalFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t +decimalFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount True) diff --git a/lib/Data/Time.hs b/lib/Data/Time.hs --- a/lib/Data/Time.hs +++ b/lib/Data/Time.hs @@ -7,13 +7,16 @@ * 'UTCTime' for actual times * 'NominalDiffTime' for differences between times, i.e. durations -Use these types for the ways people refer to time: +Use these types for the ways people refer to time and time differences: * 'Day' for something like June 27th 2017 +* 'DayOfWeek' for something like Tuesday * 'TimeOfDay' for something like 5pm * 'LocalTime' for a 'Day' with a 'TimeOfDay' * 'TimeZone' for a time zone offset (not actually the time zone itself) like -0700 * 'ZonedTime' for a 'LocalTime' with a 'TimeZone' +* 'CalendarDiffDays' for something like 6 years, 1 month and 5 days +* 'CalendarDiffTime' for something like 6 years, 1 month, 5 days, 3 hours, 7 minutes and 25.784 seconds Use this for low-latency timing: diff --git a/lib/Data/Time/Calendar.hs b/lib/Data/Time/Calendar.hs --- a/lib/Data/Time/Calendar.hs +++ b/lib/Data/Time/Calendar.hs @@ -1,9 +1,13 @@ module Data.Time.Calendar ( module Data.Time.Calendar.Days, - module Data.Time.Calendar.Gregorian + module Data.Time.Calendar.CalendarDiffDays, + module Data.Time.Calendar.Gregorian, + module Data.Time.Calendar.Week ) where import Data.Time.Calendar.Days +import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Gregorian +import Data.Time.Calendar.Week import Data.Time.Format() diff --git a/lib/Data/Time/Calendar/CalendarDiffDays.hs b/lib/Data/Time/Calendar/CalendarDiffDays.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Calendar/CalendarDiffDays.hs @@ -0,0 +1,52 @@ +module Data.Time.Calendar.CalendarDiffDays + ( + -- * Calendar Duration + module Data.Time.Calendar.CalendarDiffDays + ) where + +#if MIN_VERSION_base(4,8,0) +#else +import Data.Monoid +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup hiding (option) +#endif + +data CalendarDiffDays = CalendarDiffDays + { cdMonths :: Integer + , cdDays :: Integer + } deriving Eq + +#if MIN_VERSION_base(4,9,0) +-- | Additive +instance Semigroup CalendarDiffDays where + CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2) +#endif + +-- | Additive +instance Monoid CalendarDiffDays where + mempty = CalendarDiffDays 0 0 +#if MIN_VERSION_base(4,9,0) + mappend = (<>) +#else + mappend (CalendarDiffDays m1 d1) (CalendarDiffDays m2 d2) = CalendarDiffDays (m1 + m2) (d1 + d2) +#endif + +instance Show CalendarDiffDays where + show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D" + +calendarDay :: CalendarDiffDays +calendarDay = CalendarDiffDays 0 1 + +calendarWeek :: CalendarDiffDays +calendarWeek = CalendarDiffDays 0 7 + +calendarMonth :: CalendarDiffDays +calendarMonth = CalendarDiffDays 1 0 + +calendarYear :: CalendarDiffDays +calendarYear = CalendarDiffDays 12 0 + +-- | Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths. +scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays +scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d) diff --git a/lib/Data/Time/Calendar/Days.hs b/lib/Data/Time/Calendar/Days.hs --- a/lib/Data/Time/Calendar/Days.hs +++ b/lib/Data/Time/Calendar/Days.hs @@ -1,6 +1,5 @@ {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h" --- #hide module Data.Time.Calendar.Days ( -- * Days diff --git a/lib/Data/Time/Calendar/Gregorian.hs b/lib/Data/Time/Calendar/Gregorian.hs --- a/lib/Data/Time/Calendar/Gregorian.hs +++ b/lib/Data/Time/Calendar/Gregorian.hs @@ -1,6 +1,4 @@ {-# OPTIONS -fno-warn-orphans #-} - --- #hide module Data.Time.Calendar.Gregorian ( -- * Gregorian calendar @@ -10,6 +8,8 @@ -- e.g. "one month after March 31st" addGregorianMonthsClip,addGregorianMonthsRollOver, addGregorianYearsClip,addGregorianYearsRollOver, + addGregorianDurationClip,addGregorianDurationRollOver, + diffGregorianDurationClip,diffGregorianDurationRollOver, -- re-exported from OrdinalDate isLeapYear @@ -18,6 +18,7 @@ import Data.Time.Calendar.MonthDay import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Days +import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Private -- | Convert to proleptic Gregorian calendar. First element of result is year, second month number (1-12), third day (1-31). @@ -76,6 +77,45 @@ -- For instance, 2004-02-29 + 2 years = 2006-03-01. addGregorianYearsRollOver :: Integer -> Day -> Day addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12) + +-- | Add months (clipped to last day), then add days +addGregorianDurationClip :: CalendarDiffDays -> Day -> Day +addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day + +-- | Add months (rolling over to next month), then add days +addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day +addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day + +-- | Calendrical difference, with as many whole months as possible +diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays +diffGregorianDurationClip day2 day1 = let + (y1,m1,d1) = toGregorian day1 + (y2,m2,d2) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +-- | Calendrical difference, with as many whole months as possible. +-- Same as 'diffGregorianDurationClip' for positive durations. +diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays +diffGregorianDurationRollOver day2 day1 = let + (y1,m1,d1) = toGregorian day1 + (y2,m2,d2) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed -- orphan instance instance Show Day where diff --git a/lib/Data/Time/Calendar/Julian.hs b/lib/Data/Time/Calendar/Julian.hs --- a/lib/Data/Time/Calendar/Julian.hs +++ b/lib/Data/Time/Calendar/Julian.hs @@ -7,12 +7,15 @@ -- calendrical arithmetic -- e.g. "one month after March 31st" addJulianMonthsClip,addJulianMonthsRollOver, - addJulianYearsClip,addJulianYearsRollOver + addJulianYearsClip,addJulianYearsRollOver, + addJulianDurationClip,addJulianDurationRollOver, + diffJulianDurationClip,diffJulianDurationRollOver, ) where import Data.Time.Calendar.MonthDay import Data.Time.Calendar.JulianYearDay import Data.Time.Calendar.Days +import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Private -- | Convert to proleptic Julian calendar. First element of result is year, second month number (1-12), third day (1-31). @@ -71,3 +74,42 @@ -- For instance, 2004-02-29 + 2 years = 2006-03-01. addJulianYearsRollOver :: Integer -> Day -> Day addJulianYearsRollOver n = addJulianMonthsRollOver (n * 12) + +-- | Add months (clipped to last day), then add days +addJulianDurationClip :: CalendarDiffDays -> Day -> Day +addJulianDurationClip (CalendarDiffDays m d) day = addDays d $ addJulianMonthsClip m day + +-- | Add months (rolling over to next month), then add days +addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day +addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMonthsRollOver m day + +-- | Calendrical difference, with as many whole months as possible +diffJulianDurationClip :: Day -> Day -> CalendarDiffDays +diffJulianDurationClip day2 day1 = let + (y1,m1,d1) = toJulian day1 + (y2,m2,d2) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed + +-- | Calendrical difference, with as many whole months as possible. +-- Same as 'diffJulianDurationClip' for positive durations. +diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays +diffJulianDurationRollOver day2 day1 = let + (y1,m1,d1) = toJulian day1 + (y2,m2,d2) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 then + if d2 >= d1 then ymdiff else ymdiff - 1 + else if d2 <= d1 then ymdiff else ymdiff + 1 + dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 + in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed diff --git a/lib/Data/Time/Calendar/JulianYearDay.hs b/lib/Data/Time/Calendar/JulianYearDay.hs --- a/lib/Data/Time/Calendar/JulianYearDay.hs +++ b/lib/Data/Time/Calendar/JulianYearDay.hs @@ -1,4 +1,3 @@ --- #hide module Data.Time.Calendar.JulianYearDay ( -- * Year and day format diff --git a/lib/Data/Time/Calendar/Private.hs b/lib/Data/Time/Calendar/Private.hs --- a/lib/Data/Time/Calendar/Private.hs +++ b/lib/Data/Time/Calendar/Private.hs @@ -1,4 +1,3 @@ --- #hide module Data.Time.Calendar.Private where import Data.Fixed @@ -51,3 +50,15 @@ clipValid a _ x | x < a = Nothing clipValid _ b x | x > b = Nothing clipValid _ _ x = Just x + +quotBy :: (Real a,Integral b) => a -> a -> b +quotBy d n = truncate ((toRational n) / (toRational d)) + +remBy :: Real a => a -> a -> a +remBy d n = n - (fromInteger f) * d where + f = quotBy d n + +quotRemBy :: (Real a,Integral b) => a -> a -> (b,a) +quotRemBy d n = let + f = quotBy d n + in (f,n - (fromIntegral f) * d) diff --git a/lib/Data/Time/Calendar/Week.hs b/lib/Data/Time/Calendar/Week.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Calendar/Week.hs @@ -0,0 +1,47 @@ +module Data.Time.Calendar.Week + ( + -- * Week + DayOfWeek(..) + , dayOfWeek + ) where + +import Data.Time.Calendar.Days + +data DayOfWeek + = Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + | Sunday + deriving (Eq, Show, Read) + +-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. +-- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. +instance Enum DayOfWeek where + toEnum i = + case mod i 7 of + 0 -> Sunday + 1 -> Monday + 2 -> Tuesday + 3 -> Wednesday + 4 -> Thursday + 5 -> Friday + _ -> Saturday + fromEnum Monday = 1 + fromEnum Tuesday = 2 + fromEnum Wednesday = 3 + fromEnum Thursday = 4 + fromEnum Friday = 5 + fromEnum Saturday = 6 + fromEnum Sunday = 7 + enumFromTo wd1 wd2 + | wd1 == wd2 = [wd1] + enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2 + enumFromThenTo wd1 wd2 wd3 + | wd2 == wd3 = [wd1, wd2] + enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3 + +dayOfWeek :: Day -> DayOfWeek +dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 diff --git a/lib/Data/Time/Clock/Internal/DiffTime.hs b/lib/Data/Time/Clock/Internal/DiffTime.hs --- a/lib/Data/Time/Clock/Internal/DiffTime.hs +++ b/lib/Data/Time/Clock/Internal/DiffTime.hs @@ -3,7 +3,6 @@ #endif {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h" --- #hide module Data.Time.Clock.Internal.DiffTime ( -- * Absolute intervals diff --git a/lib/Data/Time/Clock/Internal/NominalDiffTime.hs b/lib/Data/Time/Clock/Internal/NominalDiffTime.hs --- a/lib/Data/Time/Clock/Internal/NominalDiffTime.hs +++ b/lib/Data/Time/Clock/Internal/NominalDiffTime.hs @@ -3,7 +3,6 @@ {-# LANGUAGE Trustworthy #-} #endif #include "HsConfigure.h" --- #hide module Data.Time.Clock.Internal.NominalDiffTime ( NominalDiffTime, diff --git a/lib/Data/Time/Clock/Internal/UTCDiff.hs b/lib/Data/Time/Clock/Internal/UTCDiff.hs --- a/lib/Data/Time/Clock/Internal/UTCDiff.hs +++ b/lib/Data/Time/Clock/Internal/UTCDiff.hs @@ -1,4 +1,3 @@ --- #hide module Data.Time.Clock.Internal.UTCDiff where import Data.Time.Clock.Internal.NominalDiffTime diff --git a/lib/Data/Time/Format.hs b/lib/Data/Time/Format.hs --- a/lib/Data/Time/Format.hs +++ b/lib/Data/Time/Format.hs @@ -1,344 +1,9 @@ module Data.Time.Format ( -- * UNIX-style formatting - NumericPadOption,FormatTime(..),formatTime, + FormatTime(),formatTime, module Data.Time.Format.Parse ) where - -import Data.Maybe -import Data.Char -import Data.Fixed - -import Data.Time.Clock.Internal.UniversalTime -import Data.Time.Clock.Internal.UTCTime -import Data.Time.Clock.POSIX -import Data.Time.Calendar.Days -import Data.Time.Calendar.Gregorian -import Data.Time.Calendar.WeekDate -import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.Private -import Data.Time.LocalTime.Internal.TimeZone -import Data.Time.LocalTime.Internal.TimeOfDay -import Data.Time.LocalTime.Internal.LocalTime -import Data.Time.LocalTime.Internal.ZonedTime +import Data.Time.Format.Format.Class +import Data.Time.Format.Format.Instances() import Data.Time.Format.Parse - - -type NumericPadOption = Maybe Char - --- the weird UNIX logic is here -getPadOption :: Bool -> Bool -> Int -> Char -> Maybe NumericPadOption -> Maybe Int -> PadOption -getPadOption trunc fdef idef cdef mnpad mi = let - c = case mnpad of - Just (Just c') -> c' - Just Nothing -> ' ' - _ -> cdef - i = case mi of - Just i' -> case mnpad of - Just Nothing -> i' - _ -> if trunc then i' else max i' idef - Nothing -> idef - f = case mi of - Just _ -> True - Nothing -> case mnpad of - Nothing -> fdef - Just Nothing -> False - Just (Just _) -> True - in if f then Pad i c else NoPad - -padGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String) -padGeneral trunc fdef idef cdef ff locale mnpad mi = ff locale $ getPadOption trunc fdef idef cdef mnpad mi - -padString :: (TimeLocale -> t -> String) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String) -padString ff = padGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale - -padNum :: (ShowPadded i) => Bool -> Int -> Char -> (t -> i) -> (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String) -padNum fdef idef cdef ff = padGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff - --- -class FormatTime t where - formatCharacter :: Char -> Maybe (TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String) - -formatChar :: (FormatTime t) => Char -> TimeLocale -> Maybe NumericPadOption -> Maybe Int -> t -> String -formatChar '%' = padString $ \_ _ -> "%" -formatChar 't' = padString $ \_ _ -> "\t" -formatChar 'n' = padString $ \_ _ -> "\n" -formatChar c = case formatCharacter c of - Just f -> f - _ -> \_ _ _ _ -> "" - --- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'. --- --- The general form is @%\\\@, where @\@ and @\@ are optional. --- --- == @\@ --- glibc-style modifiers can be used before the specifier (here marked as @z@): --- --- [@%-z@] no padding --- --- [@%_z@] pad with spaces --- --- [@%0z@] pad with zeros --- --- [@%^z@] convert to upper case --- --- [@%#z@] convert to lower case (consistently, unlike glibc) --- --- == @\@ --- Width digits can also be used after any modifiers and before the specifier (here marked as @z@), for example: --- --- [@%4z@] pad to 4 characters (with default padding character) --- --- [@%_12z@] pad with spaces to 12 characters --- --- == @\@ --- --- For all types (note these three are done by 'formatTime', not by 'formatCharacter'): --- --- [@%%@] @%@ --- --- [@%t@] tab --- --- [@%n@] newline --- --- === 'TimeZone' --- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'): --- --- [@%z@] timezone offset in the format @-HHMM@. --- --- [@%Z@] timezone name --- --- === 'LocalTime' --- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): --- --- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@) --- --- === 'TimeOfDay' --- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): --- --- [@%R@] same as @%H:%M@ --- --- [@%T@] same as @%H:%M:%S@ --- --- [@%X@] as 'timeFmt' @locale@ (e.g. @%H:%M:%S@) --- --- [@%r@] as 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@) --- --- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @am@, @pm@ --- --- [@%p@] day-half of day from ('amPm' @locale@), @AM@, @PM@ --- --- [@%H@] hour of day (24-hour), 0-padded to two chars, @00@ - @23@ --- --- [@%k@] hour of day (24-hour), space-padded to two chars, @ 0@ - @23@ --- --- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @01@ - @12@ --- --- [@%l@] hour of day-half (12-hour), space-padded to two chars, @ 1@ - @12@ --- --- [@%M@] minute of hour, 0-padded to two chars, @00@ - @59@ --- --- [@%S@] second of minute (without decimal part), 0-padded to two chars, @00@ - @60@ --- --- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@. --- --- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros. --- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified. --- --- === 'UTCTime' and 'ZonedTime' --- For 'UTCTime' and 'ZonedTime': --- --- [@%s@] number of whole seconds since the Unix epoch. For times before --- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@ --- the decimals are positive, not negative. For example, 0.9 seconds --- before the Unix epoch is formatted as @-1.1@ with @%s%Q@. --- --- === 'Day' --- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): --- --- [@%D@] same as @%m\/%d\/%y@ --- --- [@%F@] same as @%Y-%m-%d@ --- --- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@) --- --- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars --- --- [@%y@] year of century, 0-padded to two chars, @00@ - @99@ --- --- [@%C@] century, no padding. Note @%0C@ and @%_C@ pad to two chars --- --- [@%B@] month name, long form ('fst' from 'months' @locale@), @January@ - @December@ --- --- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@ --- --- [@%m@] month of year, 0-padded to two chars, @01@ - @12@ --- --- [@%d@] day of month, 0-padded to two chars, @01@ - @31@ --- --- [@%e@] day of month, space-padded to two chars, @ 1@ - @31@ --- --- [@%j@] day of year, 0-padded to three chars, @001@ - @366@ --- --- [@%f@] century for Week Date format, no padding. Note @%0f@ and @%_f@ pad to two chars --- --- [@%V@] week of year for Week Date format, 0-padded to two chars, @01@ - @53@ --- --- [@%u@] day of week for Week Date format, @1@ - @7@ --- --- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@ --- --- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @Sunday@ - @Saturday@ --- --- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @00@ - @53@ --- --- [@%w@] day of week number, @0@ (= Sunday) - @6@ (= Saturday) --- --- [@%W@] week of year where weeks start on Monday (as 'mondayStartWeek'), 0-padded to two chars, @00@ - @53@ -formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String -formatTime _ [] _ = "" -formatTime locale ('%':cs) t = case formatTime1 locale cs t of - Just result -> result - Nothing -> '%':(formatTime locale cs t) -formatTime locale (c:cs) t = c:(formatTime locale cs t) - -formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String -formatTime1 locale ('_':cs) t = formatTime2 locale id (Just (Just ' ')) cs t -formatTime1 locale ('-':cs) t = formatTime2 locale id (Just Nothing) cs t -formatTime1 locale ('0':cs) t = formatTime2 locale id (Just (Just '0')) cs t -formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t -formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t -formatTime1 locale cs t = formatTime2 locale id Nothing cs t - -getDigit :: Char -> Maybe Int -getDigit c | c < '0' = Nothing -getDigit c | c > '9' = Nothing -getDigit c = Just $ (ord c) - (ord '0') - -pullNumber :: Maybe Int -> String -> (Maybe Int,String) -pullNumber mx [] = (mx,[]) -pullNumber mx s@(c:cs) = case getDigit c of - Just i -> pullNumber (Just $ (fromMaybe 0 mx)*10+i) cs - Nothing -> (mx,s) - -formatTime2 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> String -> t -> Maybe String -formatTime2 locale recase mpad cs t = let - (mwidth,rest) = pullNumber Nothing cs - in formatTime3 locale recase mpad mwidth rest t - -formatTime3 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe NumericPadOption -> Maybe Int -> String -> t -> Maybe String -formatTime3 locale recase mpad mwidth (c:cs) t = Just $ (recase (formatChar c locale mpad mwidth t)) ++ (formatTime locale cs t) -formatTime3 _locale _recase _mpad _mwidth [] _t = Nothing - -instance FormatTime LocalTime where - formatCharacter 'c' = Just $ \locale _ _ -> formatTime locale (dateTimeFmt locale) - formatCharacter c = case formatCharacter c of - Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (localDay dt) - Nothing -> case formatCharacter c of - Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (localTimeOfDay dt) - Nothing -> Nothing - -todAMPM :: TimeLocale -> TimeOfDay -> String -todAMPM locale day = let - (am,pm) = amPm locale - in if (todHour day) < 12 then am else pm - -tod12Hour :: TimeOfDay -> Int -tod12Hour day = (mod (todHour day - 1) 12) + 1 - -showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String -showPaddedFixedFraction pado x = let - digits = dropWhile (=='.') $ dropWhile (/='.') $ showFixed True x - n = length digits - in case pado of - NoPad -> digits - Pad i c -> if i < n - then take i digits - else digits ++ replicate (i - n) c - -instance FormatTime TimeOfDay where - -- Aggregate - formatCharacter 'R' = Just $ padString $ \locale -> formatTime locale "%H:%M" - formatCharacter 'T' = Just $ padString $ \locale -> formatTime locale "%H:%M:%S" - formatCharacter 'X' = Just $ padString $ \locale -> formatTime locale (timeFmt locale) - formatCharacter 'r' = Just $ padString $ \locale -> formatTime locale (time12Fmt locale) - -- AM/PM - formatCharacter 'P' = Just $ padString $ \locale -> map toLower . todAMPM locale - formatCharacter 'p' = Just $ padString $ \locale -> todAMPM locale - -- Hour - formatCharacter 'H' = Just $ padNum True 2 '0' todHour - formatCharacter 'I' = Just $ padNum True 2 '0' tod12Hour - formatCharacter 'k' = Just $ padNum True 2 ' ' todHour - formatCharacter 'l' = Just $ padNum True 2 ' ' tod12Hour - -- Minute - formatCharacter 'M' = Just $ padNum True 2 '0' todMin - -- Second - formatCharacter 'S' = Just $ padNum True 2 '0' $ (floor . todSec :: TimeOfDay -> Int) - formatCharacter 'q' = Just $ padGeneral True True 12 '0' $ \_ pado -> showPaddedFixedFraction pado . todSec - formatCharacter 'Q' = Just $ padGeneral True False 12 '0' $ \_ pado -> dotNonEmpty . showPaddedFixedFraction pado . todSec where - dotNonEmpty "" = "" - dotNonEmpty s = '.':s - - -- Default - formatCharacter _ = Nothing - -instance FormatTime ZonedTime where - formatCharacter 'c' = Just $ padString $ \locale -> formatTime locale (dateTimeFmt locale) - formatCharacter 's' = Just $ padNum True 1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer) - formatCharacter c = case formatCharacter c of - Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (zonedTimeToLocalTime dt) - Nothing -> case formatCharacter c of - Just f -> Just $ \locale mpado mwidth dt -> f locale mpado mwidth (zonedTimeZone dt) - Nothing -> Nothing - -instance FormatTime TimeZone where - formatCharacter 'z' = Just $ padGeneral False True 4 '0' $ \_ pado -> showPadded pado . timeZoneOffsetString'' pado - formatCharacter 'Z' = Just $ \locale mnpo mi z -> let - n = timeZoneName z - in if null n then timeZoneOffsetString'' (getPadOption False True 4 '0' mnpo mi) z else padString (\_ -> timeZoneName) locale mnpo mi z - formatCharacter _ = Nothing - -instance FormatTime Day where - -- Aggregate - formatCharacter 'D' = Just $ padString $ \locale -> formatTime locale "%m/%d/%y" - formatCharacter 'F' = Just $ padString $ \locale -> formatTime locale "%Y-%m-%d" - formatCharacter 'x' = Just $ padString $ \locale -> formatTime locale (dateFmt locale) - - -- Year Count - formatCharacter 'Y' = Just $ padNum False 4 '0' $ fst . toOrdinalDate - formatCharacter 'y' = Just $ padNum True 2 '0' $ mod100 . fst . toOrdinalDate - formatCharacter 'C' = Just $ padNum False 2 '0' $ div100 . fst . toOrdinalDate - -- Month of Year - formatCharacter 'B' = Just $ padString $ \locale -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian - formatCharacter 'b' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian - formatCharacter 'h' = Just $ padString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian - formatCharacter 'm' = Just $ padNum True 2 '0' $ (\(_,m,_) -> m) . toGregorian - -- Day of Month - formatCharacter 'd' = Just $ padNum True 2 '0' $ (\(_,_,d) -> d) . toGregorian - formatCharacter 'e' = Just $ padNum True 2 ' ' $ (\(_,_,d) -> d) . toGregorian - -- Day of Year - formatCharacter 'j' = Just $ padNum True 3 '0' $ snd . toOrdinalDate - - -- ISO 8601 Week Date - formatCharacter 'G' = Just $ padNum False 4 '0' $ (\(y,_,_) -> y) . toWeekDate - formatCharacter 'g' = Just $ padNum True 2 '0' $ mod100 . (\(y,_,_) -> y) . toWeekDate - formatCharacter 'f' = Just $ padNum False 2 '0' $ div100 . (\(y,_,_) -> y) . toWeekDate - - formatCharacter 'V' = Just $ padNum True 2 '0' $ (\(_,w,_) -> w) . toWeekDate - formatCharacter 'u' = Just $ padNum True 1 '0' $ (\(_,_,d) -> d) . toWeekDate - - -- Day of week - formatCharacter 'a' = Just $ padString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek - formatCharacter 'A' = Just $ padString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek - formatCharacter 'U' = Just $ padNum True 2 '0' $ fst . sundayStartWeek - formatCharacter 'w' = Just $ padNum True 1 '0' $ snd . sundayStartWeek - formatCharacter 'W' = Just $ padNum True 2 '0' $ fst . mondayStartWeek - - -- Default - formatCharacter _ = Nothing - -instance FormatTime UTCTime where - formatCharacter c = fmap (\f locale mpado mwidth t -> f locale mpado mwidth (utcToZonedTime utc t)) (formatCharacter c) - -instance FormatTime UniversalTime where - formatCharacter c = fmap (\f locale mpado mwidth t -> f locale mpado mwidth (ut1ToLocalTime 0 t)) (formatCharacter c) diff --git a/lib/Data/Time/Format/Format/Class.hs b/lib/Data/Time/Format/Format/Class.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Format/Format/Class.hs @@ -0,0 +1,349 @@ +module Data.Time.Format.Format.Class + ( + -- * Formatting + formatTime, + FormatNumericPadding, + FormatOptions(..), + FormatTime(..), + ShowPadded,PadOption, + formatGeneral,formatString,formatNumber,formatNumberStd, + showPaddedFixed,showPaddedFixedFraction, + quotBy,remBy, + ) + where + +import Data.Char +import Data.Maybe +import Data.Fixed +import Data.Time.Calendar.Private +import Data.Time.Format.Locale + +type FormatNumericPadding = Maybe Char + +data FormatOptions = MkFormatOptions { + foLocale :: TimeLocale, + foPadding :: Maybe FormatNumericPadding, + foWidth :: Maybe Int +} + +-- +class FormatTime t where + formatCharacter :: Bool -> Char -> Maybe (FormatOptions -> t -> String) + + +-- the weird UNIX logic is here +getPadOption :: Bool -> Bool -> Int -> Char -> Maybe FormatNumericPadding -> Maybe Int -> PadOption +getPadOption trunc fdef idef cdef mnpad mi = let + c = case mnpad of + Just (Just c') -> c' + Just Nothing -> ' ' + _ -> cdef + i = case mi of + Just i' -> case mnpad of + Just Nothing -> i' + _ -> if trunc then i' else max i' idef + Nothing -> idef + f = case mi of + Just _ -> True + Nothing -> case mnpad of + Nothing -> fdef + Just Nothing -> False + Just (Just _) -> True + in if f then Pad i c else NoPad + +formatGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String) +formatGeneral trunc fdef idef cdef ff fo = ff (foLocale fo) $ getPadOption trunc fdef idef cdef (foPadding fo) (foWidth fo) + +formatString :: (TimeLocale -> t -> String) -> (FormatOptions -> t -> String) +formatString ff = formatGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale + +formatNumber :: (ShowPadded i) => Bool -> Int -> Char -> (t -> i) -> (FormatOptions -> t -> String) +formatNumber fdef idef cdef ff = formatGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff + +formatNumberStd :: Int -> (t -> Integer) -> (FormatOptions -> t -> String) +formatNumberStd n = formatNumber False n '0' + +showPaddedFixed :: HasResolution a => PadOption -> PadOption -> Fixed a -> String +showPaddedFixed padn padf x | x < 0 = '-' : showPaddedFixed padn padf (negate x) +showPaddedFixed padn padf x = let + ns = showPaddedNum padn $ (floor x :: Integer) + fs = showPaddedFixedFraction padf x + ds = if null fs then "" else "." + in ns ++ ds ++ fs + +showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String +showPaddedFixedFraction pado x = let + digits = dropWhile (=='.') $ dropWhile (/='.') $ showFixed True x + n = length digits + in case pado of + NoPad -> digits + Pad i c -> if i < n + then take i digits + else digits ++ replicate (i - n) c + + +-- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'. +-- +-- The general form is @%\\\\@, where @\@, @\@, and @\@ are optional. +-- +-- == @\@ +-- glibc-style modifiers can be used before the specifier (here marked as @z@): +-- +-- [@%-z@] no padding +-- +-- [@%_z@] pad with spaces +-- +-- [@%0z@] pad with zeros +-- +-- [@%^z@] convert to upper case +-- +-- [@%#z@] convert to lower case (consistently, unlike glibc) +-- +-- == @\@ +-- Width digits can also be used after any modifiers and before the specifier (here marked as @z@), for example: +-- +-- [@%4z@] pad to 4 characters (with default padding character) +-- +-- [@%_12z@] pad with spaces to 12 characters +-- +-- == @\@ +-- An optional @E@ character indicates an alternate formatting. Currently this only affects @%Z@ and @%z@. +-- +-- [@%Ez@] alternate formatting +-- +-- == @\@ +-- +-- For all types (note these three are done by 'formatTime', not by 'formatCharacter'): +-- +-- [@%%@] @%@ +-- +-- [@%t@] tab +-- +-- [@%n@] newline +-- +-- === 'TimeZone' +-- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'): +-- +-- [@%z@] timezone offset in the format @±HHMM@ +-- +-- [@%Ez@] timezone offset in the format @±HH:MM@ +-- +-- [@%Z@] timezone name (or else offset in the format @±HHMM@) +-- +-- [@%EZ@] timezone name (or else offset in the format @±HH:MM@) +-- +-- === 'LocalTime' +-- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): +-- +-- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@) +-- +-- === 'TimeOfDay' +-- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): +-- +-- [@%R@] same as @%H:%M@ +-- +-- [@%T@] same as @%H:%M:%S@ +-- +-- [@%X@] as 'timeFmt' @locale@ (e.g. @%H:%M:%S@) +-- +-- [@%r@] as 'time12Fmt' @locale@ (e.g. @%I:%M:%S %p@) +-- +-- [@%P@] day-half of day from ('amPm' @locale@), converted to lowercase, @am@, @pm@ +-- +-- [@%p@] day-half of day from ('amPm' @locale@), @AM@, @PM@ +-- +-- [@%H@] hour of day (24-hour), 0-padded to two chars, @00@ - @23@ +-- +-- [@%k@] hour of day (24-hour), space-padded to two chars, @ 0@ - @23@ +-- +-- [@%I@] hour of day-half (12-hour), 0-padded to two chars, @01@ - @12@ +-- +-- [@%l@] hour of day-half (12-hour), space-padded to two chars, @ 1@ - @12@ +-- +-- [@%M@] minute of hour, 0-padded to two chars, @00@ - @59@ +-- +-- [@%S@] second of minute (without decimal part), 0-padded to two chars, @00@ - @60@ +-- +-- [@%q@] picosecond of second, 0-padded to twelve chars, @000000000000@ - @999999999999@. +-- +-- [@%Q@] decimal point and fraction of second, up to 12 second decimals, without trailing zeros. +-- For a whole number of seconds, @%Q@ omits the decimal point unless padding is specified. +-- +-- === 'UTCTime' and 'ZonedTime' +-- For 'UTCTime' and 'ZonedTime': +-- +-- [@%s@] number of whole seconds since the Unix epoch. For times before +-- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@ +-- the decimals are positive, not negative. For example, 0.9 seconds +-- before the Unix epoch is formatted as @-1.1@ with @%s%Q@. +-- +-- === 'DayOfWeek' +-- For 'DayOfWeek' (and 'Day' and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): +-- +-- [@%u@] day of week number for Week Date format, @1@ (= Monday) - @7@ (= Sunday) +-- +-- [@%w@] day of week number, @0@ (= Sunday) - @6@ (= Saturday) +-- +-- [@%a@] day of week, short form ('snd' from 'wDays' @locale@), @Sun@ - @Sat@ +-- +-- [@%A@] day of week, long form ('fst' from 'wDays' @locale@), @Sunday@ - @Saturday@ +-- +-- === 'Day' +-- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): +-- +-- [@%D@] same as @%m\/%d\/%y@ +-- +-- [@%F@] same as @%Y-%m-%d@ +-- +-- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@) +-- +-- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars +-- +-- [@%y@] year of century, 0-padded to two chars, @00@ - @99@ +-- +-- [@%C@] century, no padding. Note @%0C@ and @%_C@ pad to two chars +-- +-- [@%B@] month name, long form ('fst' from 'months' @locale@), @January@ - @December@ +-- +-- [@%b@, @%h@] month name, short form ('snd' from 'months' @locale@), @Jan@ - @Dec@ +-- +-- [@%m@] month of year, 0-padded to two chars, @01@ - @12@ +-- +-- [@%d@] day of month, 0-padded to two chars, @01@ - @31@ +-- +-- [@%e@] day of month, space-padded to two chars, @ 1@ - @31@ +-- +-- [@%j@] day of year, 0-padded to three chars, @001@ - @366@ +-- +-- [@%f@] century for Week Date format, no padding. Note @%0f@ and @%_f@ pad to two chars +-- +-- [@%V@] week of year for Week Date format, 0-padded to two chars, @01@ - @53@ +-- +-- [@%U@] week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, @00@ - @53@ +-- +-- [@%W@] week of year where weeks start on Monday (as 'mondayStartWeek'), 0-padded to two chars, @00@ - @53@ +-- +-- == Duration types +-- The specifiers for 'DiffTime', 'NominalDiffTime', 'CalendarDiffDays', and 'CalendarDiffTime' are semantically +-- separate from the other types. +-- Specifiers on negative time differences will generally be negative (think 'rem' rather than 'mod'). +-- +-- === 'NominalDiffTime' and 'DiffTime' +-- Note that a "minute" of 'DiffTime' is simply 60 SI seconds, rather than a minute of civil time. +-- Use 'NominalDiffTime' to work with civil time, ignoring any leap seconds. +-- +-- For 'NominalDiffTime' and 'DiffTime': +-- +-- [@%w@] total whole weeks +-- +-- [@%d@] total whole days +-- +-- [@%D@] whole days of week +-- +-- [@%h@] total whole hours +-- +-- [@%H@] whole hours of day +-- +-- [@%m@] total whole minutes +-- +-- [@%M@] whole minutes of hour +-- +-- [@%s@] total whole seconds +-- +-- [@%Es@] total seconds, with decimal point and up to \ (default 12) decimal places, without trailing zeros. +-- For a whole number of seconds, @%Es@ omits the decimal point unless padding is specified. +-- +-- [@%0Es@] total seconds, with decimal point and \ (default 12) decimal places. +-- +-- [@%S@] whole seconds of minute +-- +-- [@%ES@] seconds of minute, with decimal point and up to \ (default 12) decimal places, without trailing zeros. +-- For a whole number of seconds, @%ES@ omits the decimal point unless padding is specified. +-- +-- [@%0ES@] seconds of minute as two digits, with decimal point and \ (default 12) decimal places. +-- +-- === 'CalendarDiffDays' +-- For 'CalendarDiffDays' (and 'CalendarDiffTime'): +-- +-- [@%y@] total years +-- +-- [@%b@] total months +-- +-- [@%B@] months of year +-- +-- [@%w@] total weeks, not including months +-- +-- [@%d@] total days, not including months +-- +-- [@%D@] days of week +-- +-- === 'CalendarDiffTime' +-- For 'CalendarDiffTime': +-- +-- [@%h@] total hours, not including months +-- +-- [@%H@] hours of day +-- +-- [@%m@] total minutes, not including months +-- +-- [@%M@] minutes of hour +-- +-- [@%s@] total whole seconds, not including months +-- +-- [@%Es@] total seconds, not including months, with decimal point and up to \ (default 12) decimal places, without trailing zeros. +-- For a whole number of seconds, @%Es@ omits the decimal point unless padding is specified. +-- +-- [@%0Es@] total seconds, not including months, with decimal point and \ (default 12) decimal places. +-- +-- [@%S@] whole seconds of minute +-- +-- [@%ES@] seconds of minute, with decimal point and up to \ (default 12) decimal places, without trailing zeros. +-- For a whole number of seconds, @%ES@ omits the decimal point unless padding is specified. +-- +-- [@%0ES@] seconds of minute as two digits, with decimal point and \ (default 12) decimal places. +formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String +formatTime _ [] _ = "" +formatTime locale ('%':cs) t = case formatTime1 locale cs t of + Just result -> result + Nothing -> '%':(formatTime locale cs t) +formatTime locale (c:cs) t = c:(formatTime locale cs t) + +formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String +formatTime1 locale ('_':cs) t = formatTime2 locale id (Just (Just ' ')) cs t +formatTime1 locale ('-':cs) t = formatTime2 locale id (Just Nothing) cs t +formatTime1 locale ('0':cs) t = formatTime2 locale id (Just (Just '0')) cs t +formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t +formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t +formatTime1 locale cs t = formatTime2 locale id Nothing cs t + +getDigit :: Char -> Maybe Int +getDigit c | c < '0' = Nothing +getDigit c | c > '9' = Nothing +getDigit c = Just $ (ord c) - (ord '0') + +pullNumber :: Maybe Int -> String -> (Maybe Int,String) +pullNumber mx [] = (mx,[]) +pullNumber mx s@(c:cs) = case getDigit c of + Just i -> pullNumber (Just $ (fromMaybe 0 mx)*10+i) cs + Nothing -> (mx,s) + +formatTime2 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String +formatTime2 locale recase mpad cs t = let + (mwidth,rest) = pullNumber Nothing cs + in formatTime3 locale recase mpad mwidth rest t + +formatTime3 :: (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> Maybe Int -> String -> t -> Maybe String +formatTime3 locale recase mpad mwidth ('E':cs) = formatTime4 True recase (MkFormatOptions locale mpad mwidth) cs +formatTime3 locale recase mpad mwidth cs = formatTime4 False recase (MkFormatOptions locale mpad mwidth) cs + +formatTime4 :: (FormatTime t) => Bool -> (String -> String) -> FormatOptions -> String -> t -> Maybe String +formatTime4 alt recase fo (c:cs) t = Just $ (recase (formatChar alt c fo t)) ++ (formatTime (foLocale fo) cs t) +formatTime4 _alt _recase _fo [] _t = Nothing + +formatChar :: (FormatTime t) => Bool -> Char -> FormatOptions -> t -> String +formatChar _ '%' = formatString $ \_ _ -> "%" +formatChar _ 't' = formatString $ \_ _ -> "\t" +formatChar _ 'n' = formatString $ \_ _ -> "\n" +formatChar alt c = case formatCharacter alt c of + Just f -> f + _ -> \_ _ -> "" diff --git a/lib/Data/Time/Format/Format/Instances.hs b/lib/Data/Time/Format/Format/Instances.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Format/Format/Instances.hs @@ -0,0 +1,188 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Data.Time.Format.Format.Instances () where + +import Data.Char +import Data.Fixed +import Data.Time.Clock.Internal.DiffTime +import Data.Time.Clock.Internal.NominalDiffTime +import Data.Time.Clock.Internal.UniversalTime +import Data.Time.Clock.Internal.UTCTime +import Data.Time.Clock.POSIX +import Data.Time.Calendar.Days +import Data.Time.Calendar.CalendarDiffDays +import Data.Time.Calendar.Gregorian +import Data.Time.Calendar.Week +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.OrdinalDate +import Data.Time.Calendar.Private +import Data.Time.LocalTime.Internal.CalendarDiffTime +import Data.Time.LocalTime.Internal.TimeZone +import Data.Time.LocalTime.Internal.TimeOfDay +import Data.Time.LocalTime.Internal.LocalTime +import Data.Time.LocalTime.Internal.ZonedTime +import Data.Time.Format.Locale +import Data.Time.Format.Format.Class + + +instance FormatTime LocalTime where + formatCharacter _ 'c' = Just $ \fo -> formatTime (foLocale fo) $ dateTimeFmt $ foLocale fo + formatCharacter alt c = case formatCharacter alt c of + Just f -> Just $ \fo dt -> f fo (localDay dt) + Nothing -> case formatCharacter alt c of + Just f -> Just $ \fo dt -> f fo (localTimeOfDay dt) + Nothing -> Nothing + +todAMPM :: TimeLocale -> TimeOfDay -> String +todAMPM locale day = let + (am,pm) = amPm locale + in if (todHour day) < 12 then am else pm + +tod12Hour :: TimeOfDay -> Int +tod12Hour day = (mod (todHour day - 1) 12) + 1 + +instance FormatTime TimeOfDay where + -- Aggregate + formatCharacter _ 'R' = Just $ formatString $ \locale -> formatTime locale "%H:%M" + formatCharacter _ 'T' = Just $ formatString $ \locale -> formatTime locale "%H:%M:%S" + formatCharacter _ 'X' = Just $ formatString $ \locale -> formatTime locale (timeFmt locale) + formatCharacter _ 'r' = Just $ formatString $ \locale -> formatTime locale (time12Fmt locale) + -- AM/PM + formatCharacter _ 'P' = Just $ formatString $ \locale -> map toLower . todAMPM locale + formatCharacter _ 'p' = Just $ formatString $ \locale -> todAMPM locale + -- Hour + formatCharacter _ 'H' = Just $ formatNumber True 2 '0' todHour + formatCharacter _ 'I' = Just $ formatNumber True 2 '0' tod12Hour + formatCharacter _ 'k' = Just $ formatNumber True 2 ' ' todHour + formatCharacter _ 'l' = Just $ formatNumber True 2 ' ' tod12Hour + -- Minute + formatCharacter _ 'M' = Just $ formatNumber True 2 '0' todMin + -- Second + formatCharacter _ 'S' = Just $ formatNumber True 2 '0' $ (floor . todSec :: TimeOfDay -> Int) + formatCharacter _ 'q' = Just $ formatGeneral True True 12 '0' $ \_ pado -> showPaddedFixedFraction pado . todSec + formatCharacter _ 'Q' = Just $ formatGeneral True False 12 '0' $ \_ pado -> dotNonEmpty . showPaddedFixedFraction pado . todSec where + dotNonEmpty "" = "" + dotNonEmpty s = '.':s + + -- Default + formatCharacter _ _ = Nothing + +instance FormatTime ZonedTime where + formatCharacter _ 'c' = Just $ formatString $ \locale -> formatTime locale (dateTimeFmt locale) + formatCharacter _ 's' = Just $ formatNumber True 1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer) + formatCharacter alt c = case formatCharacter alt c of + Just f -> Just $ \fo dt -> f fo (zonedTimeToLocalTime dt) + Nothing -> case formatCharacter alt c of + Just f -> Just $ \fo dt -> f fo (zonedTimeZone dt) + Nothing -> Nothing + +instance FormatTime TimeZone where + formatCharacter False 'z' = Just $ formatGeneral False True 4 '0' $ \_ -> timeZoneOffsetString'' False + formatCharacter True 'z' = Just $ formatGeneral False True 5 '0' $ \_ -> timeZoneOffsetString'' True + formatCharacter alt 'Z' = Just $ \fo z -> let + n = timeZoneName z + idef = if alt then 5 else 4 + in if null n then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z else formatString (\_ -> timeZoneName) fo z + formatCharacter _ _ = Nothing + +instance FormatTime DayOfWeek where + formatCharacter _ 'u' = Just $ formatNumber True 1 '0' $ fromEnum + formatCharacter _ 'w' = Just $ formatNumber True 1 '0' $ \wd -> (mod (fromEnum wd) 7) + formatCharacter _ 'a' = Just $ formatString $ \locale wd -> snd $ (wDays locale) !! (mod (fromEnum wd) 7) + formatCharacter _ 'A' = Just $ formatString $ \locale wd -> fst $ (wDays locale) !! (mod (fromEnum wd) 7) + formatCharacter _ _ = Nothing + +instance FormatTime Day where + -- Aggregate + formatCharacter _ 'D' = Just $ formatString $ \locale -> formatTime locale "%m/%d/%y" + formatCharacter _ 'F' = Just $ formatString $ \locale -> formatTime locale "%Y-%m-%d" + formatCharacter _ 'x' = Just $ formatString $ \locale -> formatTime locale (dateFmt locale) + + -- Year Count + formatCharacter _ 'Y' = Just $ formatNumber False 4 '0' $ fst . toOrdinalDate + formatCharacter _ 'y' = Just $ formatNumber True 2 '0' $ mod100 . fst . toOrdinalDate + formatCharacter _ 'C' = Just $ formatNumber False 2 '0' $ div100 . fst . toOrdinalDate + -- Month of Year + formatCharacter _ 'B' = Just $ formatString $ \locale -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian + formatCharacter _ 'b' = Just $ formatString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian + formatCharacter _ 'h' = Just $ formatString $ \locale -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian + formatCharacter _ 'm' = Just $ formatNumber True 2 '0' $ (\(_,m,_) -> m) . toGregorian + -- Day of Month + formatCharacter _ 'd' = Just $ formatNumber True 2 '0' $ (\(_,_,d) -> d) . toGregorian + formatCharacter _ 'e' = Just $ formatNumber True 2 ' ' $ (\(_,_,d) -> d) . toGregorian + -- Day of Year + formatCharacter _ 'j' = Just $ formatNumber True 3 '0' $ snd . toOrdinalDate + + -- ISO 8601 Week Date + formatCharacter _ 'G' = Just $ formatNumber False 4 '0' $ (\(y,_,_) -> y) . toWeekDate + formatCharacter _ 'g' = Just $ formatNumber True 2 '0' $ mod100 . (\(y,_,_) -> y) . toWeekDate + formatCharacter _ 'f' = Just $ formatNumber False 2 '0' $ div100 . (\(y,_,_) -> y) . toWeekDate + + formatCharacter _ 'V' = Just $ formatNumber True 2 '0' $ (\(_,w,_) -> w) . toWeekDate + formatCharacter _ 'u' = Just $ formatNumber True 1 '0' $ (\(_,_,d) -> d) . toWeekDate + + -- Day of week + formatCharacter _ 'a' = Just $ formatString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek + formatCharacter _ 'A' = Just $ formatString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek + formatCharacter _ 'U' = Just $ formatNumber True 2 '0' $ fst . sundayStartWeek + formatCharacter _ 'w' = Just $ formatNumber True 1 '0' $ snd . sundayStartWeek + formatCharacter _ 'W' = Just $ formatNumber True 2 '0' $ fst . mondayStartWeek + + -- Default + formatCharacter _ _ = Nothing + +instance FormatTime UTCTime where + formatCharacter alt c = fmap (\f fo t -> f fo (utcToZonedTime utc t)) (formatCharacter alt c) + +instance FormatTime UniversalTime where + formatCharacter alt c = fmap (\f fo t -> f fo (ut1ToLocalTime 0 t)) (formatCharacter alt c) + +instance FormatTime NominalDiffTime where + formatCharacter _ 'w' = Just $ formatNumberStd 1 $ quotBy $ 7 * 86400 + formatCharacter _ 'd' = Just $ formatNumberStd 1 $ quotBy 86400 + formatCharacter _ 'D' = Just $ formatNumberStd 1 $ remBy 7 . quotBy 86400 + formatCharacter _ 'h' = Just $ formatNumberStd 1 $ quotBy 3600 + formatCharacter _ 'H' = Just $ formatNumberStd 2 $ remBy 24 . quotBy 3600 + formatCharacter _ 'm' = Just $ formatNumberStd 1 $ quotBy 60 + formatCharacter _ 'M' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 60 + formatCharacter False 's' = Just $ formatNumberStd 1 $ quotBy 1 + formatCharacter True 's' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> showPaddedFixed NoPad padf (realToFrac t :: Pico) + formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 + formatCharacter True 'S' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> let + padn = case padf of + NoPad -> NoPad + Pad _ c -> Pad 2 c + in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) + formatCharacter _ _ = Nothing + +instance FormatTime DiffTime where + formatCharacter _ 'w' = Just $ formatNumberStd 1 $ quotBy $ 7 * 86400 + formatCharacter _ 'd' = Just $ formatNumberStd 1 $ quotBy 86400 + formatCharacter _ 'D' = Just $ formatNumberStd 1 $ remBy 7 . quotBy 86400 + formatCharacter _ 'h' = Just $ formatNumberStd 1 $ quotBy 3600 + formatCharacter _ 'H' = Just $ formatNumberStd 2 $ remBy 24 . quotBy 3600 + formatCharacter _ 'm' = Just $ formatNumberStd 1 $ quotBy 60 + formatCharacter _ 'M' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 60 + formatCharacter False 's' = Just $ formatNumberStd 1 $ quotBy 1 + formatCharacter True 's' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> showPaddedFixed NoPad padf (realToFrac t :: Pico) + formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 + formatCharacter True 'S' = Just $ formatGeneral False False 12 '0' $ \_ padf t -> let + padn = case padf of + NoPad -> NoPad + Pad _ c -> Pad 2 c + in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) + formatCharacter _ _ = Nothing + +instance FormatTime CalendarDiffDays where + formatCharacter _ 'y' = Just $ formatNumberStd 1 $ quotBy 12 . cdMonths + formatCharacter _ 'b' = Just $ formatNumberStd 1 $ cdMonths + formatCharacter _ 'B' = Just $ formatNumberStd 2 $ remBy 12 . cdMonths + formatCharacter _ 'w' = Just $ formatNumberStd 1 $ quotBy 7 . cdDays + formatCharacter _ 'd' = Just $ formatNumberStd 1 $ cdDays + formatCharacter _ 'D' = Just $ formatNumberStd 1 $ remBy 7 . cdDays + formatCharacter _ _ = Nothing + +instance FormatTime CalendarDiffTime where + formatCharacter _ 'y' = Just $ formatNumberStd 1 $ quotBy 12 . ctMonths + formatCharacter _ 'b' = Just $ formatNumberStd 1 $ ctMonths + formatCharacter _ 'B' = Just $ formatNumberStd 2 $ remBy 12 . ctMonths + formatCharacter alt c = fmap (\f fo t -> f fo (ctTime t)) (formatCharacter alt c) diff --git a/lib/Data/Time/Format/ISO8601.hs b/lib/Data/Time/Format/ISO8601.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Format/ISO8601.hs @@ -0,0 +1,388 @@ +module Data.Time.Format.ISO8601 + ( + -- * Format + Format, + formatShowM, + formatShow, + formatReadP, + formatParseM, + -- * Common formats + ISO8601(..), + iso8601Show, + iso8601ParseM, + -- * All formats + FormatExtension(..), + formatReadPExtension, + parseFormatExtension, + calendarFormat, + yearMonthFormat, + yearFormat, + centuryFormat, + expandedCalendarFormat, + expandedYearMonthFormat, + expandedYearFormat, + expandedCenturyFormat, + ordinalDateFormat, + expandedOrdinalDateFormat, + weekDateFormat, + yearWeekFormat, + expandedWeekDateFormat, + expandedYearWeekFormat, + timeOfDayFormat, + hourMinuteFormat, + hourFormat, + withTimeDesignator, + withUTCDesignator, + timeOffsetFormat, + timeOfDayAndOffsetFormat, + localTimeFormat, + zonedTimeFormat, + utcTimeFormat, + dayAndTimeFormat, + timeAndOffsetFormat, + durationDaysFormat, + durationTimeFormat, + alternativeDurationDaysFormat, + alternativeDurationTimeFormat, + intervalFormat, + recurringIntervalFormat, + ) where + +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +import Prelude hiding (fail) +#endif +#if MIN_VERSION_base(4,8,0) +#else +import Data.Monoid +#endif +import Data.Ratio +import Data.Fixed +import Text.ParserCombinators.ReadP +import Data.Format +import Data.Time +import Data.Time.Calendar.OrdinalDate +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.Private + +data FormatExtension = + -- | ISO 8601:2004(E) sec. 2.3.4. Use hyphens and colons. + ExtendedFormat | + -- | ISO 8601:2004(E) sec. 2.3.3. Omit hyphens and colons. "The basic format should be avoided in plain text." + BasicFormat + +-- | Read a value in either extended or basic format +formatReadPExtension :: (FormatExtension -> Format t) -> ReadP t +formatReadPExtension ff = formatReadP (ff ExtendedFormat) +++ formatReadP (ff BasicFormat) + +-- | Parse a value in either extended or basic format +parseFormatExtension :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ) => (FormatExtension -> Format t) -> String -> m t +parseFormatExtension ff = parseReader $ formatReadPExtension ff + +sepFormat :: String -> Format a -> Format b -> Format (a,b) +sepFormat sep fa fb = (fa <** literalFormat sep) <**> fb + +dashFormat :: Format a -> Format b -> Format (a,b) +dashFormat = sepFormat "-" + +colnFormat :: Format a -> Format b -> Format (a,b) +colnFormat = sepFormat ":" + +extDashFormat :: FormatExtension -> Format a -> Format b -> Format (a,b) +extDashFormat ExtendedFormat = dashFormat +extDashFormat BasicFormat = (<**>) + +extColonFormat :: FormatExtension -> Format a -> Format b -> Format (a,b) +extColonFormat ExtendedFormat = colnFormat +extColonFormat BasicFormat = (<**>) + +expandedYearFormat' :: Int -> Format Integer +expandedYearFormat' n = integerFormat PosNegSign (Just n) + +yearFormat' :: Format Integer +yearFormat' = integerFormat NegSign (Just 4) + +monthFormat :: Format Int +monthFormat = integerFormat NoSign (Just 2) + +dayOfMonthFormat :: Format Int +dayOfMonthFormat = integerFormat NoSign (Just 2) + +dayOfYearFormat :: Format Int +dayOfYearFormat = integerFormat NoSign (Just 3) + +weekOfYearFormat :: Format Int +weekOfYearFormat = literalFormat "W" **> integerFormat NoSign (Just 2) + +dayOfWeekFormat :: Format Int +dayOfWeekFormat = integerFormat NoSign (Just 1) + +hourFormat' :: Format Int +hourFormat' = integerFormat NoSign (Just 2) + +data E14 +instance HasResolution E14 where + resolution _ = 100000000000000 +data E16 +instance HasResolution E16 where + resolution _ = 10000000000000000 + +hourDecimalFormat :: Format (Fixed E16) -- need four extra decimal places for hours +hourDecimalFormat = decimalFormat NoSign (Just 2) + +minuteFormat :: Format Int +minuteFormat = integerFormat NoSign (Just 2) + +minuteDecimalFormat :: Format (Fixed E14) -- need two extra decimal places for minutes +minuteDecimalFormat = decimalFormat NoSign (Just 2) + +secondFormat :: Format Pico +secondFormat = decimalFormat NoSign (Just 2) + +mapGregorian :: Format (Integer,(Int,Int)) -> Format Day +mapGregorian = mapMFormat (\(y,(m,d)) -> fromGregorianValid y m d) (\day -> (\(y,m,d) -> Just (y,(m,d))) $ toGregorian day) + +mapOrdinalDate :: Format (Integer,Int) -> Format Day +mapOrdinalDate = mapMFormat (\(y,d) -> fromOrdinalDateValid y d) (Just . toOrdinalDate) + +mapWeekDate :: Format (Integer,(Int,Int)) -> Format Day +mapWeekDate = mapMFormat (\(y,(w,d)) -> fromWeekDateValid y w d) (\day -> (\(y,w,d) -> Just (y,(w,d))) $ toWeekDate day) + +mapTimeOfDay :: Format (Int,(Int,Pico)) -> Format TimeOfDay +mapTimeOfDay = mapMFormat (\(h,(m,s)) -> makeTimeOfDayValid h m s) (\(TimeOfDay h m s) -> Just (h,(m,s))) + + +-- | ISO 8601:2004(E) sec. 4.1.2.2 +calendarFormat :: FormatExtension -> Format Day +calendarFormat fe = mapGregorian $ extDashFormat fe yearFormat $ extDashFormat fe monthFormat dayOfMonthFormat + +-- | ISO 8601:2004(E) sec. 4.1.2.3(a) +yearMonthFormat :: Format (Integer,Int) +yearMonthFormat = yearFormat <**> literalFormat "-" **> monthFormat + +-- | ISO 8601:2004(E) sec. 4.1.2.3(b) +yearFormat :: Format Integer +yearFormat = yearFormat' + +-- | ISO 8601:2004(E) sec. 4.1.2.3(c) +centuryFormat :: Format Integer +centuryFormat = integerFormat NegSign (Just 2) + +-- | ISO 8601:2004(E) sec. 4.1.2.4(a) +expandedCalendarFormat :: Int -> FormatExtension -> Format Day +expandedCalendarFormat n fe = mapGregorian $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe monthFormat dayOfMonthFormat + +-- | ISO 8601:2004(E) sec. 4.1.2.4(b) +expandedYearMonthFormat :: Int -> Format (Integer,Int) +expandedYearMonthFormat n = dashFormat (expandedYearFormat n) monthFormat + +-- | ISO 8601:2004(E) sec. 4.1.2.4(c) +expandedYearFormat :: Int -> Format Integer +expandedYearFormat = expandedYearFormat' + +-- | ISO 8601:2004(E) sec. 4.1.2.4(d) +expandedCenturyFormat :: Int -> Format Integer +expandedCenturyFormat n = integerFormat PosNegSign (Just n) + +-- | ISO 8601:2004(E) sec. 4.1.3.2 +ordinalDateFormat :: FormatExtension -> Format Day +ordinalDateFormat fe = mapOrdinalDate $ extDashFormat fe yearFormat dayOfYearFormat + +-- | ISO 8601:2004(E) sec. 4.1.3.3 +expandedOrdinalDateFormat :: Int -> FormatExtension -> Format Day +expandedOrdinalDateFormat n fe = mapOrdinalDate $ extDashFormat fe (expandedYearFormat n) dayOfYearFormat + +-- | ISO 8601:2004(E) sec. 4.1.4.2 +weekDateFormat :: FormatExtension -> Format Day +weekDateFormat fe = mapWeekDate $ extDashFormat fe yearFormat $ extDashFormat fe weekOfYearFormat dayOfWeekFormat + +-- | ISO 8601:2004(E) sec. 4.1.4.3 +yearWeekFormat :: FormatExtension -> Format (Integer,Int) +yearWeekFormat fe = extDashFormat fe yearFormat weekOfYearFormat + +-- | ISO 8601:2004(E) sec. 4.1.4.2 +expandedWeekDateFormat :: Int -> FormatExtension -> Format Day +expandedWeekDateFormat n fe = mapWeekDate $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe weekOfYearFormat dayOfWeekFormat + +-- | ISO 8601:2004(E) sec. 4.1.4.3 +expandedYearWeekFormat :: Int -> FormatExtension -> Format (Integer,Int) +expandedYearWeekFormat n fe = extDashFormat fe (expandedYearFormat n) weekOfYearFormat + +-- | ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a) +timeOfDayFormat :: FormatExtension -> Format TimeOfDay +timeOfDayFormat fe = mapTimeOfDay $ extColonFormat fe hourFormat' $ extColonFormat fe minuteFormat secondFormat + +-- workaround for the 'fromRational' in 'Fixed', which uses 'floor' instead of 'round' +fromRationalRound :: Rational -> NominalDiffTime +fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000 + +-- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b) +hourMinuteFormat :: FormatExtension -> Format TimeOfDay +hourMinuteFormat fe = let + toTOD (h,m) = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of + (0,tod) -> Just tod + _ -> Nothing + fromTOD tod = let + mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60 + in Just $ quotRemBy 60 mm + in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat + +-- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c) +hourFormat :: Format TimeOfDay +hourFormat = let + toTOD h = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of + (0,tod) -> Just tod + _ -> Nothing + fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600 + in mapMFormat toTOD fromTOD $ hourDecimalFormat + +-- | ISO 8601:2004(E) sec. 4.2.2.5 +withTimeDesignator :: Format t -> Format t +withTimeDesignator f = literalFormat "T" **> f + +-- | ISO 8601:2004(E) sec. 4.2.4 +withUTCDesignator :: Format t -> Format t +withUTCDesignator f = f <** literalFormat "Z" + +-- | ISO 8601:2004(E) sec. 4.2.5.1 +timeOffsetFormat :: FormatExtension -> Format TimeZone +timeOffsetFormat fe = let + toTimeZone (sign,(h,m)) = minutesToTimeZone $ sign * (h * 60 + m) + fromTimeZone tz = let + mm = timeZoneMinutes tz + hm = quotRem (abs mm) 60 + in (signum mm,hm) + in isoMap toTimeZone fromTimeZone $ + mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (Just 2)) (integerFormat NoSign (Just 2)) + +-- | ISO 8601:2004(E) sec. 4.2.5.2 +timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay,TimeZone) +timeOfDayAndOffsetFormat fe = timeOfDayFormat fe <**> timeOffsetFormat fe + +-- | ISO 8601:2004(E) sec. 4.3.2 +localTimeFormat :: Format Day -> Format TimeOfDay -> Format LocalTime +localTimeFormat fday ftod = isoMap (\(day,tod) -> LocalTime day tod) (\(LocalTime day tod) -> (day,tod)) $ fday <**> withTimeDesignator ftod + +-- | ISO 8601:2004(E) sec. 4.3.2 +zonedTimeFormat :: Format Day -> Format TimeOfDay -> FormatExtension -> Format ZonedTime +zonedTimeFormat fday ftod fe = isoMap (\(lt,tz) -> ZonedTime lt tz) (\(ZonedTime lt tz) -> (lt,tz)) $ timeAndOffsetFormat (localTimeFormat fday ftod) fe + +-- | ISO 8601:2004(E) sec. 4.3.2 +utcTimeFormat :: Format Day -> Format TimeOfDay -> Format UTCTime +utcTimeFormat fday ftod = isoMap (localTimeToUTC utc) (utcToLocalTime utc) $ withUTCDesignator $ localTimeFormat fday ftod + +-- | ISO 8601:2004(E) sec. 4.3.3 +dayAndTimeFormat :: Format Day -> Format time -> Format (Day,time) +dayAndTimeFormat fday ft = fday <**> withTimeDesignator ft + +-- | ISO 8601:2004(E) sec. 4.3.3 +timeAndOffsetFormat :: Format t -> FormatExtension -> Format (t,TimeZone) +timeAndOffsetFormat ft fe = ft <**> timeOffsetFormat fe + +intDesignator :: (Eq t,Show t,Read t,Num t) => Char -> Format t +intDesignator c = optionalFormat 0 $ integerFormat NoSign Nothing <** literalFormat [c] + +decDesignator :: (Eq t,Show t,Read t,Num t) => Char -> Format t +decDesignator c = optionalFormat 0 $ decimalFormat NoSign Nothing <** literalFormat [c] + +daysDesigs :: Format CalendarDiffDays +daysDesigs = let + toCD (y,(m,(w,d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d) + fromCD (CalendarDiffDays mm d) = (quot mm 12,(rem mm 12,(0,d))) + in isoMap toCD fromCD $ + intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D' + +-- | ISO 8601:2004(E) sec. 4.4.3.2 +durationDaysFormat :: Format CalendarDiffDays +durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty,"0D") $ daysDesigs + +-- | ISO 8601:2004(E) sec. 4.4.3.2 +durationTimeFormat :: Format CalendarDiffTime +durationTimeFormat = let + toCT (cd,(h,(m,s))) = mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) + fromCT (CalendarDiffTime mm t) = let + (d,TimeOfDay h m s) = timeToDaysAndTimeOfDay t + in (CalendarDiffDays mm d,(h,(m,s))) + in (**>) (literalFormat "P") $ specialCaseShowFormat (mempty,"0D") $ isoMap toCT fromCT $ + (<**>) daysDesigs $ optionalFormat (0,(0,0)) $ literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S' + +-- | ISO 8601:2004(E) sec. 4.4.3.3 +alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays +alternativeDurationDaysFormat fe = let + toCD (y,(m,d)) = CalendarDiffDays (y * 12 + m) d + fromCD (CalendarDiffDays mm d) = (quot mm 12,(rem mm 12,d)) + in isoMap toCD fromCD $ (**>) (literalFormat "P") $ + extDashFormat fe (clipFormat (0,9999) $ integerFormat NegSign $ Just 4) $ + extDashFormat fe (clipFormat (0,12) $ integerFormat NegSign $ Just 2) $ + (clipFormat (0,30) $ integerFormat NegSign $ Just 2) + +-- | ISO 8601:2004(E) sec. 4.4.3.3 +alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime +alternativeDurationTimeFormat fe = let + toCT (cd,(h,(m,s))) = mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) + fromCT (CalendarDiffTime mm t) = let + (d,TimeOfDay h m s) = timeToDaysAndTimeOfDay t + in (CalendarDiffDays mm d,(h,(m,s))) + in isoMap toCT fromCT $ + (<**>) (alternativeDurationDaysFormat fe) $ + withTimeDesignator $ + extColonFormat fe (clipFormat (0,24) $ integerFormat NegSign (Just 2)) $ + extColonFormat fe (clipFormat (0,60) $ integerFormat NegSign (Just 2)) $ + (clipFormat (0,60) $ decimalFormat NegSign (Just 2)) + +-- | ISO 8601:2004(E) sec. 4.4.4.1 +intervalFormat :: Format a -> Format b -> Format (a,b) +intervalFormat = sepFormat "/" + +-- | ISO 8601:2004(E) sec. 4.5 +recurringIntervalFormat :: Format a -> Format b -> Format (Int,a,b) +recurringIntervalFormat fa fb = isoMap (\(r,(a,b)) -> (r,a,b)) (\(r,a,b) -> (r,(a,b))) $ sepFormat "/" (literalFormat "R" **> integerFormat NoSign Nothing) $ intervalFormat fa fb + +class ISO8601 t where + -- | The most commonly used ISO 8601 format for this type. + iso8601Format :: Format t + +-- | Show in the most commonly used ISO 8601 format. +iso8601Show :: ISO8601 t => t -> String +iso8601Show = formatShow iso8601Format + +-- | Parse the most commonly used ISO 8601 format. +iso8601ParseM :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ,ISO8601 t) => String -> m t +iso8601ParseM = formatParseM iso8601Format + +-- | @yyyy-mm-dd@ (ISO 8601:2004(E) sec. 4.1.2.2 extended format) +instance ISO8601 Day where + iso8601Format = calendarFormat ExtendedFormat +-- | @hh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a) extended format) +instance ISO8601 TimeOfDay where + iso8601Format = timeOfDayFormat ExtendedFormat +-- | @±hh:mm@ (ISO 8601:2004(E) sec. 4.2.5.1 extended format) +instance ISO8601 TimeZone where + iso8601Format = timeOffsetFormat ExtendedFormat +-- | @yyyy-mm-ddThh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 LocalTime where + iso8601Format = localTimeFormat iso8601Format iso8601Format +-- | @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 ZonedTime where + iso8601Format = zonedTimeFormat iso8601Format iso8601Format ExtendedFormat +-- | @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +instance ISO8601 UTCTime where + iso8601Format = utcTimeFormat iso8601Format iso8601Format +-- | @PyYmMdD@ (ISO 8601:2004(E) sec. 4.4.3.2) +instance ISO8601 CalendarDiffDays where + iso8601Format = durationDaysFormat +-- | @PyYmMdDThHmMs[.sss]S@ (ISO 8601:2004(E) sec. 4.4.3.2) +instance ISO8601 CalendarDiffTime where + iso8601Format = durationTimeFormat diff --git a/lib/Data/Time/Format/Locale.hs b/lib/Data/Time/Format/Locale.hs --- a/lib/Data/Time/Format/Locale.hs +++ b/lib/Data/Time/Format/Locale.hs @@ -32,7 +32,7 @@ -- -- 'knownTimeZones' contains only the ten time-zones mentioned in RFC 822 sec. 5: -- \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\". --- Note that the parsing functions will regardless parse single-letter military time-zones and +HHMM format. +-- Note that the parsing functions will regardless parse "UTC", single-letter military time-zones, and +HHMM format. defaultTimeLocale :: TimeLocale defaultTimeLocale = TimeLocale { wDays = [("Sunday", "Sun"), ("Monday", "Mon"), diff --git a/lib/Data/Time/Format/Parse.hs b/lib/Data/Time/Format/Parse.hs --- a/lib/Data/Time/Format/Parse.hs +++ b/lib/Data/Time/Format/Parse.hs @@ -1,86 +1,38 @@ {-# OPTIONS -fno-warn-orphans #-} -#include "HsConfigure.h" - --- #hide module Data.Time.Format.Parse ( -- * UNIX-style parsing -#if LANGUAGE_Rank2Types parseTimeM, parseTimeOrError, readSTime, readPTime, parseTime, readTime, readsTime, -#endif - ParseTime(..), + ParseTime(), -- * Locale module Data.Time.Format.Locale ) where -import Text.Read(readMaybe) +import Data.Proxy +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +import Prelude hiding (fail) +#endif +import Data.Char +import Data.Time.Format.Locale +import Text.ParserCombinators.ReadP hiding (char, string) import Data.Time.Clock.Internal.UniversalTime -import Data.Time.Clock.POSIX import Data.Time.Clock.Internal.UTCTime import Data.Time.Calendar.Days -import Data.Time.Calendar.Gregorian -import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.WeekDate -import Data.Time.Calendar.Private(clipValid) import Data.Time.LocalTime.Internal.TimeZone import Data.Time.LocalTime.Internal.TimeOfDay import Data.Time.LocalTime.Internal.LocalTime import Data.Time.LocalTime.Internal.ZonedTime - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>),(<*>)) -#endif -#if LANGUAGE_Rank2Types -import Control.Monad -#endif -import Data.Char -import Data.Fixed -import Data.List -import Data.Maybe -import Data.Ratio -import Data.Time.Format.Locale -#if LANGUAGE_Rank2Types -import Text.ParserCombinators.ReadP hiding (char, string) -#endif - -#if LANGUAGE_Rank2Types --- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'. -char :: Char -> ReadP Char -char c = satisfy (\x -> toUpper c == toUpper x) --- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'. -string :: String -> ReadP String -string this = do s <- look; scan this s - where - scan [] _ = do return this - scan (x:xs) (y:ys) | toUpper x == toUpper y = do _ <- get; scan xs ys - scan _ _ = do pfail -#endif --- | Convert string to upper case. -up :: String -> String -up = map toUpper - - --- | The class of types which can be parsed given a UNIX-style time format --- string. -class ParseTime t where - -- | Builds a time value from a parsed input string. - -- If the input does not include all the information needed to - -- construct a complete value, any missing parts should be taken - -- from 1970-01-01 00:00:00 +0000 (which was a Thursday). - -- In the absence of @%C@ or @%Y@, century is 1969 - 2068. - buildTime :: TimeLocale -- ^ The time locale. - -> [(Char,String)] -- ^ Pairs of format characters and the - -- corresponding part of the input. - -> Maybe t +import Data.Time.Format.Parse.Class +import Data.Time.Format.Parse.Instances() -#if LANGUAGE_Rank2Types -- | Parses a time value given a format string. -- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers, however padding widths are not supported. -- Case is not significant in the input string. -- Some variations in the input are accepted: -- --- [@%z@] accepts any of @-HHMM@ or @-HH:MM@. +-- [@%z@] accepts any of @±HHMM@ or @±HH:MM@. -- -- [@%Z@] accepts any string of letters, or any of the formats accepted by @%z@. -- @@ -99,7 +51,13 @@ -- > Prelude Data.Time> parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2010-3-04" :: Maybe Day -- > Just 2010-03-04 -- -parseTimeM :: (Monad m,ParseTime t) => +parseTimeM :: ( +#if MIN_VERSION_base(4,9,0) + MonadFail m +#else + Monad m +#endif + ,ParseTime t) => Bool -- ^ Accept leading and trailing whitespace? -> TimeLocale -- ^ Time locale. -> String -- ^ Format string. @@ -150,16 +108,19 @@ readPTime False l f = readPOnlyTime l f readPTime True l f = (skipSpaces >> readPOnlyTime l f) <++ readPOnlyTime l f +readPOnlyTime' :: ParseTime t => proxy t -> TimeLocale -> String -> ReadP t +readPOnlyTime' pt l f = do + pairs <- parseSpecifiers pt l f + case buildTime l pairs of + Just t -> return t + Nothing -> pfail + -- | Parse a time value given a format string (without allowing leading whitespace). See 'parseTimeM' for details. readPOnlyTime :: ParseTime t => TimeLocale -- ^ Time locale. -> String -- ^ Format string -> ReadP t -readPOnlyTime l f = do - mt <- liftM (buildTime l) (parseInput l (parseFormat l f)) - case mt of - Just t -> return t - Nothing -> pfail +readPOnlyTime = readPOnlyTime' Proxy {-# DEPRECATED parseTime "use \"parseTimeM True\" instead" #-} parseTime :: ParseTime t => @@ -185,427 +146,8 @@ -> ReadS t readsTime = readSTime True - --- --- * Internals --- - -data Padding = NoPadding | SpacePadding | ZeroPadding - deriving Show - -type DateFormat = [DateFormatSpec] - -data DateFormatSpec = Value (Maybe Padding) Char - | WhiteSpace - | Literal Char - deriving Show - -parseFormat :: TimeLocale -> String -> DateFormat -parseFormat l = p - where p "" = [] - p ('%': '-' : c :cs) = (pc (Just NoPadding) c) ++ p cs - p ('%': '_' : c :cs) = (pc (Just SpacePadding) c) ++ p cs - p ('%': '0' : c :cs) = (pc (Just ZeroPadding) c) ++ p cs - p ('%': c :cs) = (pc Nothing c) ++ p cs - p (c:cs) | isSpace c = WhiteSpace : p cs - p (c:cs) = Literal c : p cs - pc _ 'c' = p (dateTimeFmt l) - pc _ 'R' = p "%H:%M" - pc _ 'T' = p "%H:%M:%S" - pc _ 'X' = p (timeFmt l) - pc _ 'r' = p (time12Fmt l) - pc _ 'D' = p "%m/%d/%y" - pc _ 'F' = p "%Y-%m-%d" - pc _ 'x' = p (dateFmt l) - pc _ 'h' = p "%b" - pc _ '%' = [Literal '%'] - pc mpad c = [Value mpad c] - -parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)] -parseInput _ [] = return [] -parseInput l (Value mpad c:ff) = do - s <- parseValue l mpad c - r <- parseInput l ff - return ((c,s):r) -parseInput l (Literal c:ff) = do - _ <- char c - parseInput l ff -parseInput l (WhiteSpace:ff) = do - _ <- satisfy isSpace - case ff of - (WhiteSpace:_) -> return () - _ -> skipSpaces - parseInput l ff - --- | Get the string corresponding to the given format specifier. -parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String -parseValue l mpad c = - case c of - -- century - 'C' -> digits SpacePadding 2 - 'f' -> digits SpacePadding 2 - - -- year - 'Y' -> digits SpacePadding 4 - 'G' -> digits SpacePadding 4 - - -- year of century - 'y' -> digits ZeroPadding 2 - 'g' -> digits ZeroPadding 2 - - -- month of year - 'B' -> oneOf (map fst (months l)) - 'b' -> oneOf (map snd (months l)) - 'm' -> digits ZeroPadding 2 - - -- day of month - 'd' -> digits ZeroPadding 2 - 'e' -> digits SpacePadding 2 - - -- week of year - 'V' -> digits ZeroPadding 2 - 'U' -> digits ZeroPadding 2 - 'W' -> digits ZeroPadding 2 - - -- day of week - 'u' -> oneOf $ map (:[]) ['1'..'7'] - 'a' -> oneOf (map snd (wDays l)) - 'A' -> oneOf (map fst (wDays l)) - 'w' -> oneOf $ map (:[]) ['0'..'6'] - - -- day of year - 'j' -> digits ZeroPadding 3 - - -- dayhalf of day (i.e. AM or PM) - 'P' -> oneOf (let (am,pm) = amPm l in [am, pm]) - 'p' -> oneOf (let (am,pm) = amPm l in [am, pm]) - - -- hour of day (i.e. 24h) - 'H' -> digits ZeroPadding 2 - 'k' -> digits SpacePadding 2 - - -- hour of dayhalf (i.e. 12h) - 'I' -> digits ZeroPadding 2 - 'l' -> digits SpacePadding 2 - - -- minute of hour - 'M' -> digits ZeroPadding 2 - - -- second of minute - 'S' -> digits ZeroPadding 2 - - -- picosecond of second - 'q' -> digits ZeroPadding 12 - 'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return "" - - -- time zone - 'z' -> numericTZ - 'Z' -> munch1 isAlpha <++ - numericTZ <++ - return "" -- produced by %Z for LocalTime - - -- seconds since epoch - 's' -> (char '-' >> liftM ('-':) (munch1 isDigit)) - <++ munch1 isDigit - - _ -> fail $ "Unknown format character: " ++ show c - where - oneOf = choice . map string - digitsforce ZeroPadding n = count n (satisfy isDigit) - digitsforce SpacePadding _n = skipSpaces >> many1 (satisfy isDigit) - digitsforce NoPadding _n = many1 (satisfy isDigit) - digits pad = digitsforce (fromMaybe pad mpad) - numericTZ = do s <- choice [char '+', char '-'] - h <- digitsforce ZeroPadding 2 - optional (char ':') - m <- digitsforce ZeroPadding 2 - return (s:h++m) -#endif - --- --- * Instances for the time package types --- - -data DayComponent = Century Integer -- century of all years - | CenturyYear Integer -- 0-99, last two digits of both real years and week years - | YearMonth Int -- 1-12 - | MonthDay Int -- 1-31 - | YearDay Int -- 1-366 - | WeekDay Int -- 1-7 (mon-sun) - | YearWeek WeekType Int -- 1-53 or 0-53 - -data WeekType = ISOWeek | SundayWeek | MondayWeek - -instance ParseTime Day where - buildTime l = let - - -- 'Nothing' indicates a parse failure, - -- while 'Just []' means no information - f :: Char -> String -> Maybe [DayComponent] - f c x = let - ra :: (Read a) => Maybe a - ra = readMaybe x - - zeroBasedListIndex :: [String] -> Maybe Int - zeroBasedListIndex ss = elemIndex (up x) $ fmap up ss - - oneBasedListIndex :: [String] -> Maybe Int - oneBasedListIndex ss = do - index <- zeroBasedListIndex ss - return $ 1 + index - - in case c of - -- %C: century (all but the last two digits of the year), 00 - 99 - 'C' -> do - a <- ra - return [Century a] - -- %f century (all but the last two digits of the year), 00 - 99 - 'f' -> do - a <- ra - return [Century a] - -- %Y: year - 'Y' -> do - a <- ra - return [Century (a `div` 100), CenturyYear (a `mod` 100)] - -- %G: year for Week Date format - 'G' -> do - a <- ra - return [Century (a `div` 100), CenturyYear (a `mod` 100)] - -- %y: last two digits of year, 00 - 99 - 'y' -> do - a <- ra - return [CenturyYear a] - -- %g: last two digits of year for Week Date format, 00 - 99 - 'g' -> do - a <- ra - return [CenturyYear a] - -- %B: month name, long form (fst from months locale), January - December - 'B' -> do - a <- oneBasedListIndex $ fmap fst $ months l - return [YearMonth a] - -- %b: month name, short form (snd from months locale), Jan - Dec - 'b' -> do - a <- oneBasedListIndex $ fmap snd $ months l - return [YearMonth a] - -- %m: month of year, leading 0 as needed, 01 - 12 - 'm' -> do - raw <- ra - a <- clipValid 1 12 raw - return [YearMonth a] - -- %d: day of month, leading 0 as needed, 01 - 31 - 'd' -> do - raw <- ra - a <- clipValid 1 31 raw - return [MonthDay a] - -- %e: day of month, leading space as needed, 1 - 31 - 'e' -> do - raw <- ra - a <- clipValid 1 31 raw - return [MonthDay a] - -- %V: week for Week Date format, 01 - 53 - 'V' -> do - raw <- ra - a <- clipValid 1 53 raw - return [YearWeek ISOWeek a] - -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 - 'U' -> do - raw <- ra - a <- clipValid 0 53 raw - return [YearWeek SundayWeek a] - -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 - 'W' -> do - raw <- ra - a <- clipValid 0 53 raw - return [YearWeek MondayWeek a] - -- %u: day for Week Date format, 1 - 7 - 'u' -> do - raw <- ra - a <- clipValid 1 7 raw - return [WeekDay a] - -- %a: day of week, short form (snd from wDays locale), Sun - Sat - 'a' -> do - a' <- zeroBasedListIndex $ fmap snd $ wDays l - let a = if a' == 0 then 7 else a' - return [WeekDay a] - -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday - 'A' -> do - a' <- zeroBasedListIndex $ fmap fst $ wDays l - let a = if a' == 0 then 7 else a' - return [WeekDay a] - -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) - 'w' -> do - raw <- ra - a' <- clipValid 0 6 raw - let a = if a' == 0 then 7 else a' - return [WeekDay a] - -- %j: day of year for Ordinal Date format, 001 - 366 - 'j' -> do - raw <- ra - a <- clipValid 1 366 raw - return [YearDay a] - -- unrecognised, pass on to other parsers - _ -> return [] - - buildDay :: [DayComponent] -> Maybe Day - buildDay cs = let - safeLast x xs = last (x:xs) - y = let - d = safeLast 70 [x | CenturyYear x <- cs] - c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] - in 100 * c + d - rest (YearMonth m:_) = let - d = safeLast 1 [x | MonthDay x <- cs] - in fromGregorianValid y m d - rest (YearDay d:_) = fromOrdinalDateValid y d - rest (YearWeek wt w:_) = let - d = safeLast 4 [x | WeekDay x <- cs] - in case wt of - ISOWeek -> fromWeekDateValid y w d - SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) - MondayWeek -> fromMondayStartWeekValid y w d - rest (_:xs) = rest xs - rest [] = rest [YearMonth 1] - - in rest cs - - in \pairs -> do - components <- mapM (uncurry f) pairs - buildDay $ concat components - -mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a -mfoldl f = let - mf ma b = do - a <- ma - f a b - in foldl mf - -instance ParseTime TimeOfDay where - buildTime l = let - f t@(TimeOfDay h m s) (c,x) = let - ra :: (Read a) => Maybe a - ra = readMaybe x - - getAmPm = let - upx = up x - (amStr,pmStr) = amPm l - in if upx == amStr - then Just $ TimeOfDay (h `mod` 12) m s - else if upx == pmStr - then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s - else Nothing - - in case c of - 'P' -> getAmPm - 'p' -> getAmPm - 'H' -> do - a <- ra - return $ TimeOfDay a m s - 'I' -> do - a <- ra - return $ TimeOfDay a m s - 'k' -> do - a <- ra - return $ TimeOfDay a m s - 'l' -> do - a <- ra - return $ TimeOfDay a m s - 'M' -> do - a <- ra - return $ TimeOfDay h a s - 'S' -> do - a <- ra - return $ TimeOfDay h m (fromInteger a) - 'q' -> do - a <- ra - return $ TimeOfDay h m (mkPico (floor s) a) - 'Q' -> if null x then Just t else do - ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x - return $ TimeOfDay h m (mkPico (floor s) ps) - _ -> Just t - - in mfoldl f (Just midnight) - -rpad :: Int -> a -> [a] -> [a] -rpad n c xs = xs ++ replicate (n - length xs) c - -mkPico :: Integer -> Integer -> Pico -mkPico i f = fromInteger i + fromRational (f % 1000000000000) - -instance ParseTime LocalTime where - buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs) - -enumDiff :: (Enum a) => a -> a -> Int -enumDiff a b = (fromEnum a) - (fromEnum b) - -getMilZoneHours :: Char -> Maybe Int -getMilZoneHours c | c < 'A' = Nothing -getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A' -getMilZoneHours 'J' = Nothing -getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K' -getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1 -getMilZoneHours 'Z' = Just 0 -getMilZoneHours _ = Nothing - -getMilZone :: Char -> Maybe TimeZone -getMilZone c = let - yc = toUpper c - in do - hours <- getMilZoneHours yc - return $ TimeZone (hours * 60) False [yc] - -getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone -getKnownTimeZone locale x = find (\tz -> up x == timeZoneName tz) (knownTimeZones locale) - -instance ParseTime TimeZone where - buildTime l = let - f (TimeZone _ dst name) ('z',x) | Just offset <- readTzOffset x = TimeZone offset dst name - f t ('Z',"") = t - f _ ('Z',x) | Just zone <- getKnownTimeZone l x = zone - f _ ('Z',[c]) | Just zone <- getMilZone c = zone - f (TimeZone offset dst _) ('Z',x) | isAlpha (head x) = TimeZone offset dst (up x) - f (TimeZone _ dst name) ('Z',x) | Just offset <- readTzOffset x = TimeZone offset dst name - f t _ = t - in Just . foldl f (minutesToTimeZone 0) - -readTzOffset :: String -> Maybe Int -readTzOffset str = let - - getSign '+' = Just 1 - getSign '-' = Just (-1) - getSign _ = Nothing - - calc s h1 h2 m1 m2 = do - sign <- getSign s - h <- readMaybe [h1,h2] - m <- readMaybe [m1,m2] - return $ sign * (60 * h + m) - - in case str of - (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2 - (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2 - _ -> Nothing - -instance ParseTime ZonedTime where - buildTime l xs = let - f (ZonedTime (LocalTime _ tod) z) ('s',x) = do - a <- readMaybe x - let - s = fromInteger a - (_,ps) = properFraction (todSec tod) :: (Integer,Pico) - s' = s + fromRational (toRational ps) - return $ utcToZonedTime z (posixSecondsToUTCTime s') - f t _ = Just t - in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs - -instance ParseTime UTCTime where - buildTime l xs = zonedTimeToUTC <$> buildTime l xs - -instance ParseTime UniversalTime where - buildTime l xs = localTimeToUT1 0 <$> buildTime l xs - -- * Read instances for time package types -#if LANGUAGE_Rank2Types instance Read Day where readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Y-%m-%d" @@ -627,4 +169,3 @@ instance Read UniversalTime where readsPrec n s = [ (localTimeToUT1 0 t, r) | (t,r) <- readsPrec n s ] -#endif diff --git a/lib/Data/Time/Format/Parse/Class.hs b/lib/Data/Time/Format/Parse/Class.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Format/Parse/Class.hs @@ -0,0 +1,220 @@ +module Data.Time.Format.Parse.Class + ( + -- * Parsing + ParseNumericPadding(..), + ParseTime(..), + parseSpecifiers, + timeSubstituteTimeSpecifier, + timeParseTimeSpecifier, + durationParseTimeSpecifier, + ) + where + +import Control.Applicative hiding (optional,many) +import Data.Char +import Data.Maybe +import Data.Time.Format.Locale +import Text.ParserCombinators.ReadP + +data ParseNumericPadding = NoPadding | SpacePadding | ZeroPadding + +-- | The class of types which can be parsed given a UNIX-style time format +-- string. +class ParseTime t where + substituteTimeSpecifier :: proxy t -> TimeLocale -> Char -> Maybe String + substituteTimeSpecifier _ _ _ = Nothing + -- | Get the string corresponding to the given format specifier. + parseTimeSpecifier :: proxy t -> TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String + -- | Builds a time value from a parsed input string. + -- If the input does not include all the information needed to + -- construct a complete value, any missing parts should be taken + -- from 1970-01-01 00:00:00 +0000 (which was a Thursday). + -- In the absence of @%C@ or @%Y@, century is 1969 - 2068. + buildTime :: TimeLocale -- ^ The time locale. + -> [(Char,String)] -- ^ Pairs of format characters and the + -- corresponding part of the input. + -> Maybe t + +-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'. +charCI :: Char -> ReadP Char +charCI c = satisfy (\x -> toUpper c == toUpper x) + +-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'. +stringCI :: String -> ReadP String +stringCI this = do + let + scan [] _ = return this + scan (x:xs) (y:ys) | toUpper x == toUpper y = do + _ <- get + scan xs ys + scan _ _ = pfail + s <- look + scan this s + +parseSpecifiers :: ParseTime t => proxy t -> TimeLocale -> String -> ReadP [(Char,String)] +parseSpecifiers pt locale = let + parse :: String -> ReadP [(Char,String)] + parse [] = return [] + parse ('%':cs) = parse1 cs + parse (c:cs) | isSpace c = do + _ <- satisfy isSpace + case cs of + (c':_) | isSpace c' -> return () + _ -> skipSpaces + parse cs + parse (c:cs) = do + _ <- charCI c + parse cs + + parse1 :: String -> ReadP [(Char,String)] + parse1 ('-':cs) = parse2 (Just NoPadding) cs + parse1 ('_':cs) = parse2 (Just SpacePadding) cs + parse1 ('0':cs) = parse2 (Just ZeroPadding) cs + parse1 cs = parse2 Nothing cs + + parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char,String)] + parse2 mpad ('E':cs) = parse3 mpad True cs + parse2 mpad cs = parse3 mpad False cs + + parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char,String)] + parse3 _ _ ('%':cs) = do + _ <- char '%' + parse cs + parse3 _ _ (c:cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs + parse3 mpad _alt (c:cs) = do + str <- parseTimeSpecifier pt locale mpad c + specs <- parse cs + return $ (c,str) : specs + parse3 _ _ [] = return [] + in parse + +parsePaddedDigits :: ParseNumericPadding -> Int -> ReadP String +parsePaddedDigits ZeroPadding n = count n (satisfy isDigit) +parsePaddedDigits SpacePadding _n = skipSpaces >> many1 (satisfy isDigit) +parsePaddedDigits NoPadding _n = many1 (satisfy isDigit) + +parsePaddedSignedDigits :: ParseNumericPadding -> Int -> ReadP String +parsePaddedSignedDigits pad n = do + sign <- option "" $ char '-' >> return "-" + digits <- parsePaddedDigits pad n + return $ sign ++ digits + +parseSignedDecimal :: ReadP String +parseSignedDecimal = do + sign <- option "" $ char '-' >> return "-" + skipSpaces + digits <- many1 $ satisfy isDigit + decimaldigits <- option "" $ do + _ <- char '.' + dd <- many $ satisfy isDigit + return $ '.':dd + return $ sign ++ digits ++ decimaldigits + +timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String +timeParseTimeSpecifier l mpad c = let + digits pad = parsePaddedDigits (fromMaybe pad mpad) + oneOf = choice . map stringCI + numericTZ = do + s <- choice [char '+', char '-'] + h <- parsePaddedDigits ZeroPadding 2 + optional (char ':') + m <- parsePaddedDigits ZeroPadding 2 + return (s:h++m) + in case c of + -- century + 'C' -> digits SpacePadding 2 + 'f' -> digits SpacePadding 2 + + -- year + 'Y' -> digits SpacePadding 4 + 'G' -> digits SpacePadding 4 + + -- year of century + 'y' -> digits ZeroPadding 2 + 'g' -> digits ZeroPadding 2 + + -- month of year + 'B' -> oneOf (map fst (months l)) + 'b' -> oneOf (map snd (months l)) + 'm' -> digits ZeroPadding 2 + + -- day of month + 'd' -> digits ZeroPadding 2 + 'e' -> digits SpacePadding 2 + + -- week of year + 'V' -> digits ZeroPadding 2 + 'U' -> digits ZeroPadding 2 + 'W' -> digits ZeroPadding 2 + + -- day of week + 'u' -> oneOf $ map (:[]) ['1'..'7'] + 'a' -> oneOf (map snd (wDays l)) + 'A' -> oneOf (map fst (wDays l)) + 'w' -> oneOf $ map (:[]) ['0'..'6'] + + -- day of year + 'j' -> digits ZeroPadding 3 + + -- dayhalf of day (i.e. AM or PM) + 'P' -> oneOf (let (am,pm) = amPm l in [am, pm]) + 'p' -> oneOf (let (am,pm) = amPm l in [am, pm]) + + -- hour of day (i.e. 24h) + 'H' -> digits ZeroPadding 2 + 'k' -> digits SpacePadding 2 + + -- hour of dayhalf (i.e. 12h) + 'I' -> digits ZeroPadding 2 + 'l' -> digits SpacePadding 2 + + -- minute of hour + 'M' -> digits ZeroPadding 2 + + -- second of minute + 'S' -> digits ZeroPadding 2 + + -- picosecond of second + 'q' -> digits ZeroPadding 12 + 'Q' -> liftA2 (:) (char '.') (munch isDigit) <++ return "" + + -- time zone + 'z' -> numericTZ + 'Z' -> munch1 isAlpha <++ + numericTZ + + -- seconds since epoch + 's' -> (char '-' >> fmap ('-':) (munch1 isDigit)) + <++ munch1 isDigit + + _ -> fail $ "Unknown format character: " ++ show c + +timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String +timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l +timeSubstituteTimeSpecifier _ 'R' = Just "%H:%M" +timeSubstituteTimeSpecifier _ 'T' = Just "%H:%M:%S" +timeSubstituteTimeSpecifier l 'X' = Just $ timeFmt l +timeSubstituteTimeSpecifier l 'r' = Just $ time12Fmt l +timeSubstituteTimeSpecifier _ 'D' = Just "%m/%d/%y" +timeSubstituteTimeSpecifier _ 'F' = Just "%Y-%m-%d" +timeSubstituteTimeSpecifier l 'x' = Just $ dateFmt l +timeSubstituteTimeSpecifier _ 'h' = Just "%b" +timeSubstituteTimeSpecifier _ _ = Nothing + +durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String +durationParseTimeSpecifier _ mpad c = let + padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad + in case c of + 'y' -> padopt 1 + 'b' -> padopt 1 + 'B' -> padopt 2 + 'w' -> padopt 1 + 'd' -> padopt 1 + 'D' -> padopt 1 + 'h' -> padopt 1 + 'H' -> padopt 2 + 'm' -> padopt 1 + 'M' -> padopt 2 + 's' -> parseSignedDecimal + 'S' -> parseSignedDecimal + _ -> fail $ "Unknown format character: " ++ show c diff --git a/lib/Data/Time/Format/Parse/Instances.hs b/lib/Data/Time/Format/Parse/Instances.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Format/Parse/Instances.hs @@ -0,0 +1,392 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Data.Time.Format.Parse.Instances() where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>),(<*>)) +#endif +import Data.Char +import Data.Fixed +import Data.List +import Data.Ratio +import Data.Traversable +import Text.Read(readMaybe) +import Data.Time.Clock.Internal.DiffTime +import Data.Time.Clock.Internal.NominalDiffTime +import Data.Time.Clock.Internal.UniversalTime +import Data.Time.Clock.POSIX +import Data.Time.Clock.Internal.UTCTime +import Data.Time.Calendar.Days +import Data.Time.Calendar.Gregorian +import Data.Time.Calendar.CalendarDiffDays +import Data.Time.Calendar.OrdinalDate +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.Private(clipValid) +import Data.Time.LocalTime.Internal.CalendarDiffTime +import Data.Time.LocalTime.Internal.TimeZone +import Data.Time.LocalTime.Internal.TimeOfDay +import Data.Time.LocalTime.Internal.LocalTime +import Data.Time.LocalTime.Internal.ZonedTime +import Data.Time.Format.Locale +import Data.Time.Format.Parse.Class + +data DayComponent = Century Integer -- century of all years + | CenturyYear Integer -- 0-99, last two digits of both real years and week years + | YearMonth Int -- 1-12 + | MonthDay Int -- 1-31 + | YearDay Int -- 1-366 + | WeekDay Int -- 1-7 (mon-sun) + | YearWeek WeekType Int -- 1-53 or 0-53 + +data WeekType = ISOWeek | SundayWeek | MondayWeek + +instance ParseTime Day where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l = let + + -- 'Nothing' indicates a parse failure, + -- while 'Just []' means no information + f :: Char -> String -> Maybe [DayComponent] + f c x = let + ra :: (Read a) => Maybe a + ra = readMaybe x + + zeroBasedListIndex :: [String] -> Maybe Int + zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss + + oneBasedListIndex :: [String] -> Maybe Int + oneBasedListIndex ss = do + index <- zeroBasedListIndex ss + return $ 1 + index + + in case c of + -- %C: century (all but the last two digits of the year), 00 - 99 + 'C' -> do + a <- ra + return [Century a] + -- %f century (all but the last two digits of the year), 00 - 99 + 'f' -> do + a <- ra + return [Century a] + -- %Y: year + 'Y' -> do + a <- ra + return [Century (a `div` 100), CenturyYear (a `mod` 100)] + -- %G: year for Week Date format + 'G' -> do + a <- ra + return [Century (a `div` 100), CenturyYear (a `mod` 100)] + -- %y: last two digits of year, 00 - 99 + 'y' -> do + a <- ra + return [CenturyYear a] + -- %g: last two digits of year for Week Date format, 00 - 99 + 'g' -> do + a <- ra + return [CenturyYear a] + -- %B: month name, long form (fst from months locale), January - December + 'B' -> do + a <- oneBasedListIndex $ fmap fst $ months l + return [YearMonth a] + -- %b: month name, short form (snd from months locale), Jan - Dec + 'b' -> do + a <- oneBasedListIndex $ fmap snd $ months l + return [YearMonth a] + -- %m: month of year, leading 0 as needed, 01 - 12 + 'm' -> do + raw <- ra + a <- clipValid 1 12 raw + return [YearMonth a] + -- %d: day of month, leading 0 as needed, 01 - 31 + 'd' -> do + raw <- ra + a <- clipValid 1 31 raw + return [MonthDay a] + -- %e: day of month, leading space as needed, 1 - 31 + 'e' -> do + raw <- ra + a <- clipValid 1 31 raw + return [MonthDay a] + -- %V: week for Week Date format, 01 - 53 + 'V' -> do + raw <- ra + a <- clipValid 1 53 raw + return [YearWeek ISOWeek a] + -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 + 'U' -> do + raw <- ra + a <- clipValid 0 53 raw + return [YearWeek SundayWeek a] + -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 + 'W' -> do + raw <- ra + a <- clipValid 0 53 raw + return [YearWeek MondayWeek a] + -- %u: day for Week Date format, 1 - 7 + 'u' -> do + raw <- ra + a <- clipValid 1 7 raw + return [WeekDay a] + -- %a: day of week, short form (snd from wDays locale), Sun - Sat + 'a' -> do + a' <- zeroBasedListIndex $ fmap snd $ wDays l + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday + 'A' -> do + a' <- zeroBasedListIndex $ fmap fst $ wDays l + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) + 'w' -> do + raw <- ra + a' <- clipValid 0 6 raw + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %j: day of year for Ordinal Date format, 001 - 366 + 'j' -> do + raw <- ra + a <- clipValid 1 366 raw + return [YearDay a] + -- unrecognised, pass on to other parsers + _ -> return [] + + buildDay :: [DayComponent] -> Maybe Day + buildDay cs = let + safeLast x xs = last (x:xs) + y = let + d = safeLast 70 [x | CenturyYear x <- cs] + c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] + in 100 * c + d + rest (YearMonth m:_) = let + d = safeLast 1 [x | MonthDay x <- cs] + in fromGregorianValid y m d + rest (YearDay d:_) = fromOrdinalDateValid y d + rest (YearWeek wt w:_) = let + d = safeLast 4 [x | WeekDay x <- cs] + in case wt of + ISOWeek -> fromWeekDateValid y w d + SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) + MondayWeek -> fromMondayStartWeekValid y w d + rest (_:xs) = rest xs + rest [] = rest [YearMonth 1] + + in rest cs + + in \pairs -> do + components <- for pairs $ \(c,x) -> f c x + buildDay $ concat components + +mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a +mfoldl f = let + mf ma b = do + a <- ma + f a b + in foldl mf + +instance ParseTime TimeOfDay where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l = let + f t@(TimeOfDay h m s) (c,x) = let + ra :: (Read a) => Maybe a + ra = readMaybe x + + getAmPm = let + upx = map toUpper x + (amStr,pmStr) = amPm l + in if upx == amStr + then Just $ TimeOfDay (h `mod` 12) m s + else if upx == pmStr + then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s + else Nothing + + in case c of + 'P' -> getAmPm + 'p' -> getAmPm + 'H' -> do + raw <- ra + a <- clipValid 0 23 raw + return $ TimeOfDay a m s + 'I' -> do + raw <- ra + a <- clipValid 1 12 raw + return $ TimeOfDay a m s + 'k' -> do + raw <- ra + a <- clipValid 0 23 raw + return $ TimeOfDay a m s + 'l' -> do + raw <- ra + a <- clipValid 1 12 raw + return $ TimeOfDay a m s + 'M' -> do + raw <- ra + a <- clipValid 0 59 raw + return $ TimeOfDay h a s + 'S' -> do + raw <- ra + a <- clipValid 0 60 raw + return $ TimeOfDay h m (fromInteger a) + 'q' -> do + a <- ra + return $ TimeOfDay h m (mkPico (floor s) a) + 'Q' -> if null x then Just t else do + ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x + return $ TimeOfDay h m (mkPico (floor s) ps) + _ -> Just t + + in mfoldl f (Just midnight) + +rpad :: Int -> a -> [a] -> [a] +rpad n c xs = xs ++ replicate (n - length xs) c + +mkPico :: Integer -> Integer -> Pico +mkPico i f = fromInteger i + fromRational (f % 1000000000000) + +instance ParseTime LocalTime where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs) + +enumDiff :: (Enum a) => a -> a -> Int +enumDiff a b = (fromEnum a) - (fromEnum b) + +getMilZoneHours :: Char -> Maybe Int +getMilZoneHours c | c < 'A' = Nothing +getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A' +getMilZoneHours 'J' = Nothing +getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K' +getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1 +getMilZoneHours 'Z' = Just 0 +getMilZoneHours _ = Nothing + +getMilZone :: Char -> Maybe TimeZone +getMilZone c = let + yc = toUpper c + in do + hours <- getMilZoneHours yc + return $ TimeZone (hours * 60) False [yc] + +getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone +getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale) + +instance ParseTime TimeZone where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l = let + f :: Char -> String -> TimeZone -> Maybe TimeZone + f 'z' str (TimeZone _ dst name) | Just offset <- readTzOffset str = Just $ TimeZone offset dst name + f 'z' _ _ = Nothing + f 'Z' str _ | Just offset <- readTzOffset str = Just $ TimeZone offset False "" + f 'Z' str _ | Just zone <- getKnownTimeZone l str = Just zone + f 'Z' "UTC" _ = Just utc + f 'Z' [c] _ | Just zone <- getMilZone c = Just zone + f 'Z' _ _ = Nothing + f _ _ tz = Just tz + in foldl (\mt (c,s) -> mt >>= f c s) (Just $ minutesToTimeZone 0) + +readTzOffset :: String -> Maybe Int +readTzOffset str = let + + getSign '+' = Just 1 + getSign '-' = Just (-1) + getSign _ = Nothing + + calc s h1 h2 m1 m2 = do + sign <- getSign s + h <- readMaybe [h1,h2] + m <- readMaybe [m1,m2] + return $ sign * (60 * h + m) + + in case str of + (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2 + (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2 + _ -> Nothing + +instance ParseTime ZonedTime where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l xs = let + f (ZonedTime (LocalTime _ tod) z) ('s',x) = do + a <- readMaybe x + let + s = fromInteger a + (_,ps) = properFraction (todSec tod) :: (Integer,Pico) + s' = s + fromRational (toRational ps) + return $ utcToZonedTime z (posixSecondsToUTCTime s') + f t _ = Just t + in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs + +instance ParseTime UTCTime where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l xs = zonedTimeToUTC <$> buildTime l xs + +instance ParseTime UniversalTime where + substituteTimeSpecifier _ = timeSubstituteTimeSpecifier + parseTimeSpecifier _ = timeParseTimeSpecifier + buildTime l xs = localTimeToUT1 0 <$> buildTime l xs + +buildTimeMonths :: [(Char,String)] -> Maybe Integer +buildTimeMonths xs = do + tt <- for xs $ \(c,s) -> case c of + 'y' -> fmap ((*) 12) $ readMaybe s + 'b' -> readMaybe s + 'B' -> readMaybe s + _ -> return 0 + return $ sum tt + +buildTimeDays :: [(Char,String)] -> Maybe Integer +buildTimeDays xs = do + tt <- for xs $ \(c,s) -> case c of + 'w' -> fmap ((*) 7) $ readMaybe s + 'd' -> readMaybe s + 'D' -> readMaybe s + _ -> return 0 + return $ sum tt + +buildTimeSeconds :: [(Char,String)] -> Maybe Pico +buildTimeSeconds xs = do + tt <- for xs $ \(c,s) -> let + readInt :: Integer -> Maybe Pico + readInt t = do + i <- readMaybe s + return $ fromInteger $ i * t + in case c of + 'h' -> readInt 3600 + 'H' -> readInt 3600 + 'm' -> readInt 60 + 'M' -> readInt 60 + 's' -> readMaybe s + 'S' -> readMaybe s + _ -> return 0 + return $ sum tt + +instance ParseTime NominalDiffTime where + parseTimeSpecifier _ = durationParseTimeSpecifier + buildTime _ xs = do + dd <- buildTimeDays xs + tt <- buildTimeSeconds xs + return $ (fromInteger dd * 86400) + realToFrac tt + +instance ParseTime DiffTime where + parseTimeSpecifier _ = durationParseTimeSpecifier + buildTime _ xs = do + dd <- buildTimeDays xs + tt <- buildTimeSeconds xs + return $ (fromInteger dd * 86400) + realToFrac tt + +instance ParseTime CalendarDiffDays where + parseTimeSpecifier _ = durationParseTimeSpecifier + buildTime _ xs = do + mm <- buildTimeMonths xs + dd <- buildTimeDays xs + return $ CalendarDiffDays mm dd + +instance ParseTime CalendarDiffTime where + parseTimeSpecifier _ = durationParseTimeSpecifier + buildTime locale xs = do + mm <- buildTimeMonths xs + tt <- buildTime locale xs + return $ CalendarDiffTime mm tt diff --git a/lib/Data/Time/LocalTime.hs b/lib/Data/Time/LocalTime.hs --- a/lib/Data/Time/LocalTime.hs +++ b/lib/Data/Time/LocalTime.hs @@ -7,6 +7,7 @@ getTimeZone,getCurrentTimeZone, module Data.Time.LocalTime.Internal.TimeOfDay, + module Data.Time.LocalTime.Internal.CalendarDiffTime, module Data.Time.LocalTime.Internal.LocalTime, module Data.Time.LocalTime.Internal.ZonedTime, ) where @@ -14,5 +15,6 @@ import Data.Time.Format() import Data.Time.LocalTime.Internal.TimeZone hiding (timeZoneOffsetString'') import Data.Time.LocalTime.Internal.TimeOfDay +import Data.Time.LocalTime.Internal.CalendarDiffTime import Data.Time.LocalTime.Internal.LocalTime import Data.Time.LocalTime.Internal.ZonedTime diff --git a/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs b/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs @@ -0,0 +1,46 @@ +module Data.Time.LocalTime.Internal.CalendarDiffTime + ( + -- * Calendar Duration + module Data.Time.LocalTime.Internal.CalendarDiffTime + ) where +#if MIN_VERSION_base(4,8,0) +#else +import Data.Monoid +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup hiding (option) +#endif +import Data.Fixed +import Data.Time.Calendar.CalendarDiffDays +import Data.Time.Clock.Internal.NominalDiffTime + +data CalendarDiffTime = CalendarDiffTime + { ctMonths :: Integer + , ctTime :: NominalDiffTime + } deriving (Eq) +#if MIN_VERSION_base(4,9,0) +-- | Additive +instance Semigroup CalendarDiffTime where + CalendarDiffTime m1 d1 <> CalendarDiffTime m2 d2 = CalendarDiffTime (m1 + m2) (d1 + d2) +#endif +-- | Additive +instance Monoid CalendarDiffTime where + mempty = CalendarDiffTime 0 0 +#if MIN_VERSION_base(4,9,0) + mappend = (<>) +#else + mappend (CalendarDiffTime m1 d1) (CalendarDiffTime m2 d2) = CalendarDiffTime (m1 + m2) (d1 + d2) +#endif + +instance Show CalendarDiffTime where + show (CalendarDiffTime m t) = "P" ++ show m ++ "MT" ++ showFixed True (realToFrac t :: Pico) ++ "S" + +calendarTimeDays :: CalendarDiffDays -> CalendarDiffTime +calendarTimeDays (CalendarDiffDays m d) = CalendarDiffTime m $ fromInteger d * nominalDay + +calendarTimeTime :: NominalDiffTime -> CalendarDiffTime +calendarTimeTime dt = CalendarDiffTime 0 dt + +-- | Scale by a factor. Note that @scaleCalendarDiffTime (-1)@ will not perfectly invert a duration, due to variable month lengths. +scaleCalendarDiffTime :: Integer -> CalendarDiffTime -> CalendarDiffTime +scaleCalendarDiffTime k (CalendarDiffTime m d) = CalendarDiffTime (k * m) (fromInteger k * d) diff --git a/lib/Data/Time/LocalTime/Internal/LocalTime.hs b/lib/Data/Time/LocalTime/Internal/LocalTime.hs --- a/lib/Data/Time/LocalTime/Internal/LocalTime.hs +++ b/lib/Data/Time/LocalTime/Internal/LocalTime.hs @@ -1,12 +1,12 @@ {-# OPTIONS -fno-warn-orphans #-} #include "HsConfigure.h" - --- #hide module Data.Time.LocalTime.Internal.LocalTime ( -- * Local Time LocalTime(..), + addLocalTime,diffLocalTime, + -- converting UTC and UT1 times to LocalTime utcToLocalTime,localTimeToUTC,ut1ToLocalTime,localTimeToUT1, ) where @@ -20,7 +20,9 @@ #endif import Data.Time.Calendar.Days import Data.Time.Calendar.Gregorian +import Data.Time.Clock.Internal.NominalDiffTime import Data.Time.Clock.Internal.UniversalTime +import Data.Time.Clock.Internal.UTCDiff import Data.Time.Clock.Internal.UTCTime import Data.Time.LocalTime.Internal.TimeOfDay import Data.Time.LocalTime.Internal.TimeZone @@ -48,6 +50,14 @@ instance Show LocalTime where show (LocalTime d t) = (showGregorian d) ++ " " ++ (show t) + +-- | addLocalTime a b = a + b +addLocalTime :: NominalDiffTime -> LocalTime -> LocalTime +addLocalTime x = utcToLocalTime utc . addUTCTime x . localTimeToUTC utc + +-- | diffLocalTime a b = a - b +diffLocalTime :: LocalTime -> LocalTime -> NominalDiffTime +diffLocalTime a b = diffUTCTime (localTimeToUTC utc a) (localTimeToUTC utc b) -- | Get the local time of a UTC time in a time zone. utcToLocalTime :: TimeZone -> UTCTime -> LocalTime diff --git a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs --- a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs @@ -1,10 +1,10 @@ {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h" --- #hide module Data.Time.LocalTime.Internal.TimeOfDay ( -- * Time of day TimeOfDay(..),midnight,midday,makeTimeOfDayValid, + timeToDaysAndTimeOfDay,daysAndTimeOfDayToTime, utcToLocalTimeOfDay,localToUTCTimeOfDay, timeToTimeOfDay,timeOfDayToTime, dayFractionToTimeOfDay,timeOfDayToDayFraction @@ -17,6 +17,7 @@ import Data.Data #endif import Data.Time.Clock.Internal.DiffTime +import Data.Time.Clock.Internal.NominalDiffTime import Data.Time.Calendar.Private import Data.Time.LocalTime.Internal.TimeZone @@ -60,6 +61,20 @@ _ <- clipValid 0 59 m _ <- clipValid 0 60.999999999999 s return (TimeOfDay h m s) + +-- | Convert a period of time into a count of days and a time of day since midnight. +-- The time of day will never have a leap second. +timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer,TimeOfDay) +timeToDaysAndTimeOfDay dt = let + s = realToFrac dt + (m,ms) = divMod' s 60 + (h,hm) = divMod' m 60 + (d,dh) = divMod' h 24 + in (d,TimeOfDay dh hm ms) + +-- | Convert a count of days and a time of day since midnight into a period of time. +daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime +daysAndTimeOfDayToTime d (TimeOfDay dh hm ms) = (+) (realToFrac ms) $ (*) 60 $ (+) (realToFrac hm) $ (*) 60 $ (+) (realToFrac dh) $ (*) 24 $ realToFrac d -- | Convert a time of day in UTC to a time of day in some timezone, together with a day adjustment. utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Integer,TimeOfDay) diff --git a/lib/Data/Time/LocalTime/Internal/TimeZone.hs b/lib/Data/Time/LocalTime/Internal/TimeZone.hs --- a/lib/Data/Time/LocalTime/Internal/TimeZone.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeZone.hs @@ -1,8 +1,6 @@ {-# OPTIONS -fno-warn-unused-imports #-} {-# LANGUAGE ForeignFunctionInterface #-} #include "HsConfigure.h" - --- #hide module Data.Time.LocalTime.Internal.TimeZone ( -- * Time zones @@ -57,21 +55,26 @@ hoursToTimeZone :: Int -> TimeZone hoursToTimeZone i = minutesToTimeZone (60 * i) -showT :: PadOption -> Int -> String -showT opt t = showPaddedNum opt ((div t 60) * 100 + (mod t 60)) +showT :: Bool -> PadOption -> Int -> String +showT False opt t = showPaddedNum opt ((div t 60) * 100 + (mod t 60)) +showT True opt t = let + opt' = case opt of + NoPad -> NoPad + Pad i c -> Pad (max 0 $ i - 3) c + in showPaddedNum opt' (div t 60) ++ ":" ++ show2 (mod t 60) -timeZoneOffsetString'' :: PadOption -> TimeZone -> String -timeZoneOffsetString'' opt (TimeZone t _ _) | t < 0 = '-':(showT opt (negate t)) -timeZoneOffsetString'' opt (TimeZone t _ _) = '+':(showT opt t) +timeZoneOffsetString'' :: Bool -> PadOption -> TimeZone -> String +timeZoneOffsetString'' colon opt (TimeZone t _ _) | t < 0 = '-':(showT colon opt (negate t)) +timeZoneOffsetString'' colon opt (TimeZone t _ _) = '+':(showT colon opt t) -- | Text representing the offset of this timezone, such as \"-0800\" or \"+0400\" (like @%z@ in formatTime), with arbitrary padding. timeZoneOffsetString' :: Maybe Char -> TimeZone -> String -timeZoneOffsetString' Nothing = timeZoneOffsetString'' NoPad -timeZoneOffsetString' (Just c) = timeZoneOffsetString'' $ Pad 4 c +timeZoneOffsetString' Nothing = timeZoneOffsetString'' False NoPad +timeZoneOffsetString' (Just c) = timeZoneOffsetString'' False $ Pad 4 c -- | Text representing the offset of this timezone, such as \"-0800\" or \"+0400\" (like @%z@ in formatTime). timeZoneOffsetString :: TimeZone -> String -timeZoneOffsetString = timeZoneOffsetString'' (Pad 4 '0') +timeZoneOffsetString = timeZoneOffsetString'' False (Pad 4 '0') instance Show TimeZone where show zone@(TimeZone _ _ "") = timeZoneOffsetString zone diff --git a/lib/Data/Time/LocalTime/Internal/ZonedTime.hs b/lib/Data/Time/LocalTime/Internal/ZonedTime.hs --- a/lib/Data/Time/LocalTime/Internal/ZonedTime.hs +++ b/lib/Data/Time/LocalTime/Internal/ZonedTime.hs @@ -1,7 +1,5 @@ {-# OPTIONS -fno-warn-orphans #-} #include "HsConfigure.h" - --- #hide module Data.Time.LocalTime.Internal.ZonedTime ( ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime diff --git a/test/main/Main.hs b/test/main/Main.hs --- a/test/main/Main.hs +++ b/test/main/Main.hs @@ -5,16 +5,21 @@ import Test.Calendar.Calendars import Test.Calendar.ClipDates import Test.Calendar.ConvertBack +import Test.Calendar.Duration import Test.Calendar.Easter import Test.Calendar.LongWeekYears import Test.Calendar.MonthDay import Test.Calendar.Valid +import Test.Calendar.Week import Test.Clock.Conversion import Test.Clock.Resolution import Test.Clock.TAI import Test.Format.Format import Test.Format.ParseTime +import Test.Format.ISO8601 import Test.LocalTime.Time +import Test.LocalTime.TimeOfDay +import Test.LocalTime.CalendarDiffTime tests :: TestTree @@ -27,7 +32,9 @@ longWeekYears, testMonthDay, testEaster, - testValid + testValid, + testWeek, + testDuration ], testGroup "Clock" [ testClockConversion, @@ -36,10 +43,13 @@ ], testGroup "Format" [ testFormat, - testParseTime + testParseTime, + testISO8601 ], testGroup "LocalTime" [ - testTime + testTime, + testTimeOfDay, + testCalendarDiffTime ] ] diff --git a/test/main/Test/Arbitrary.hs b/test/main/Test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/Arbitrary.hs @@ -0,0 +1,107 @@ +{-# OPTIONS -fno-warn-orphans #-} + +module Test.Arbitrary where + +import Control.Monad +import Data.Ratio +import Data.Time +import Data.Time.Clock.POSIX +import Test.Tasty.QuickCheck hiding (reason) + +instance Arbitrary DayOfWeek where + arbitrary = fmap toEnum $ choose (1,7) + +instance Arbitrary Day where + arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31 + shrink day = let + (y, m, d) = toGregorian day + dayShrink = + if d > 1 + then [fromGregorian y m (d - 1)] + else [] + monthShrink = + if m > 1 + then [fromGregorian y (m - 1) d] + else [] + yearShrink = + if y > 2000 + then [fromGregorian (y - 1) m d] + else if y < 2000 + then [fromGregorian (y + 1) m d] + else [] + in dayShrink ++ monthShrink ++ yearShrink + +instance CoArbitrary Day where + coarbitrary (ModifiedJulianDay d) = coarbitrary d + +instance Arbitrary CalendarDiffDays where + arbitrary = liftM2 CalendarDiffDays arbitrary arbitrary + +instance Arbitrary DiffTime where + arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second + where + intSecs = liftM secondsToDiffTime' $ choose (0, 86400) + fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10 ^ (12 :: Int)) + secondsToDiffTime' :: Integer -> DiffTime + secondsToDiffTime' = fromInteger + picosecondsToDiffTime' :: Integer -> DiffTime + picosecondsToDiffTime' x = fromRational (x % 10 ^ (12 :: Int)) + +instance CoArbitrary DiffTime where + coarbitrary t = coarbitrary (fromEnum t) + +instance Arbitrary NominalDiffTime where + arbitrary = oneof [intSecs, fracSecs] + where + limit = 1000 * 86400 + picofactor = 10 ^ (12 :: Int) + intSecs = liftM secondsToDiffTime' $ choose (negate limit, limit) + fracSecs = liftM picosecondsToDiffTime' $ choose (negate limit * picofactor, limit * picofactor) + secondsToDiffTime' :: Integer -> NominalDiffTime + secondsToDiffTime' = fromInteger + picosecondsToDiffTime' :: Integer -> NominalDiffTime + picosecondsToDiffTime' x = fromRational (x % 10 ^ (12 :: Int)) + +instance CoArbitrary NominalDiffTime where + coarbitrary t = coarbitrary (fromEnum t) + +instance Arbitrary CalendarDiffTime where + arbitrary = liftM2 CalendarDiffTime arbitrary arbitrary + +instance Arbitrary TimeOfDay where + arbitrary = liftM timeToTimeOfDay arbitrary + +instance CoArbitrary TimeOfDay where + coarbitrary t = coarbitrary (timeOfDayToTime t) + +instance Arbitrary LocalTime where + arbitrary = liftM2 LocalTime arbitrary arbitrary + +instance CoArbitrary LocalTime where + coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer) + +instance Arbitrary TimeZone where + arbitrary = liftM minutesToTimeZone $ choose (-720, 720) + +instance CoArbitrary TimeZone where + coarbitrary tz = coarbitrary (timeZoneMinutes tz) + +instance Arbitrary ZonedTime where + arbitrary = liftM2 ZonedTime arbitrary arbitrary + +instance CoArbitrary ZonedTime where + coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer) + +instance Arbitrary UTCTime where + arbitrary = liftM2 UTCTime arbitrary arbitrary + +instance CoArbitrary UTCTime where + coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds t) :: Integer) + +instance Arbitrary UniversalTime where + arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) -- 1000-01-1 to 9999-12-31 + where + k = 86400 + +instance CoArbitrary UniversalTime where + coarbitrary (ModJulianDate d) = coarbitrary d diff --git a/test/main/Test/Calendar/Duration.hs b/test/main/Test/Calendar/Duration.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/Calendar/Duration.hs @@ -0,0 +1,46 @@ +module Test.Calendar.Duration + ( testDuration + ) where + +import Data.Time.Calendar +import Data.Time.Calendar.Julian +import Test.Arbitrary () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding (reason) + +testAddDiff :: TestTree +testAddDiff = + testGroup + "add diff" + [ testProperty "add diff GregorianDurationClip" $ \day1 day2 -> + addGregorianDurationClip (diffGregorianDurationClip day2 day1) day1 == day2 + , testProperty "add diff GregorianDurationRollOver" $ \day1 day2 -> + addGregorianDurationRollOver (diffGregorianDurationRollOver day2 day1) day1 == day2 + , testProperty "add diff JulianDurationClip" $ \day1 day2 -> + addJulianDurationClip (diffJulianDurationClip day2 day1) day1 == day2 + , testProperty "add diff JulianDurationRollOver" $ \day1 day2 -> + addJulianDurationRollOver (diffJulianDurationRollOver day2 day1) day1 == day2 + ] + +testClip :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree +testClip (y1,m1,d1) (y2,m2,d2) (em, ed) = let + day1 = fromGregorian y1 m1 d1 + day2 = fromGregorian y2 m2 d2 + expected = CalendarDiffDays em ed + found = diffGregorianDurationClip day1 day2 + in testCase (show day1 ++ " - " ++ show day2) $ assertEqual "" expected found + +testDiffs :: TestTree +testDiffs = + testGroup + "diffs" + [ testClip (2017, 04, 07) (2017, 04, 07) (0, 0) + , testClip (2017, 04, 07) (2017, 04, 01) (0, 6) + , testClip (2017, 04, 01) (2017, 04, 07) (0, -6) + , testClip (2017, 04, 07) (2017, 02, 01) (2, 6) + , testClip (2017, 02, 01) (2017, 04, 07) (-2, -6) + ] + +testDuration :: TestTree +testDuration = testGroup "CalendarDiffDays" [testAddDiff, testDiffs] diff --git a/test/main/Test/Calendar/Week.hs b/test/main/Test/Calendar/Week.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/Calendar/Week.hs @@ -0,0 +1,93 @@ +module Test.Calendar.Week + ( testWeek + ) where + +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate +import Test.Tasty +import Test.Tasty.HUnit + +testDay :: TestTree +testDay = + testCase "day" $ do + let day = fromGregorian 2018 1 9 + assertEqual "" (ModifiedJulianDay 58127) day + assertEqual "" (2018, 2, 2) $ toWeekDate day + assertEqual "" Tuesday $ dayOfWeek day + +allDaysOfWeek :: [DayOfWeek] +allDaysOfWeek = [Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday] + +testAllDays :: String -> (DayOfWeek -> IO ()) -> TestTree +testAllDays name f = testGroup name $ fmap (\wd -> testCase (show wd) $ f wd) allDaysOfWeek + +testSucc :: TestTree +testSucc = testAllDays "succ" $ \wd -> assertEqual "" (toEnum $ succ $ fromEnum wd) $ succ wd + +testPred :: TestTree +testPred = testAllDays "pred" $ \wd -> assertEqual "" (toEnum $ pred $ fromEnum wd) $ pred wd + +testSequences :: TestTree +testSequences = + testGroup + "sequence" + [ testCase "[Monday .. Sunday]" $ assertEqual "" allDaysOfWeek [Monday .. Sunday] + , testCase "[Wednesday .. Wednesday]" $ assertEqual "" [Wednesday] [Wednesday .. Wednesday] + , testCase "[Sunday .. Saturday]" $ + assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday] + , testCase "[Thursday .. Wednesday]" $ + assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday] + , testCase "[Tuesday ..]" $ + assertEqual + "" + [ Tuesday + , Wednesday + , Thursday + , Friday + , Saturday + , Sunday + , Monday + , Tuesday + , Wednesday + , Thursday + , Friday + , Saturday + , Sunday + , Monday + , Tuesday + ] $ + take 15 [Tuesday ..] + , testCase "[Wednesday, Tuesday ..]" $ + assertEqual + "" + [ Wednesday + , Tuesday + , Monday + , Sunday + , Saturday + , Friday + , Thursday + , Wednesday + , Tuesday + , Monday + , Sunday + , Saturday + , Friday + , Thursday + , Wednesday + ] $ + take 15 [Wednesday,Tuesday ..] + , testCase "[Sunday, Friday ..]" $ + assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $ + take 8 [Sunday,Friday ..] + , testCase "[Monday,Sunday .. Tuesday]" $ + assertEqual "" [Monday, Sunday, Saturday, Friday, Thursday, Wednesday, Tuesday] [Monday,Sunday .. Tuesday] + , testCase "[Thursday, Saturday .. Tuesday]" $ + assertEqual "" [Thursday, Saturday, Monday, Wednesday, Friday, Sunday, Tuesday] [Thursday,Saturday .. Tuesday] + ] + +testReadShow :: TestTree +testReadShow = testAllDays "read show" $ \wd -> assertEqual "" wd $ read $ show wd + +testWeek :: TestTree +testWeek = testGroup "Week" [testDay, testSucc, testPred, testSequences, testReadShow] diff --git a/test/main/Test/Format/Format.hs b/test/main/Test/Format/Format.hs --- a/test/main/Test/Format/Format.hs +++ b/test/main/Test/Format/Format.hs @@ -1,7 +1,7 @@ module Test.Format.Format(testFormat) where import Data.Time -import Control.Exception; +import Data.Proxy import Test.Tasty import Test.Tasty.HUnit import Test.TestUtil @@ -29,45 +29,130 @@ somestrings :: [String] somestrings = ["", " ", "-", "\n"] -getBottom :: a -> IO (Maybe Control.Exception.SomeException); -getBottom a = Control.Exception.catch (seq a (return Nothing)) (return . Just); - -compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> TestTree -compareExpected testname fmt str expected = testCase testname $ do - let found = parseTimeM False defaultTimeLocale fmt str - mex <- getBottom found - case mex of - Just ex -> assertFailure $ unwords [ "Exception: expected" , show expected ++ ", caught", show ex] - Nothing -> assertEqual "" expected found - -class (ParseTime t) => TestParse t where - expectedParse :: String -> String -> Maybe t - expectedParse "%Z" "" = buildTime defaultTimeLocale [] - expectedParse "%_Z" "" = buildTime defaultTimeLocale [] - expectedParse "%-Z" "" = buildTime defaultTimeLocale [] - expectedParse "%0Z" "" = buildTime defaultTimeLocale [] - expectedParse _ _ = Nothing - -instance TestParse Day -instance TestParse TimeOfDay -instance TestParse LocalTime -instance TestParse TimeZone -instance TestParse ZonedTime -instance TestParse UTCTime +compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> proxy t -> TestTree +compareExpected testname fmt str proxy = testCase testname $ do + let + found :: ParseTime t => proxy t -> Maybe t + found _ = parseTimeM False defaultTimeLocale fmt str + assertEqual "" Nothing $ found proxy checkParse :: String -> String -> [TestTree] checkParse fmt str = [ - compareExpected "Day" fmt str (expectedParse fmt str :: Maybe Day), - compareExpected "TimeOfDay" fmt str (expectedParse fmt str :: Maybe TimeOfDay), - compareExpected "LocalTime" fmt str (expectedParse fmt str :: Maybe LocalTime), - compareExpected "TimeZone" fmt str (expectedParse fmt str :: Maybe TimeZone), - compareExpected "UTCTime" fmt str (expectedParse fmt str :: Maybe UTCTime) + compareExpected "Day" fmt str (Proxy :: Proxy Day), + compareExpected "TimeOfDay" fmt str (Proxy :: Proxy TimeOfDay), + compareExpected "LocalTime" fmt str (Proxy :: Proxy LocalTime), + compareExpected "TimeZone" fmt str (Proxy :: Proxy TimeZone), + compareExpected "UTCTime" fmt str (Proxy :: Proxy UTCTime) ] testCheckParse :: TestTree testCheckParse = testGroup "checkParse" $ tgroup formats $ \fmt -> tgroup somestrings $ \str -> checkParse fmt str +days :: [Day] +days = [(fromGregorian 2018 1 5) .. (fromGregorian 2018 1 26)] + +testDayOfWeek :: TestTree +testDayOfWeek = testGroup "DayOfWeek" $ tgroup "uwaA" $ \fmt -> tgroup days $ \day -> let + dayFormat = formatTime defaultTimeLocale ['%',fmt] day + dowFormat = formatTime defaultTimeLocale ['%',fmt] $ dayOfWeek day + in assertEqual "" dayFormat dowFormat + +testZone :: String -> String -> Int -> TestTree +testZone fmt expected minutes = testCase (show fmt) $ assertEqual "" expected $ formatTime defaultTimeLocale fmt $ TimeZone minutes False "" + +testZonePair :: String -> String -> Int -> TestTree +testZonePair mods expected minutes = testGroup (show mods ++ " " ++ show minutes) + [ + testZone ("%" ++ mods ++ "z") expected minutes, + testZone ("%" ++ mods ++ "Z") expected minutes + ] + +testTimeZone :: TestTree +testTimeZone = testGroup "TimeZone" + [ + testZonePair "" "+0000" 0, + testZonePair "E" "+00:00" 0, + testZonePair "" "+0500" 300, + testZonePair "E" "+05:00" 300, + testZonePair "3" "+0500" 300, + testZonePair "4E" "+05:00" 300, + testZonePair "4" "+0500" 300, + testZonePair "5E" "+05:00" 300, + testZonePair "5" "+00500" 300, + testZonePair "6E" "+005:00" 300, + testZonePair "" "-0700" (-420), + testZonePair "E" "-07:00" (-420), + testZonePair "" "+1015" 615, + testZonePair "E" "+10:15" 615, + testZonePair "3" "+1015" 615, + testZonePair "4E" "+10:15" 615, + testZonePair "4" "+1015" 615, + testZonePair "5E" "+10:15" 615, + testZonePair "5" "+01015" 615, + testZonePair "6E" "+010:15" 615, + testZonePair "" "-1130" (-690), + testZonePair "E" "-11:30" (-690) + ] + +testAFormat :: FormatTime t => String -> String -> t -> TestTree +testAFormat fmt expected t = testCase fmt $ assertEqual "" expected $ formatTime defaultTimeLocale fmt t + +testNominalDiffTime :: TestTree +testNominalDiffTime = testGroup "NominalDiffTime" + [ + testAFormat "%ww%Dd%Hh%Mm%ESs" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime), + testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: NominalDiffTime), + testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: NominalDiffTime), + testAFormat "%dd %hh %mm %ss %Ess %0Ess" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime), + testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m-8s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime), + testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime), + testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m0s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime), + testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-0.21s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime), + testAFormat "%dd %hh %mm %Ess" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime) + ] + +testDiffTime :: TestTree +testDiffTime = testGroup "DiffTime" + [ + testAFormat "%ww%Dd%Hh%Mm%ESs" "3w2d2h22m8.21s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime), + testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: DiffTime), + testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: DiffTime), + testAFormat "%dd %hh %mm %ss %Ess %0Ess" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime), + testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m-8s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime), + testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-8.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime), + testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m0s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime), + testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-0.21s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime), + testAFormat "%dd %hh %mm %Ess" "-23d -554h -33262m -1995728.21s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime) + ] + +testCalenderDiffDays :: TestTree +testCalenderDiffDays = testGroup "CalenderDiffDays" + [ + testAFormat "%yy%Bm%ww%Dd" "5y4m3w2d" $ CalendarDiffDays 64 23, + testAFormat "%bm %dd" "64m 23d" $ CalendarDiffDays 64 23, + testAFormat "%yy%Bm%ww%Dd" "-5y-4m-3w-2d" $ CalendarDiffDays (-64) (-23), + testAFormat "%bm %dd" "-64m -23d" $ CalendarDiffDays (-64) (-23) + ] + +testCalenderDiffTime :: TestTree +testCalenderDiffTime = testGroup "CalenderDiffTime" + [ + testAFormat "%yy%Bm%ww%Dd%Hh%Mm%Ss" "5y4m3w2d2h22m8s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21, + testAFormat "%yy%Bm%ww%Dd%Hh%Mm%ESs" "5y4m3w2d2h22m8.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21, + testAFormat "%yy%Bm%ww%Dd%Hh%Mm%0ESs" "5y4m3w2d2h22m08.210000000000s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21, + testAFormat "%bm %dd %hh %mm %Ess" "64m 23d 554h 33262m 1995728.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21, + testAFormat "%yy%Bm%ww%Dd%Hh%Mm%Ss" "-5y-4m-3w-2d-2h-22m-8s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21, + testAFormat "%yy%Bm%ww%Dd%Hh%Mm%ESs" "-5y-4m-3w-2d-2h-22m-8.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21, + testAFormat "%bm %dd %hh %mm %Ess" "-64m -23d -554h -33262m -1995728.21s" $ CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21 + ] + testFormat :: TestTree testFormat = testGroup "testFormat" $ [ - testCheckParse + testCheckParse, + testDayOfWeek, + testTimeZone, + testNominalDiffTime, + testDiffTime, + testCalenderDiffDays, + testCalenderDiffTime ] diff --git a/test/main/Test/Format/ISO8601.hs b/test/main/Test/Format/ISO8601.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/Format/ISO8601.hs @@ -0,0 +1,290 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Test.Format.ISO8601(testISO8601) where + +import Data.Ratio +import Data.Time +import Data.Time.Format.ISO8601 +import Test.QuickCheck.Property +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding (reason) +import Test.TestUtil +import Test.Arbitrary() + + +deriving instance Eq ZonedTime + +readShowProperty :: (Eq a,Show a) => Format a -> a -> Property +readShowProperty fmt val = case formatShowM fmt val of + Nothing -> property Discard + Just str -> let + found = formatParseM fmt str + expected = Just val + in property $ if expected == found then succeeded else + failed {reason = show str ++ ": expected " ++ (show expected) ++ ", found " ++ (show found)} + +readBoth :: NameTest t => (FormatExtension -> t) -> [TestTree] +readBoth fmts = + [ + nameTest "extended" $ fmts ExtendedFormat, + nameTest "basic" $ fmts BasicFormat + ] + +readShowProperties :: (Eq a,Show a,Arbitrary a) => (FormatExtension -> Format a) -> [TestTree] +readShowProperties fmts = readBoth $ \fe -> readShowProperty $ fmts fe + +newtype Durational t = MkDurational t + +instance Show t => Show (Durational t) where + show (MkDurational t) = show t + +instance Arbitrary (Durational CalendarDiffDays) where + arbitrary = do + mm <- choose (-10000,10000) + dd <- choose (-40,40) + return $ MkDurational $ CalendarDiffDays mm dd + +instance Arbitrary (Durational CalendarDiffTime) where + arbitrary = let + limit = 40 * 86400 + picofactor = 10 ^ (12 :: Int) + in do + mm <- choose (-10000,10000) + ss <- choose (negate limit * picofactor, limit * picofactor) + return $ MkDurational $ CalendarDiffTime mm $ fromRational $ ss % picofactor + +testReadShowFormat :: TestTree +testReadShowFormat = nameTest "read-show format" + [ + nameTest "calendarFormat" $ readShowProperties $ calendarFormat, + nameTest "yearMonthFormat" $ readShowProperty $ yearMonthFormat, + nameTest "yearFormat" $ readShowProperty $ yearFormat, + nameTest "centuryFormat" $ readShowProperty $ centuryFormat, + nameTest "expandedCalendarFormat" $ readShowProperties $ expandedCalendarFormat 6, + nameTest "expandedYearMonthFormat" $ readShowProperty $ expandedYearMonthFormat 6, + nameTest "expandedYearFormat" $ readShowProperty $ expandedYearFormat 6, + nameTest "expandedCenturyFormat" $ readShowProperty $ expandedCenturyFormat 4, + nameTest "ordinalDateFormat" $ readShowProperties $ ordinalDateFormat, + nameTest "expandedOrdinalDateFormat" $ readShowProperties $ expandedOrdinalDateFormat 6, + nameTest "weekDateFormat" $ readShowProperties $ weekDateFormat, + nameTest "yearWeekFormat" $ readShowProperties $ yearWeekFormat, + nameTest "expandedWeekDateFormat" $ readShowProperties $ expandedWeekDateFormat 6, + nameTest "expandedYearWeekFormat" $ readShowProperties $ expandedYearWeekFormat 6, + nameTest "timeOfDayFormat" $ readShowProperties $ timeOfDayFormat, + nameTest "hourMinuteFormat" $ readShowProperties $ hourMinuteFormat, + nameTest "hourFormat" $ readShowProperty $ hourFormat, + nameTest "withTimeDesignator" $ readShowProperties $ \fe -> withTimeDesignator $ timeOfDayFormat fe, + nameTest "withUTCDesignator" $ readShowProperties $ \fe -> withUTCDesignator $ timeOfDayFormat fe, + nameTest "timeOffsetFormat" $ readShowProperties $ timeOffsetFormat, + nameTest "timeOfDayAndOffsetFormat" $ readShowProperties $ timeOfDayAndOffsetFormat, + nameTest "localTimeFormat" $ readShowProperties $ \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe), + nameTest "zonedTimeFormat" $ readShowProperties $ \fe -> zonedTimeFormat (calendarFormat fe) (timeOfDayFormat fe) fe, + nameTest "utcTimeFormat" $ readShowProperties $ \fe -> utcTimeFormat (calendarFormat fe) (timeOfDayFormat fe), + nameTest "dayAndTimeFormat" $ readShowProperties $ \fe -> dayAndTimeFormat (calendarFormat fe) (timeOfDayFormat fe), + nameTest "timeAndOffsetFormat" $ readShowProperties $ \fe -> timeAndOffsetFormat (timeOfDayFormat fe) fe, + nameTest "durationDaysFormat" $ readShowProperty $ durationDaysFormat, + nameTest "durationTimeFormat" $ readShowProperty $ durationTimeFormat, + nameTest "alternativeDurationDaysFormat" $ readBoth $ \fe (MkDurational t) -> readShowProperty (alternativeDurationDaysFormat fe) t, + nameTest "alternativeDurationTimeFormat" $ readBoth $ \fe (MkDurational t) -> readShowProperty (alternativeDurationTimeFormat fe) t, + nameTest "intervalFormat" $ readShowProperties $ \fe -> intervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat, + nameTest "recurringIntervalFormat" $ readShowProperties $ \fe -> recurringIntervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat + ] + +testShowFormat :: String -> Format t -> String -> t -> TestTree +testShowFormat name fmt str t = nameTest (name ++ ": " ++ str) $ + assertEqual "" (Just str) $ formatShowM fmt t + +testShowFormats :: TestTree +testShowFormats = nameTest "show format" + [ + testShowFormat "durationDaysFormat" durationDaysFormat "P0D" $ CalendarDiffDays 0 0, + testShowFormat "durationDaysFormat" durationDaysFormat "P4Y" $ CalendarDiffDays 48 0, + testShowFormat "durationDaysFormat" durationDaysFormat "P7M" $ CalendarDiffDays 7 0, + testShowFormat "durationDaysFormat" durationDaysFormat "P5D" $ CalendarDiffDays 0 5, + testShowFormat "durationDaysFormat" durationDaysFormat "P2Y3M81D" $ CalendarDiffDays 27 81, + testShowFormat "durationTimeFormat" durationTimeFormat "P0D" $ CalendarDiffTime 0 0, + testShowFormat "durationTimeFormat" durationTimeFormat "P4Y" $ CalendarDiffTime 48 0, + testShowFormat "durationTimeFormat" durationTimeFormat "P7M" $ CalendarDiffTime 7 0, + testShowFormat "durationTimeFormat" durationTimeFormat "P5D" $ CalendarDiffTime 0 $ 5 * nominalDay, + testShowFormat "durationTimeFormat" durationTimeFormat "P2Y3M81D" $ CalendarDiffTime 27 $ 81 * nominalDay, + testShowFormat "durationTimeFormat" durationTimeFormat "PT2H" $ CalendarDiffTime 0 $ 7200, + testShowFormat "durationTimeFormat" durationTimeFormat "PT3M" $ CalendarDiffTime 0 $ 180, + testShowFormat "durationTimeFormat" durationTimeFormat "PT12S" $ CalendarDiffTime 0 $ 12, + testShowFormat "durationTimeFormat" durationTimeFormat "PT1M18.77634S" $ CalendarDiffTime 0 $ 78.77634, + testShowFormat "durationTimeFormat" durationTimeFormat "PT2H1M18.77634S" $ CalendarDiffTime 0 $ 7278.77634, + testShowFormat "durationTimeFormat" durationTimeFormat "P5DT2H1M18.77634S" $ CalendarDiffTime 0 $ 5 * nominalDay + 7278.77634, + testShowFormat "durationTimeFormat" durationTimeFormat "P7Y10M5DT2H1M18.77634S" $ CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634, + testShowFormat "durationTimeFormat" durationTimeFormat "P7Y10MT2H1M18.77634S" $ CalendarDiffTime 94 $ 7278.77634, + testShowFormat "durationTimeFormat" durationTimeFormat "P8YT2H1M18.77634S" $ CalendarDiffTime 96 $ 7278.77634, + testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0001-00-00" $ CalendarDiffDays 12 0, + testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0002-03-29" $ CalendarDiffDays 27 29, + testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0561-08-29" $ CalendarDiffDays (561 * 12 + 8) 29, + testShowFormat "alternativeDurationTimeFormat" (alternativeDurationTimeFormat ExtendedFormat) "P0000-00-01T00:00:00" $ CalendarDiffTime 0 86400, + testShowFormat "alternativeDurationTimeFormat" (alternativeDurationTimeFormat ExtendedFormat) "P0007-10-05T02:01:18.77634" $ CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634, + testShowFormat "alternativeDurationTimeFormat" (alternativeDurationTimeFormat ExtendedFormat) "P4271-10-05T02:01:18.77634" $ CalendarDiffTime (12 * 4271 + 10) $ 5 * nominalDay + 7278.77634, + testShowFormat "centuryFormat" centuryFormat "02" 2, + testShowFormat "centuryFormat" centuryFormat "21" 21, + testShowFormat "intervalFormat etc." + (intervalFormat (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat)) durationTimeFormat) + "2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S" + (LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56),CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34), + testShowFormat "recurringIntervalFormat etc." + (recurringIntervalFormat (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat)) durationTimeFormat) + "R74/2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S" + (74,LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56),CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34), + testShowFormat "recurringIntervalFormat etc." + (recurringIntervalFormat (calendarFormat ExtendedFormat) durationDaysFormat) + "R74/2015-06-13/P1Y2M7D" + (74,fromGregorian 2015 6 13,CalendarDiffDays 14 7), + testShowFormat "timeOffsetFormat" + iso8601Format + "-06:30" + (minutesToTimeZone (-390)), + testShowFormat "timeOffsetFormat" + iso8601Format + "+00:00" + (minutesToTimeZone 0), + testShowFormat "timeOffsetFormat" + (timeOffsetFormat BasicFormat) + "+0000" + (minutesToTimeZone 0), + testShowFormat "timeOffsetFormat" + iso8601Format + "+00:10" + (minutesToTimeZone 10), + testShowFormat "timeOffsetFormat" + iso8601Format + "-00:10" + (minutesToTimeZone (-10)), + testShowFormat "timeOffsetFormat" + iso8601Format + "+01:35" + (minutesToTimeZone 95), + testShowFormat "timeOffsetFormat" + iso8601Format + "-01:35" + (minutesToTimeZone (-95)), + testShowFormat "timeOffsetFormat" + (timeOffsetFormat BasicFormat) + "+0135" + (minutesToTimeZone 95), + testShowFormat "timeOffsetFormat" + (timeOffsetFormat BasicFormat) + "-0135" + (minutesToTimeZone (-95)), + testShowFormat "timeOffsetFormat" + (timeOffsetFormat BasicFormat) + "-1100" + (minutesToTimeZone $ negate $ 11 * 60), + testShowFormat "timeOffsetFormat" + (timeOffsetFormat BasicFormat) + "+1015" + (minutesToTimeZone $ 615), + testShowFormat "zonedTimeFormat" + iso8601Format + "2024-07-06T08:45:56.553-06:30" + (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone (-390))), + testShowFormat "zonedTimeFormat" + iso8601Format + "2024-07-06T08:45:56.553+06:30" + (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone 390)), + testShowFormat "utcTimeFormat" + iso8601Format + "2024-07-06T08:45:56.553Z" + (UTCTime (fromGregorian 2024 07 06) (timeOfDayToTime $ TimeOfDay 8 45 56.553)), + testShowFormat "utcTimeFormat" + iso8601Format + "2028-12-31T23:59:60.9Z" + (UTCTime (fromGregorian 2028 12 31) (timeOfDayToTime $ TimeOfDay 23 59 60.9)), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1994-W52-7" + (fromGregorian 1995 1 1), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1995-W01-1" + (fromGregorian 1995 1 2), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1996-W52-7" + (fromGregorian 1996 12 29), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1997-W01-2" + (fromGregorian 1996 12 31), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1997-W01-3" + (fromGregorian 1997 1 1), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1974-W32-6" + (fromGregorian 1974 8 10), + testShowFormat "weekDateFormat" + (weekDateFormat BasicFormat) + "1974W326" + (fromGregorian 1974 8 10), + testShowFormat "weekDateFormat" + (weekDateFormat ExtendedFormat) + "1995-W05-6" + (fromGregorian 1995 2 4), + testShowFormat "weekDateFormat" + (weekDateFormat BasicFormat) + "1995W056" + (fromGregorian 1995 2 4), + testShowFormat "weekDateFormat" + (expandedWeekDateFormat 6 ExtendedFormat) + "+001995-W05-6" + (fromGregorian 1995 2 4), + testShowFormat "weekDateFormat" + (expandedWeekDateFormat 6 BasicFormat) + "+001995W056" + (fromGregorian 1995 2 4), + testShowFormat "ordinalDateFormat" + (ordinalDateFormat ExtendedFormat) + "1846-235" + (fromGregorian 1846 8 23), + testShowFormat "ordinalDateFormat" + (ordinalDateFormat BasicFormat) + "1844236" + (fromGregorian 1844 8 23), + testShowFormat "ordinalDateFormat" + (expandedOrdinalDateFormat 5 ExtendedFormat) + "+01846-235" + (fromGregorian 1846 8 23), + testShowFormat "hourMinuteFormat" + (hourMinuteFormat ExtendedFormat) + "13:17.25" + (TimeOfDay 13 17 15), + testShowFormat "hourMinuteFormat" + (hourMinuteFormat ExtendedFormat) + "01:12.4" + (TimeOfDay 1 12 24), + testShowFormat "hourMinuteFormat" + (hourMinuteFormat BasicFormat) + "1317.25" + (TimeOfDay 13 17 15), + testShowFormat "hourMinuteFormat" + (hourMinuteFormat BasicFormat) + "0112.4" + (TimeOfDay 1 12 24), + testShowFormat "hourFormat" + hourFormat + "22" + (TimeOfDay 22 0 0), + testShowFormat "hourFormat" + hourFormat + "06" + (TimeOfDay 6 0 0), + testShowFormat "hourFormat" + hourFormat + "18.9475" + (TimeOfDay 18 56 51) + ] + +testISO8601 :: TestTree +testISO8601 = nameTest "ISO8601" + [ + testShowFormats, + testReadShowFormat + ] diff --git a/test/main/Test/Format/ParseTime.hs b/test/main/Test/Format/ParseTime.hs --- a/test/main/Test/Format/ParseTime.hs +++ b/test/main/Test/Format/ParseTime.hs @@ -3,16 +3,16 @@ import Control.Monad import Data.Char -import Data.Ratio +import Text.Read import Data.Time import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate -import Data.Time.Clock.POSIX import Test.QuickCheck.Property import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding (reason) import Test.TestUtil +import Test.Arbitrary() testParseTime :: TestTree @@ -233,61 +233,6 @@ format :: (FormatTime t) => String -> t -> String format f t = formatTime defaultTimeLocale f t -instance Arbitrary Day where - arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31 - -instance CoArbitrary Day where - coarbitrary (ModifiedJulianDay d) = coarbitrary d - -instance Arbitrary DiffTime where - arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second - where intSecs = liftM secondsToDiffTime' $ choose (0, 86400) - fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10^(12::Int)) - secondsToDiffTime' :: Integer -> DiffTime - secondsToDiffTime' = fromInteger - picosecondsToDiffTime' :: Integer -> DiffTime - picosecondsToDiffTime' x = fromRational (x % 10^(12::Int)) - -instance CoArbitrary DiffTime where - coarbitrary t = coarbitrary (fromEnum t) - -instance Arbitrary TimeOfDay where - arbitrary = liftM timeToTimeOfDay arbitrary - -instance CoArbitrary TimeOfDay where - coarbitrary t = coarbitrary (timeOfDayToTime t) - -instance Arbitrary LocalTime where - arbitrary = liftM2 LocalTime arbitrary arbitrary - -instance CoArbitrary LocalTime where - coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer) - -instance Arbitrary TimeZone where - arbitrary = liftM minutesToTimeZone $ choose (-720,720) - -instance CoArbitrary TimeZone where - coarbitrary tz = coarbitrary (timeZoneMinutes tz) - -instance Arbitrary ZonedTime where - arbitrary = liftM2 ZonedTime arbitrary arbitrary - -instance CoArbitrary ZonedTime where - coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer) - -instance Arbitrary UTCTime where - arbitrary = liftM2 UTCTime arbitrary arbitrary - -instance CoArbitrary UTCTime where - coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds t) :: Integer) - -instance Arbitrary UniversalTime where - arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) where -- 1000-01-1 to 9999-12-31 - k = 86400 - -instance CoArbitrary UniversalTime where - coarbitrary (ModJulianDate d) = coarbitrary d - -- missing from the time package instance Eq ZonedTime where ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2 @@ -315,7 +260,7 @@ -- prop_read_show :: (Read a, Show a, Eq a) => a -> Result -prop_read_show t = compareResult [(t,"")] (reads (show t)) +prop_read_show t = compareResult (Just t) (readMaybe (show t)) -- -- * special show functions @@ -361,7 +306,7 @@ prop_parse_format_lower :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result prop_parse_format_lower (FormatString f) t = compareParse t f (map toLower $ format f t) -prop_format_parse_format :: (FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result +prop_format_parse_format :: (FormatTime t, ParseTime t) => FormatString t -> t -> Result prop_format_parse_format (FormatString f) t = compareResult (Just (format f t)) (fmap (format f) (parse False f (format f t) `asTypeOf` Just t)) @@ -400,7 +345,6 @@ instance Show (FormatString a) where show (FormatString f) = show f - typedTests :: (forall t. (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result) -> [TestTree] typedTests prop = [ nameTest "Day" $ tgroup dayFormats prop, @@ -408,8 +352,13 @@ nameTest "LocalTime" $ tgroup localTimeFormats prop, nameTest "TimeZone" $ tgroup timeZoneFormats prop, nameTest "ZonedTime" $ tgroup zonedTimeFormats prop, - nameTest "UTCTime" $ tgroup utcTimeFormats prop, - nameTest "UniversalTime" $ tgroup universalTimeFormats prop + nameTest "ZonedTime" $ tgroup zonedTimeAlmostFormats $ \fmt t -> (todSec $ localTimeOfDay $ zonedTimeToLocalTime t) < 60 ==> prop fmt t, + nameTest "UTCTime" $ tgroup utcTimeAlmostFormats $ \fmt t -> utctDayTime t < 86400 ==> prop fmt t, + nameTest "UniversalTime" $ tgroup universalTimeFormats prop, + nameTest "CalendarDiffDays" $ tgroup calendarDiffDaysFormats prop, + nameTest "CalenderDiffTime" $ tgroup calendarDiffTimeFormats prop, + nameTest "DiffTime" $ tgroup diffTimeFormats prop, + nameTest "NominalDiffTime" $ tgroup nominalDiffTimeFormats prop ] formatParseFormatTests :: TestTree @@ -428,8 +377,8 @@ nameTest "TimeOfDay" $ tgroup (timeOfDayFormats ++ partialTimeOfDayFormats) prop_no_crash_bad_input, nameTest "LocalTime" $ tgroup (localTimeFormats ++ partialLocalTimeFormats) prop_no_crash_bad_input, nameTest "TimeZone" $ tgroup (timeZoneFormats) prop_no_crash_bad_input, - nameTest "ZonedTime" $ tgroup (zonedTimeFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input, - nameTest "UTCTime" $ tgroup (utcTimeFormats ++ partialUTCTimeFormats) prop_no_crash_bad_input, + nameTest "ZonedTime" $ tgroup (zonedTimeFormats ++ zonedTimeAlmostFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input, + nameTest "UTCTime" $ tgroup (utcTimeAlmostFormats ++ partialUTCTimeFormats) prop_no_crash_bad_input, nameTest "UniversalTime" $ tgroup (universalTimeFormats ++ partialUniversalTimeFormats) prop_no_crash_bad_input ] @@ -442,6 +391,8 @@ nameTest "ZonedTime" (prop_read_show :: ZonedTime -> Result), nameTest "UTCTime" (prop_read_show :: UTCTime -> Result), nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result) + --nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result), + --nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result) ] parseShowTests :: TestTree @@ -501,15 +452,29 @@ zonedTimeFormats :: [FormatString ZonedTime] zonedTimeFormats = map FormatString - ["%a, %d %b %Y %H:%M:%S.%q %z", "%a, %d %b %Y %H:%M:%S%Q %z", "%s.%q %z", "%s%Q %z", - "%a, %d %b %Y %H:%M:%S.%q %Z", "%a, %d %b %Y %H:%M:%S%Q %Z", "%s.%q %Z", "%s%Q %Z"] + ["%a, %d %b %Y %H:%M:%S.%q %z", "%a, %d %b %Y %H:%M:%S%Q %z", + "%a, %d %b %Y %H:%M:%S.%q %Z", "%a, %d %b %Y %H:%M:%S%Q %Z"] -utcTimeFormats :: [FormatString UTCTime] -utcTimeFormats = map FormatString - ["%s.%q","%s%Q"] +zonedTimeAlmostFormats :: [FormatString ZonedTime] +zonedTimeAlmostFormats = map FormatString ["%s.%q %z", "%s%Q %z", "%s.%q %Z", "%s%Q %Z"] +utcTimeAlmostFormats :: [FormatString UTCTime] +utcTimeAlmostFormats = map FormatString ["%s.%q","%s%Q"] + universalTimeFormats :: [FormatString UniversalTime] universalTimeFormats = map FormatString [] + +calendarDiffDaysFormats :: [FormatString CalendarDiffDays] +calendarDiffDaysFormats = map FormatString ["%yy%Bm%ww%Dd","%yy%Bm%dd","%bm%ww%Dd","%bm%dd"] + +calendarDiffTimeFormats :: [FormatString CalendarDiffTime] +calendarDiffTimeFormats = map FormatString ["%yy%Bm%ww%Dd%Hh%Mm%ESs","%bm%ww%Dd%Hh%Mm%ESs","%bm%dd%Hh%Mm%ESs","%bm%hh%Mm%ESs","%bm%mm%ESs","%bm%mm%0ESs","%bm%Ess","%bm%0Ess"] + +diffTimeFormats :: [FormatString DiffTime] +diffTimeFormats = map FormatString ["%ww%Dd%Hh%Mm%ESs","%dd%Hh%Mm%ESs","%hh%Mm%ESs","%mm%ESs","%mm%0ESs","%Ess","%0Ess"] + +nominalDiffTimeFormats :: [FormatString NominalDiffTime] +nominalDiffTimeFormats = map FormatString ["%ww%Dd%Hh%Mm%ESs","%dd%Hh%Mm%ESs","%hh%Mm%ESs","%mm%ESs","%mm%0ESs","%Ess","%0Ess"] -- -- * Formats that do not include all the information diff --git a/test/main/Test/LocalTime/CalendarDiffTime.hs b/test/main/Test/LocalTime/CalendarDiffTime.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/LocalTime/CalendarDiffTime.hs @@ -0,0 +1,18 @@ +module Test.LocalTime.CalendarDiffTime + ( testCalendarDiffTime + ) where + +--import Data.Time.LocalTime +import Test.Arbitrary () +import Test.Tasty +--import Test.Tasty.QuickCheck hiding (reason) + +--testReadShow :: TestTree +--testReadShow = testProperty "read . show" $ \(t :: CalendarDiffTime) -> read (show t) == t + +testCalendarDiffTime :: TestTree +testCalendarDiffTime = + testGroup + "CalendarDiffTime" + [ --testReadShow + ] diff --git a/test/main/Test/LocalTime/TimeOfDay.hs b/test/main/Test/LocalTime/TimeOfDay.hs new file mode 100644 --- /dev/null +++ b/test/main/Test/LocalTime/TimeOfDay.hs @@ -0,0 +1,22 @@ +module Test.LocalTime.TimeOfDay + ( testTimeOfDay + ) where + +import Data.Time.LocalTime +import Test.Arbitrary () +import Test.Tasty +import Test.Tasty.QuickCheck hiding (reason) + +testTimeOfDay :: TestTree +testTimeOfDay = + testGroup + "TimeOfDay" + [ testProperty "daysAndTimeOfDayToTime . timeToDaysAndTimeOfDay" $ \ndt -> let + (d, tod) = timeToDaysAndTimeOfDay ndt + ndt' = daysAndTimeOfDayToTime d tod + in ndt' == ndt + , testProperty "timeOfDayToTime . timeToTimeOfDay" $ \dt -> let + tod = timeToTimeOfDay dt + dt' = timeOfDayToTime tod + in dt' == dt + ] diff --git a/time.cabal b/time.cabal --- a/time.cabal +++ b/time.cabal @@ -1,5 +1,5 @@ name: time -version: 1.8.0.4 +version: 1.9 stability: stable license: BSD3 license-file: LICENSE @@ -67,13 +67,17 @@ Data.Time.Clock.TAI, Data.Time.LocalTime, Data.Time.Format, + Data.Time.Format.ISO8601, Data.Time default-extensions: CPP c-sources: lib/cbits/HsTime.c other-modules: + Data.Format Data.Time.Calendar.Private, Data.Time.Calendar.Days, Data.Time.Calendar.Gregorian, + Data.Time.Calendar.CalendarDiffDays, + Data.Time.Calendar.Week, Data.Time.Calendar.JulianYearDay, Data.Time.Clock.Internal.DiffTime, Data.Time.Clock.Internal.AbsoluteTime, @@ -87,10 +91,15 @@ Data.Time.Clock.Internal.UTCDiff, Data.Time.LocalTime.Internal.TimeZone, Data.Time.LocalTime.Internal.TimeOfDay, + Data.Time.LocalTime.Internal.CalendarDiffTime Data.Time.LocalTime.Internal.LocalTime, Data.Time.LocalTime.Internal.ZonedTime, - Data.Time.Format.Parse - Data.Time.Format.Locale + Data.Time.Format.Parse, + Data.Time.Format.Locale, + Data.Time.Format.Format.Class, + Data.Time.Format.Format.Instances, + Data.Time.Format.Parse.Class, + Data.Time.Format.Parse.Instances include-dirs: lib/include if os(windows) install-includes: @@ -137,6 +146,7 @@ main-is: Main.hs other-modules: Test.TestUtil + Test.Arbitrary Test.Calendar.AddDays Test.Calendar.AddDaysRef Test.Calendar.Calendars @@ -144,6 +154,7 @@ Test.Calendar.ClipDates Test.Calendar.ClipDatesRef Test.Calendar.ConvertBack + Test.Calendar.Duration Test.Calendar.Easter Test.Calendar.EasterRef Test.Calendar.LongWeekYears @@ -151,12 +162,16 @@ Test.Calendar.MonthDay Test.Calendar.MonthDayRef Test.Calendar.Valid + Test.Calendar.Week Test.Clock.Conversion Test.Clock.Resolution Test.Clock.TAI Test.Format.Format Test.Format.ParseTime + Test.Format.ISO8601 + Test.LocalTime.CalendarDiffTime Test.LocalTime.Time + Test.LocalTime.TimeOfDay Test.LocalTime.TimeRef test-suite test-unix