packages feed

time 1.8.0.4 → 1.9

raw patch · 39 files changed

+2890/−959 lines, 39 filesdep ~base

Dependency ranges changed: base

Files

changelog.md view
@@ -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
configure.ac view
@@ -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])
+ lib/Data/Format.hs view
@@ -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)
lib/Data/Time.hs view
@@ -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:
lib/Data/Time/Calendar.hs view
@@ -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()
+ lib/Data/Time/Calendar/CalendarDiffDays.hs view
@@ -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)
lib/Data/Time/Calendar/Days.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h"--- #hide module Data.Time.Calendar.Days (     -- * Days
lib/Data/Time/Calendar/Gregorian.hs view
@@ -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
lib/Data/Time/Calendar/Julian.hs view
@@ -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
lib/Data/Time/Calendar/JulianYearDay.hs view
@@ -1,4 +1,3 @@--- #hide module Data.Time.Calendar.JulianYearDay     (     -- * Year and day format
lib/Data/Time/Calendar/Private.hs view
@@ -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)
+ lib/Data/Time/Calendar/Week.hs view
@@ -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
lib/Data/Time/Clock/Internal/DiffTime.hs view
@@ -3,7 +3,6 @@ #endif {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h"--- #hide module Data.Time.Clock.Internal.DiffTime     (     -- * Absolute intervals
lib/Data/Time/Clock/Internal/NominalDiffTime.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE Trustworthy #-} #endif #include "HsConfigure.h"--- #hide module Data.Time.Clock.Internal.NominalDiffTime     (     NominalDiffTime,
lib/Data/Time/Clock/Internal/UTCDiff.hs view
@@ -1,4 +1,3 @@--- #hide module Data.Time.Clock.Internal.UTCDiff where  import Data.Time.Clock.Internal.NominalDiffTime
lib/Data/Time/Format.hs view
@@ -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---- <http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html>-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 @%\<modifier\>\<width\>\<specifier\>@, where @\<modifier\>@ and @\<width\>@ are optional.------ == @\<modifier\>@--- 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\>@--- 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------ == @\<specifier\>@------ 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)
+ lib/Data/Time/Format/Format/Class.hs view
@@ -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+}++-- <http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html>+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 @%\<modifier\>\<width\>\<alternate\>\<specifier\>@, where @\<modifier\>@, @\<width\>@, and @\<alternate\>@ are optional.+--+-- == @\<modifier\>@+-- 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\>@+-- 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+--+-- == @\<alternate\>@+-- An optional @E@ character indicates an alternate formatting. Currently this only affects @%Z@ and @%z@.+--+-- [@%Ez@] alternate formatting+--+-- == @\<specifier\>@+--+-- 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 \<width\> (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 \<width\> (default 12) decimal places.+--+-- [@%S@] whole seconds of minute+--+-- [@%ES@] seconds of minute, with decimal point and up to \<width\> (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 \<width\> (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 \<width\> (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 \<width\> (default 12) decimal places.+--+-- [@%S@] whole seconds of minute+--+-- [@%ES@] seconds of minute, with decimal point and up to \<width\> (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 \<width\> (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+    _ -> \_ _ -> ""
+ lib/Data/Time/Format/Format/Instances.hs view
@@ -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)
+ lib/Data/Time/Format/ISO8601.hs view
@@ -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
lib/Data/Time/Format/Locale.hs view
@@ -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"),
lib/Data/Time/Format/Parse.hs view
@@ -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
+ lib/Data/Time/Format/Parse/Class.hs view
@@ -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
+ lib/Data/Time/Format/Parse/Instances.hs view
@@ -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
lib/Data/Time/LocalTime.hs view
@@ -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
+ lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs view
@@ -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)
lib/Data/Time/LocalTime/Internal/LocalTime.hs view
@@ -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
lib/Data/Time/LocalTime/Internal/TimeOfDay.hs view
@@ -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)
lib/Data/Time/LocalTime/Internal/TimeZone.hs view
@@ -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
lib/Data/Time/LocalTime/Internal/ZonedTime.hs view
@@ -1,7 +1,5 @@ {-# OPTIONS -fno-warn-orphans #-} #include "HsConfigure.h"---- #hide module Data.Time.LocalTime.Internal.ZonedTime (     ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime
test/main/Main.hs view
@@ -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         ]     ]
+ test/main/Test/Arbitrary.hs view
@@ -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
+ test/main/Test/Calendar/Duration.hs view
@@ -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]
+ test/main/Test/Calendar/Week.hs view
@@ -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]
test/main/Test/Format/Format.hs view
@@ -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     ]
+ test/main/Test/Format/ISO8601.hs view
@@ -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+    ]
test/main/Test/Format/ParseTime.hs view
@@ -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
+ test/main/Test/LocalTime/CalendarDiffTime.hs view
@@ -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+        ]
+ test/main/Test/LocalTime/TimeOfDay.hs view
@@ -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+        ]
time.cabal view
@@ -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