packages feed

time-compat 0.1.0.3 → 1.9.2

raw patch · 21 files changed

+1692/−94 lines, 21 filesdep +HUnitdep +base-orphansdep +deepseqdep −old-timedep ~basedep ~timesetup-changednew-uploader

Dependencies added: HUnit, base-orphans, deepseq, fail, old-locale, semigroups, time-compat

Dependencies removed: old-time

Dependency ranges changed: base, time

Files

LICENSE view
@@ -1,24 +1,30 @@-Copyright (c) 2013, Dag Odenhall+Copyright (c) 2019 time contibutors, Oleg Grenrus+ All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -* Redistributions of source code must retain the above copyright notice,-  this list of conditions and the following disclaimer.+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright notice,-  this list of conditions and the following disclaimer in the documentation-  and/or other materials provided with the distribution.+    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+    * Neither the name of Oleg Grenrus nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ src/Data/Format.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP #-}+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)
+ src/Data/Time/Calendar/Compat.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Time.Calendar.Compat (+    -- * Days+    Day(..),addDays,diffDays,++    -- * CalendarDiffTime+    CalendarDiffDays (..),+    calendarDay,calendarWeek,calendarMonth,calendarYear,scaleCalendarDiffDays,++    -- * Gregorian calendar+    toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength,++    -- calendrical arithmetic+    -- e.g. "one month after March 31st"+    addGregorianMonthsClip,addGregorianMonthsRollOver,+    addGregorianYearsClip,addGregorianYearsRollOver,+    addGregorianDurationClip,addGregorianDurationRollOver,+    diffGregorianDurationClip,diffGregorianDurationRollOver,++    -- re-exported from OrdinalDate+    isLeapYear ,++      -- * Week+    DayOfWeek(..), dayOfWeek,+    ) where++import Data.Time.Calendar+import Data.Time.Format+import Data.Time.Orphans ()++#if !MIN_VERSION_time(1,5,0)+import System.Locale (TimeLocale (..))+#endif++import Data.Data      (Data, Typeable)+import Data.Monoid    (Monoid (..))+import Data.Semigroup (Semigroup (..))+++-------------------------------------------------------------------------------+-- CalendarDiffTime+-------------------------------------------------------------------------------++#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_base(1,9,2)+deriving instance Typeable CalendarDiffDays+deriving instance Data CalendarDiffDays+#endif++#if !MIN_VERSION_time(1,9,0)++data CalendarDiffDays = CalendarDiffDays+    { cdMonths :: Integer+    , cdDays :: Integer+    } deriving (Eq,+    Data+#if __GLASGOW_HASKELL__ >= 802+#endif+    ,Typeable+#if __GLASGOW_HASKELL__ >= 802+#endif+    )++-- | Additive+instance Semigroup CalendarDiffDays where+    CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2)++-- | Additive+instance Monoid CalendarDiffDays where+    mempty  = CalendarDiffDays 0 0+    mappend = (<>)++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)++#endif++-------------------------------------------------------------------------------+-- Gregorian+-------------------------------------------------------------------------------++#if !MIN_VERSION_time(1,9,0)++-- | 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++#endif++-------------------------------------------------------------------------------+-- DayOfWeek+-------------------------------------------------------------------------------++#if !MIN_VERSION_time(1,9,0)++data DayOfWeek+    = Monday+    | Tuesday+    | Wednesday+    | Thursday+    | Friday+    | Saturday+    | Sunday+    deriving (Eq, Show, Read, Typeable)++-- | \"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++toSomeDay :: DayOfWeek -> Day+toSomeDay d = ModifiedJulianDay (fromIntegral $ fromEnum d + 4)++#if MIN_VERSION_time(1,8,0)+#define FORMAT_OPTS tl mpo i+#else+#define FORMAT_OPTS tl mpo+#endif++instance FormatTime DayOfWeek where+    formatCharacter 'u' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'u')+    formatCharacter 'w' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'w')+    formatCharacter 'a' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'a')+    formatCharacter 'A' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'A')+    formatCharacter _  = Nothing++#endif
+ src/Data/Time/Calendar/Easter/Compat.hs view
@@ -0,0 +1,9 @@+module Data.Time.Calendar.Easter.Compat (+    sundayAfter,+    orthodoxPaschalMoon,orthodoxEaster,+    gregorianPaschalMoon,gregorianEaster+    )where++import Data.Time.Orphans ()++import Data.Time.Calendar.Easter
+ src/Data/Time/Calendar/Julian/Compat.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+module Data.Time.Calendar.Julian.Compat (++    toJulianYearAndDay,+    fromJulianYearAndDay,+    fromJulianYearAndDayValid,+    showJulianYearAndDay,+    isJulianLeapYear,++    toJulian,fromJulian,fromJulianValid,showJulian,julianMonthLength,++    -- calendrical arithmetic+    -- e.g. "one month after March 31st"+    addJulianMonthsClip,addJulianMonthsRollOver,+    addJulianYearsClip,addJulianYearsRollOver,+    addJulianDurationClip,addJulianDurationRollOver,+    diffJulianDurationClip,diffJulianDurationRollOver,+    ) where++import Data.Time.Orphans ()++import Data.Time.Calendar.Julian+import Data.Time.Calendar.Compat ++#if !MIN_VERSION_time(1,9,0)++-- | 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++#endif
+ src/Data/Time/Calendar/MonthDay/Compat.hs view
@@ -0,0 +1,7 @@+module Data.Time.Calendar.MonthDay.Compat (+    monthAndDayToDayOfYear,monthAndDayToDayOfYearValid,dayOfYearToMonthAndDay,monthLength,+    ) where++import Data.Time.Orphans ()++import Data.Time.Calendar.MonthDay
+ src/Data/Time/Calendar/OrdinalDate/Compat.hs view
@@ -0,0 +1,17 @@+module Data.Time.Calendar.OrdinalDate.Compat (+    toOrdinalDate,+    fromOrdinalDate,+    fromOrdinalDateValid,+    showOrdinalDate,+    isLeapYear,+    mondayStartWeek,+    sundayStartWeek,+    fromMondayStartWeek,+    fromMondayStartWeekValid,+    fromSundayStartWeek,+    fromSundayStartWeekValid, +    ) where++import Data.Time.Orphans ()++import Data.Time.Calendar.OrdinalDate
+ src/Data/Time/Calendar/Private.hs view
@@ -0,0 +1,65 @@+module Data.Time.Calendar.Private where++import Data.Time.Orphans ()+import Data.Fixed++data PadOption = Pad Int Char | NoPad++showPadded :: PadOption -> String -> String+showPadded NoPad s = s+showPadded (Pad i c) s = replicate (i - length s) c ++ s++class (Num t,Ord t,Show t) => ShowPadded t where+    showPaddedNum :: PadOption -> t -> String++instance ShowPadded Integer where+    showPaddedNum NoPad i = show i+    showPaddedNum pad i | i < 0 = '-':(showPaddedNum pad (negate i))+    showPaddedNum pad i = showPadded pad $ show i++instance ShowPadded Int where+    showPaddedNum NoPad i = show i+    showPaddedNum _pad i | i == minBound = show i+    showPaddedNum pad i | i < 0 = '-':(showPaddedNum pad (negate i))+    showPaddedNum pad i = showPadded pad $ show i++show2Fixed :: Pico -> String+show2Fixed x | x < 10 = '0':(showFixed True x)+show2Fixed x = showFixed True x++show2 :: (ShowPadded t) => t -> String+show2 = showPaddedNum $ Pad 2 '0'++show3 :: (ShowPadded t) => t -> String+show3 = showPaddedNum $ Pad 3 '0'++show4 :: (ShowPadded t) => t -> String+show4 = showPaddedNum $ Pad 4 '0'++mod100 :: (Integral i) => i -> i+mod100 x = mod x 100++div100 :: (Integral i) => i -> i+div100 x = div x 100++clip :: (Ord t) => t -> t -> t -> t+clip a _ x | x < a = a+clip _ b x | x > b = b+clip _ _ x = x++clipValid :: (Ord t) => t -> t -> t -> Maybe t+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)
+ src/Data/Time/Calendar/WeekDate/Compat.hs view
@@ -0,0 +1,10 @@+module Data.Time.Calendar.WeekDate.Compat (+    toWeekDate,+    fromWeekDate,+    fromWeekDateValid,+    showWeekDate,+    ) where++import Data.Time.Orphans ()++import Data.Time.Calendar.WeekDate
+ src/Data/Time/Clock/Compat.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+module Data.Time.Clock.Compat (+    -- * Universal Time+    -- | Time as measured by the Earth.+    UniversalTime(..),++    -- * Absolute intervals, DiffTime+    DiffTime,+    secondsToDiffTime,+    picosecondsToDiffTime,+    diffTimeToPicoseconds,++    -- * UTCTime+    UTCTime (..),++    -- * NominalDiffTime+    NominalDiffTime,+    secondsToNominalDiffTime,+    nominalDiffTimeToSeconds,+    nominalDay,++    -- * UTC differences+    addUTCTime,+    diffUTCTime,+  +    -- * Current time+    getCurrentTime,+    getTime_resolution+    ) where++import Data.Time.Orphans ()++import Data.Time.Clock+import Data.Fixed (Pico)++#if !MIN_VERSION_time(1,9,1)++-- | Create a 'NominalDiffTime' from a number of seconds.+secondsToNominalDiffTime :: Pico -> NominalDiffTime+secondsToNominalDiffTime = realToFrac++-- | Get the seconds in a 'NominalDiffTime'.+nominalDiffTimeToSeconds :: NominalDiffTime -> Pico+nominalDiffTimeToSeconds = realToFrac++#endif++#if !MIN_VERSION_time(1,8,0)+-- | One day in 'NominalDiffTime'.+nominalDay :: NominalDiffTime+nominalDay = 86400+#endif++#if !MIN_VERSION_time(1,8,0)+-- | The resolution of 'getSystemTime', 'getCurrentTime', 'getPOSIXTime'+getTime_resolution :: DiffTime+getTime_resolution = 1E-6 -- microsecond+#endif++#if !MIN_VERSION_time(1,6,0)+-- | Get the number of picoseconds in a 'DiffTime'.+diffTimeToPicoseconds :: DiffTime -> Integer+#if MIN_VERSION_time(1,4,0)+diffTimeToPicoseconds = truncate . (1000000000000 *)+#else+diffTimeToPicoseconds = truncate . toRational . (1000000000000 *)+#endif+#endif
+ src/Data/Time/Clock/POSIX/Compat.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+module Data.Time.Clock.POSIX.Compat (+    posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime,getCurrentTime,+    systemToPOSIXTime,+    ) where++import Data.Time.Orphans ()++import Data.Time+import Data.Time.Clock.POSIX+import Data.Time.Clock.System.Compat++#if !MIN_VERSION_time(1,8,0)+systemToPOSIXTime :: SystemTime -> POSIXTime+systemToPOSIXTime (MkSystemTime s ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9+#endif
+ src/Data/Time/Clock/System/Compat.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Time.Clock.System.Compat (+    systemEpochDay,+    SystemTime(..),+    truncateSystemTimeLeapSecond,+    getSystemTime,+    systemToUTCTime,+    utcToSystemTime,+    systemToTAITime,+    ) where++import Data.Time.Orphans ()++#if MIN_VERSION_time(1,8,0)+import Data.Time.Clock.System+#else++import Control.DeepSeq (NFData (..))+import Data.Int (Int64)+import Data.Word (Word32)+import Data.Typeable (Typeable)++import Data.Time.Clock.TAI.Compat+import Data.Time.Clock.POSIX+import Data.Time.Compat++-- | 'SystemTime' is time returned by system clock functions.+-- Its semantics depends on the clock function, but the epoch is typically the beginning of 1970.+-- Note that 'systemNanoseconds' of 1E9 to 2E9-1 can be used to represent leap seconds.+data SystemTime = MkSystemTime+    { systemSeconds ::     {-# UNPACK #-} !Int64+    , systemNanoseconds :: {-# UNPACK #-} !Word32+    } deriving (Eq,Ord,Show,Typeable)++instance NFData SystemTime where+    rnf a = a `seq` ()++-- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored.+-- 'getSystemTime' is typically much faster than 'getCurrentTime'.+getSystemTime :: IO SystemTime+++-- Use gettimeofday+getSystemTime = do+    t <- getPOSIXTime+    let secs = truncate t+    let nsecs = truncate $ 1000000000 * (t - fromIntegral secs)+    return (MkSystemTime secs nsecs)++-- | Map leap-second values to the start of the following second.+-- The resulting 'systemNanoseconds' will always be in the range 0 to 1E9-1.+truncateSystemTimeLeapSecond :: SystemTime -> SystemTime+truncateSystemTimeLeapSecond (MkSystemTime seconds nanoseconds) | nanoseconds >= 1000000000 = MkSystemTime (succ seconds) 0+truncateSystemTimeLeapSecond t = t++-- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC.+systemToUTCTime :: SystemTime -> UTCTime+systemToUTCTime (MkSystemTime seconds nanoseconds) = let+    days :: Int64+    timeSeconds :: Int64+    (days, timeSeconds) = seconds `divMod` 86400++    day :: Day+    day = addDays (fromIntegral days) systemEpochDay++    timeNanoseconds :: Int64+    timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds)++    timePicoseconds :: Int64+    timePicoseconds = timeNanoseconds * 1000++    time :: DiffTime+    time = picosecondsToDiffTime $ fromIntegral timePicoseconds+    in UTCTime day time++-- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC.+utcToSystemTime :: UTCTime -> SystemTime+utcToSystemTime (UTCTime day time) = let+    days :: Int64+    days = fromIntegral $ diffDays day systemEpochDay++    timePicoseconds :: Int64+    timePicoseconds = fromIntegral $ diffTimeToPicoseconds time++    timeNanoseconds :: Int64+    timeNanoseconds = timePicoseconds `div` 1000++    timeSeconds :: Int64+    nanoseconds :: Int64+    (timeSeconds,nanoseconds) = if timeNanoseconds >= 86400000000000 then (86399,timeNanoseconds - 86399000000000) else timeNanoseconds `divMod` 1000000000++    seconds :: Int64+    seconds = days * 86400 + timeSeconds++    in MkSystemTime seconds $ fromIntegral nanoseconds++systemEpochAbsolute :: AbsoluteTime+systemEpochAbsolute = taiNominalDayStart systemEpochDay++-- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI.+systemToTAITime :: SystemTime -> AbsoluteTime+systemToTAITime (MkSystemTime s ns) = let+    diff :: DiffTime+    diff = (fromIntegral s) + (fromIntegral ns) * 1E-9+    in addAbsoluteTime diff systemEpochAbsolute++-- | The day of the epoch of 'SystemTime', 1970-01-01+systemEpochDay :: Day+systemEpochDay = ModifiedJulianDay 40587++#endif
+ src/Data/Time/Clock/TAI/Compat.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+module Data.Time.Clock.TAI.Compat (+    -- * TAI arithmetic+    AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime,+    taiNominalDayStart,++    -- * leap-second map type+    LeapSecondMap',++    -- * conversion between UTC and TAI with map+    utcDayLength,utcToTAITime,taiToUTCTime,++    taiClock,+    ) where++import Data.Time.Orphans ()++import Data.Time.Compat+import Data.Time.Clock.TAI++-- | This type is either 'LeapSecondMap' or 'LeapSecondTable', depending+-- on the version of @time@ (changed in @time-1.7.0@).+#if MIN_VERSION_time(1,7,0)+type LeapSecondMap' = LeapSecondMap+#else+type LeapSecondMap' = LeapSecondTable+#endif++#if !(MIN_VERSION_time(1,8,0))+taiNominalDayStart :: Day -> AbsoluteTime+taiNominalDayStart (ModifiedJulianDay ds) =+   addAbsoluteTime (secondsToDiffTime (ds * 86400)) taiEpoch++-- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention.+taiClock :: Maybe (DiffTime,IO AbsoluteTime)+taiClock = Nothing+#endif
src/Data/Time/Compat.hs view
@@ -1,54 +1,13 @@-{-# LANGUAGE RecordWildCards #-}---- | Compatibility with the---   <http://hackage.haskell.org/package/old-time old-time> package for the---   \"new\" <http://hackage.haskell.org/package/time time> package.------   This is useful for writing portable code; in particular, if you're---   using the <http://hackage.haskell.org/package/directory directory>---   package and you want your code to build with both GHC 7.6 and earlier---   versions.  The version of @directory@ used with GHC 7.6 changed---   a dependency from @old-time@ to @time@ which means its---   @getModificationTime@ function now returns a 'Time.UTCTime' instead of---   a 'OldTime.ClockTime'.  This type affects the public API of many---   libraries that use it.  To make such libraries portable, port your---   code to use the @time@ package and to only rely on 'Time.UTCTime' in---   its public API, and call 'toUTCTime' on the values returned by---   functions like @getModificationTime@, for example:------     >fmap toUTCTime getModificationTime------   If you're using @directory-1.2@, 'toUTCTime' will just be 'id' and the---   original value is returned intact.  If you're using an older---   @directory@, for example because you're building with GHC 7.4, the---   'OldTime.ClockTime' returned by @getModificationTime@ will be---   converted to a 'Time.UTCTime' and will be compatible with your code---   ported to the new @time@ package.-module Data.Time.Compat-    ( -- * Converting between representations-      ToUTCTime(..)-    )-  where--import qualified Data.Time   as Time-import qualified System.Time as OldTime--class ToUTCTime a where-    toUTCTime :: a -> Time.UTCTime--instance ToUTCTime Time.UTCTime where-    toUTCTime = id+module Data.Time.Compat (+    module Data.Time.Calendar.Compat,+    module Data.Time.Clock.Compat,+    module Data.Time.LocalTime.Compat,+    module Data.Time.Format.Compat,+    ) where -instance ToUTCTime OldTime.ClockTime where-    toUTCTime = toUTCTime . OldTime.toUTCTime+import Data.Time.Orphans () -instance ToUTCTime OldTime.CalendarTime where-    toUTCTime OldTime.CalendarTime{..} =-        Time.UTCTime day diffTime-      where-        year = fromIntegral ctYear-        month = fromEnum ctMonth + 1-        day = Time.fromGregorian year month ctDay-        sec = ctHour*60^2 + ctMin*60 + ctSec-        pico = fromIntegral sec*10^12 + ctPicosec-        diffTime = Time.picosecondsToDiffTime pico+import Data.Time.Calendar.Compat+import Data.Time.Clock.Compat+import Data.Time.LocalTime.Compat+import Data.Time.Format.Compat
+ src/Data/Time/Format/Compat.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+module Data.Time.Format.Compat (+    -- * UNIX-style formatting+    FormatTime(),formatTime,++    -- * UNIX-style parsing+    -- ** __Note__ in compat mode acceptWS argument is ignored, it's always 'True'.+    parseTimeM, parseTimeOrError,+    readSTime, readPTime,+    parseTime, readTime, readsTime,+    ParseTime(),++    -- * Locale+    TimeLocale(..),++    defaultTimeLocale,++    iso8601DateFormat,+    rfc822DateFormat,+    ) where++import Data.Time.Orphans ()++import Data.Time.Format++#if !MIN_VERSION_time(1,5,0)+import System.Locale (TimeLocale, defaultTimeLocale, iso8601DateFormat, rfc822DateFormat)+import qualified Control.Monad.Fail as Fail+import Text.ParserCombinators.ReadP (readP_to_S, readS_to_P, ReadP)++parseTimeM+    :: (Fail.MonadFail m, ParseTime t)+    => Bool       -- ^ Accept leading and trailing whitespace?+    -> TimeLocale -- ^ Time locale.+    -> String     -- ^ Format string.+    -> String     -- ^ Input string.+    -> m t        -- ^ Return the time value, or fail if the in+parseTimeM _acceptWS l fmt s = case parseTime l fmt s of+    Just x  -> return x+    Nothing -> Fail.fail "parseTimeM: no parse"++parseTimeOrError+    :: ParseTime t+    => Bool       -- ^ Accept leading and trailing whitespace?+    -> TimeLocale -- ^ Time locale.+    -> String     -- ^ Format string.+    -> String     -- ^ Input string.+    -> t          -- ^ The time value.+parseTimeOrError _acceptWS l fmt s = case parseTime l fmt s of+    Just x  -> x+    Nothing -> error "parseTimeOrError: no parse"++-- | Parse a time value given a format string.  See 'parseTimeM' for details.+readSTime :: ParseTime t =>+             Bool       -- ^ Accept leading whitespace?+          -> TimeLocale -- ^ Time locale.+          -> String     -- ^ Format string+          -> ReadS t+readSTime _acceptWS l f  = readsTime l f++-- | Parse a time value given a format string.  See 'parseTimeM' for details.+readPTime :: ParseTime t =>+             Bool       -- ^ Accept leading whitespace?+          -> TimeLocale -- ^ Time locale.+          -> String     -- ^ Format string+          -> ReadP t+readPTime acceptWS l f = readS_to_P (readSTime acceptWS l f)+#endif
+ src/Data/Time/Format/ISO8601/Compat.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE CPP #-}+module Data.Time.Format.ISO8601.Compat (+    -- * 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++import Data.Time.Orphans ()++#if MIN_VERSION_time(1,9,0)+import Data.Time.Format.ISO8601+#else++import Control.Monad.Fail+import Prelude hiding (fail)+import Data.Monoid+import Data.Ratio+import Data.Fixed+import Text.ParserCombinators.ReadP+import Data.Format+import Data.Time+import Data.Time.Calendar.Compat+import Data.Time.Calendar.OrdinalDate.Compat+import Data.Time.Calendar.WeekDate.Compat+import Data.Time.LocalTime.Compat+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++#endif
+ src/Data/Time/LocalTime/Compat.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+module Data.Time.LocalTime.Compat (+    -- * Time zones+    TimeZone(..),timeZoneOffsetString,timeZoneOffsetString',minutesToTimeZone,hoursToTimeZone,utc,++    -- getting the locale time zone+    getTimeZone,getCurrentTimeZone,++    -- * Time of day+    TimeOfDay(..),midnight,midday,makeTimeOfDayValid,+    timeToDaysAndTimeOfDay,daysAndTimeOfDayToTime,+    utcToLocalTimeOfDay,localToUTCTimeOfDay,+    timeToTimeOfDay,timeOfDayToTime,+    dayFractionToTimeOfDay,timeOfDayToDayFraction,++    -- * CalendarDiffTime+    CalendarDiffTime (..),+    calendarTimeDays, calendarTimeTime, scaleCalendarDiffTime,++    -- * Local Time+    LocalTime(..),++    addLocalTime,diffLocalTime,++    -- converting UTC and UT1 times to LocalTime+    utcToLocalTime,localTimeToUTC,ut1ToLocalTime,localTimeToUT1,++    -- * Zoned Time+    ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime,+    ) where++import Data.Time.Orphans ()++import Data.Time.LocalTime+import Data.Time.Clock.Compat+import Data.Time.Calendar.Compat++import Data.Fixed (Pico (..), showFixed, divMod')+import Data.Monoid (Monoid (..))+import Data.Data (Data, Typeable)+import Data.Semigroup (Semigroup (..))++-------------------------------------------------------------------------------+-- TimeOfDay+-------------------------------------------------------------------------------++#if !MIN_VERSION_time(1,9,0)++-- | 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++#endif++-------------------------------------------------------------------------------+-- CalendarDiffTime+-------------------------------------------------------------------------------++#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_base(1,9,2)+deriving instance Typeable CalendarDiffTime+deriving instance Data CalendarDiffTime+#endif++#if !MIN_VERSION_time(1,9,2)++data CalendarDiffTime = CalendarDiffTime+    { ctMonths :: Integer+    , ctTime :: NominalDiffTime+    } deriving (Eq,+    Data+    ,Typeable+    )++-- | Additive+instance Semigroup CalendarDiffTime where++    CalendarDiffTime m1 d1 <> CalendarDiffTime m2 d2 = CalendarDiffTime (m1 + m2) (d1 + d2)+instance Monoid CalendarDiffTime where+    mempty = CalendarDiffTime 0 0+    mappend = (<>)++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)+#endif++-------------------------------------------------------------------------------+-- LocalTime+-------------------------------------------------------------------------------++#if !MIN_VERSION_time(1,9,0)++-- | 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)++#endif
+ src/Data/Time/Orphans.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+module Data.Time.Orphans where++import Data.Orphans ()++import Control.DeepSeq (NFData (..))+import Data.Time+import Data.Time.Clock+import Data.Time.Clock.TAI+import Data.Time.Format++#if !MIN_VERSION_time(1,4,0)+instance NFData Day where+    rnf (ModifiedJulianDay d) = rnf d++instance NFData UniversalTime where+    rnf (ModJulianDate d) = rnf d++instance NFData DiffTime where+    rnf d = d `seq` ()++instance NFData AbsoluteTime where+    rnf d = d `seq` ()++instance NFData UTCTime where+    rnf (UTCTime d t) = rnf d `seq` rnf t++instance NFData NominalDiffTime where+    rnf d = d `seq` ()++instance NFData LocalTime where+    rnf (LocalTime d tod) = rnf d `seq` rnf tod++instance NFData ZonedTime where+    rnf (ZonedTime lt tz) = rnf lt `seq` rnf tz++instance NFData TimeOfDay where+    rnf (TimeOfDay h m s) = rnf h `seq` rnf m `seq` rnf s++instance NFData TimeZone where+    rnf (TimeZone a b c) = rnf a `seq` rnf b `seq` rnf c+#endif++#if !MIN_VERSION_time(1,6,0)+instance ParseTime UniversalTime where+    -- substituteTimeSpecifier _ = timeSubstituteTimeSpecifier+    -- parseTimeSpecifier _ = timeParseTimeSpecifier+    buildTime l xs = localTimeToUT1 0 (buildTime l xs)++instance FormatTime UniversalTime where+    formatCharacter c = fmap (\f tl fo t -> f tl fo (ut1ToLocalTime 0 t)) (formatCharacter c)+#endif
+ test/Test.hs view
@@ -0,0 +1,68 @@+module Main where++import Control.DeepSeq (force)++import Data.Time.Calendar.Compat+import Data.Time.Clock.System.Compat+import Data.Time.Clock.TAI.Compat+import Data.Time.Compat+import Data.Time.Format.Compat+import Test.HUnit.Base               ((@?=))++main :: IO ()+main = do+    utc <- getCurrentTime++    -- UTCTime+    putStrLn $ formatTime defaultTimeLocale rfc822DateFormat (force utc)++    -- ZonedTime+    zt <- getZonedTime+    putStrLn $ formatTime defaultTimeLocale rfc822DateFormat (force zt)++    -- SystemTime+    st <- getSystemTime+    print $ force st++    -- FormatTime DayOfWeek+    formatTime defaultTimeLocale "%u %w %a %A" Monday @?= "1 1 Mon Monday"++    -- TAI taiNominalDayStart+    show (taiNominalDayStart (ModifiedJulianDay 123)) @?= "1859-03-20 00:00:00 TAI"++_ParseTimeInstances :: [()]+_ParseTimeInstances =+    [ () -- test (undefined :: CalendarDiffTime)+    , test (undefined :: Day)+    , () -- test (undefined :: DiffTime)+    , () -- test (undefined :: NominalDiffTime)+    , test (undefined :: UTCTime)+    , test (undefined :: UniversalTime)+    , () -- test (undefined :: CalendarDiffTime)+    , test (undefined :: TimeZone)+    , test (undefined :: TimeOfDay)+    , test (undefined :: LocalTime)+    , test (undefined :: ZonedTime)+    ]+  where+    test :: ParseTime t => t -> ()+    test _ = ()++_FormatTimeInstances :: [()]+_FormatTimeInstances =+    [ () -- test (undefined :: CalendarDiffTime)+    , test (undefined :: Day)+    , () -- test (undefined :: DiffTime)+    , () -- test (undefined :: NominalDiffTime)+    , test (undefined :: UTCTime)+    , test (undefined :: UniversalTime)+    , () -- test (undefined :: CalendarDiffTime)+    , test (undefined :: TimeZone)+    , test (undefined :: TimeOfDay)+    , test (undefined :: LocalTime)+    , test (undefined :: ZonedTime)+    , test (undefined :: DayOfWeek)+    ]+  where+    test :: FormatTime t => t -> ()+    test _ = ()
time-compat.cabal view
@@ -1,29 +1,97 @@-name          : time-compat-version       : 0.1.0.3-homepage      : http://hub.darcs.net/dag/time-compat-bug-reports   : http://hub.darcs.net/dag/time-compat/issues-category      : System-cabal-version : >= 1.10-build-type    : Simple+cabal-version: 2.2+name:          time-compat+version:       1.9.2+tested-with:   GHC ==7.8.4 || ==7.6.3 || ==7.4.2+synopsis:      Compatibility package for time+description:+  This packages tries to compat as much of @time@ features as possible.+  .+  /TODO:/ Difference type @ParseTime@ and @FormatTime@ instances are missing. -license       : BSD3-license-file  : LICENSE-author        : Dag Odenhall-maintainer    : dag.odenhall@gmail.com+category:      Time, Compatibility+license:       BSD-3-Clause+license-file:  LICENSE+maintainer:    Oleg Grenrus <oleg.grenrus@iki.fi>+author:        Ashley Yakeley -synopsis      : Compatibility with old-time for the time package-description   : Compatibility with the <old-time> package for the \"new\"-                <time> package.+tested-with:+  GHC==7.0.4+  GHC==7.2.2,+  GHC==7.4.2,+  GHC==7.6.3,+  GHC==7.8.4,+  GHC==7.10.3,+  GHC==8.0.2,+  GHC==8.2.2,+  GHC==8.4.4,+  GHC==8.6.5,+  GHC==8.8.1  source-repository head-  type     : darcs-  location : http://hub.darcs.net/dag/time-compat+  type:      git+  location:  https://github.com/phadej/time-compat.git ++flag old-locale+  description: If true, use old-locale, otherwise use time 1.5 or newer.+  manual:      False+  default:     False+ library-  hs-source-dirs   : src-  default-language : Haskell2010-  ghc-options      : -Wall -fno-warn-type-defaults-  exposed-modules  : Data.Time.Compat-  build-depends    : base == 4.*,-                     old-time,-                     time+  default-language: Haskell2010+  hs-source-dirs:   src+  other-extensions: CPP++  if impl(ghc >=7.2)+    default-extensions: Trustworthy++  build-depends:+    , base          >=4.3     && <4.14+    , base-orphans  ^>=0.8.1+    , deepseq       ^>=1.3.0.0 || ^>=1.4.1.1+    , time          ^>=1.2.0.3 || ^>=1.4 || ^>=1.5.0.1 || ^>=1.6.0.1 || ^>=1.8.0.2 || ^>=1.9.2++  if flag(old-locale)+    build-depends:+      , old-locale  ^>=1.0.0.2+      , time        >=0       && <1.5++  else+    build-depends: time >=1.5++  if !impl(ghc >=8.0)+    build-depends:+      , fail        ^>=4.9.0.0+      , semigroups  >=0.18.5  && <0.20++  exposed-modules:+    Data.Time.Calendar.Compat+    Data.Time.Calendar.Easter.Compat+    Data.Time.Calendar.Julian.Compat+    Data.Time.Calendar.MonthDay.Compat+    Data.Time.Calendar.OrdinalDate.Compat+    Data.Time.Calendar.WeekDate.Compat+    Data.Time.Clock.Compat+    Data.Time.Clock.POSIX.Compat+    Data.Time.Clock.System.Compat+    Data.Time.Clock.TAI.Compat+    Data.Time.Compat+    Data.Time.Format.Compat+    Data.Time.Format.ISO8601.Compat+    Data.Time.LocalTime.Compat++  other-modules:+    Data.Format+    Data.Time.Calendar.Private+    Data.Time.Orphans++test-suite instances+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Test.hs+  build-depends:+    , base+    , deepseq+    , time-compat+    , HUnit ^>=1.6.0.0 || ^>=1.3.1.2