packages feed

thyme 0.2.0.0 → 0.2.1.0

raw patch · 18 files changed

+871/−255 lines, 18 filesdep +containersdep +utf8-stringdep ~QuickCheckdep ~attoparsecdep ~base

Dependencies added: containers, utf8-string

Dependency ranges changed: QuickCheck, attoparsec, base, bytestring, criterion, lens, old-locale, random, time, transformers, vector-space

Files

src/Data/Thyme/Calendar.hs view
@@ -4,9 +4,10 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Thyme.Calendar (+module Data.Thyme.Calendar+    ( Years, Months, Days     -- * Days-      Day (..)+    , Day (..)     -- * Gregorian calendar     , Year, Month, DayOfMonth     , YearMonthDay (..)@@ -44,7 +45,7 @@ {-# INLINEABLE gregorianValid #-} gregorianValid :: YearMonthDay -> Maybe Day gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y-    <$> monthDayToDayOfYearValid (isLeapYear y) (MonthDay m d)+    <$> monthDayValid (isLeapYear y) (MonthDay m d)  {-# INLINEABLE showGregorian #-} showGregorian :: Day -> String@@ -58,11 +59,37 @@ #endif  {-# INLINE gregorianMonthLength #-}-gregorianMonthLength :: Year -> Month -> Int+gregorianMonthLength :: Year -> Month -> Days gregorianMonthLength = monthLength . isLeapYear --- TODO: addGregorianMonthsClip addGregorianMonthsRollover--- TODO: addGregorianYearsClip addGregorianYearsRollover+{-# INLINEABLE gregorianMonthsClip #-}+gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay+gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m'+        $ min (gregorianMonthLength y' m') d where+    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12++{-# INLINEABLE gregorianMonthsRollover #-}+gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay+gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of+    True -> YearMonthDay y' m' d+    False -> case m' < 12 of+        True -> YearMonthDay y' (m' + 1) (d - len)+        False -> YearMonthDay (y' + 1) 1 (d - len)+  where+    ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12+    len = gregorianMonthLength y' m'++{-# INLINEABLE gregorianYearsClip #-}+gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay+gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29)+    | not (isLeapYear y') = YearMonthDay y' 2 28+gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d++{-# INLINEABLE gregorianYearsRollover #-}+gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay+gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29)+    | not (isLeapYear y') = YearMonthDay y' 3 1+gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d  -- * Lenses thymeLenses ''Day
src/Data/Thyme/Calendar/Internal.hs view
@@ -18,6 +18,10 @@ import Data.Ix import Data.Thyme.Format.Internal +type Years = Int+type Months = Int+type Days = Int+ -- | The Modified Julian Day is a standard count of days, with zero being -- the day 1858-11-17. newtype Day = ModifiedJulianDay@@ -25,7 +29,7 @@     } deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)  instance AffineSpace Day where-    type Diff Day = Int+    type Diff Day = Days     {-# INLINE (.-.) #-}     ModifiedJulianDay a .-. ModifiedJulianDay b = fromIntegral (a - b)     {-# INLINE (.+^) #-}@@ -70,12 +74,10 @@             (fromIntegral year) (fromIntegral yd) where         -- pilfered         a = mjd + 678575-        quadcent = div a 146097-        b = mod a 146097+        (quadcent, b) = divMod a 146097         cent = min (div b 36524) 3         c = b - cent * 36524-        quad = div c 1461-        d = mod c 1461+        (quad, d) = divMod c 1461         y = min (div d 365) 3         yd = d - y * 365 + 1         year = quadcent * 400 + cent * 100 + quad * 4 + y + 1@@ -159,11 +161,11 @@     shows04 y . (++) "-W" . shows02 w . (:) '-' . shows d $ ""  --------------------------------------------------------------------------- * Non-standard week dates  -- | Weeks numbered from 0 to 53, starting with the first Sunday of the year -- as the first day of week 1. The last week of a given year and week 0 of--- the next both refer to the same week.+-- the next both refer to the same week, but not all 'DayOfWeek' are valid.+-- 'Year' coincides with that of 'gregorian'. data SundayWeek = SundayWeek     { swYear :: {-# UNPACK #-}!Year     , swWeek :: {-# UNPACK #-}!WeekOfYear@@ -209,8 +211,9 @@ ------------------------------------------------------------------------  -- | Weeks numbered from 0 to 53, starting with the first Monday of the year--- as the first day of week 01. The last week of a given year and week 0 of+-- as the first day of week 1. The last week of a given year and week 0 of -- the next both refer to the same week, but not all 'DayOfWeek' are valid.+-- 'Year' coincides with that of 'gregorian'. data MondayWeek = MondayWeek     { mwYear :: {-# UNPACK #-}!Year     , mwWeek :: {-# UNPACK #-}!WeekOfYear
src/Data/Thyme/Calendar/MonthDay.hs view
@@ -41,13 +41,13 @@     toOrdinal :: MonthDay -> DayOfYear     toOrdinal (MonthDay m d) = T.monthAndDayToDayOfYear leap m d -{-# INLINEABLE monthDayToDayOfYearValid #-}-monthDayToDayOfYearValid :: Bool -> MonthDay -> Maybe DayOfYear-monthDayToDayOfYearValid leap md@(MonthDay m d) = review (monthDay leap) md+{-# INLINEABLE monthDayValid #-}+monthDayValid :: Bool -> MonthDay -> Maybe DayOfYear+monthDayValid leap md@(MonthDay m d) = review (monthDay leap) md     <$ guard (1 <= m && m <= 12 && 1 <= d && d <= T.monthLength leap m)  {-# INLINE monthLength #-}-monthLength :: Bool -> Month -> Int+monthLength :: Bool -> Month -> Days monthLength = T.monthLength  -- * Lenses
src/Data/Thyme/Calendar/WeekDate.hs view
@@ -7,7 +7,9 @@     ( Year, WeekOfYear, DayOfWeek     -- * ISO 8601 Week Date     , WeekDate (..), weekDate, weekDateValid, showWeekDate+    -- * Weeks starting Sunday     , SundayWeek (..), sundayWeek, sundayWeekValid+    -- * Weeks starting Monday     , MondayWeek (..), mondayWeek, mondayWeekValid     , module Data.Thyme.Calendar.WeekDate     ) where
+ src/Data/Thyme/Calendar/WeekdayOfMonth.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Data.Thyme.Calendar.WeekdayOfMonth where++import Prelude+import Control.Applicative+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Data+import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal+import Data.Thyme.Calendar.MonthDay+import Data.Thyme.TH++data WeekdayOfMonth = WeekdayOfMonth+    { womYear :: {-# UNPACK #-}!Year+    , womMonth :: {-# UNPACK #-}!Month+    , womNth :: {-# UNPACK #-}!Int -- ^ ±1–5, negative means n-th last+    , womDayOfWeek :: {-# UNPACK #-}!DayOfWeek+    } deriving (Eq, Ord, Data, Typeable, Show)++instance NFData WeekdayOfMonth++{-# INLINE weekdayOfMonth #-}+weekdayOfMonth :: Simple Iso Day WeekdayOfMonth+weekdayOfMonth = iso toWeekday fromWeekday where++    {-# INLINEABLE toWeekday #-}+    toWeekday :: Day -> WeekdayOfMonth+    toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where+        YearMonthDay y m d = view yearMonthDay ord+        WeekDate _ _ wd = toWeekOrdinal ord day+        n = div (d - 1) 7++    {-# INLINEABLE fromWeekday #-}+    fromWeekday :: WeekdayOfMonth -> Day+    fromWeekday (WeekdayOfMonth y m n wd) = refDay .+^ s * offset where+        refOrd = review yearMonthDay . YearMonthDay y m $+            if n < 0 then monthLength (isLeapYear y) m else 1+        refDay = review ordinalDate refOrd+        WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay+        s = signum n+        wo = s * (wd - wd1)+        offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo++{-# INLINEABLE weekdayOfMonthValid #-}+weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day+weekdayOfMonthValid (WeekdayOfMonth y m n wd) = (refDay .+^ s * offset)+        <$ guard (n /= 0 && 1 <= wd && wd <= 7 && offset < len) where+    len = monthLength (isLeapYear y) m+    refOrd = review yearMonthDay $ YearMonthDay y m (if n < 0 then len else 1)+    refDay = review ordinalDate refOrd+    WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay+    s = signum n+    wo = s * (wd - wd1)+    offset = (abs n - 1) * 7 + if wo < 0 then wo + 7 else wo++-- * Lenses+thymeLenses ''WeekdayOfMonth+
src/Data/Thyme/Clock.hs view
@@ -3,15 +3,18 @@  module Data.Thyme.Clock (     -- * Universal Time+      UniversalTime+    , modJulianDate      -- * Absolute intervals-      DiffTime+    , DiffTime     , microsecondsToDiffTime      -- * UTC     , UTCTime, UTCView (..)     , utcTime     , NominalDiffTime+    , microsecondsToNominalDiffTime     , module Data.Thyme.Clock      -- * Lenses@@ -20,8 +23,7 @@  import Prelude import Control.Lens-import Data.Thyme.Clock.Scale-import Data.Thyme.Clock.UTC+import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX #if !SHOW_INTERNAL import Data.Thyme.LocalTime.Internal
+ src/Data/Thyme/Clock/Internal.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- #hide+module Data.Thyme.Clock.Internal where++import Prelude+import Control.DeepSeq+import Control.Lens+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Basis+import Data.Data+import Data.Int+import Data.Ix+import Data.Micro+import Data.Thyme.Calendar+import Data.VectorSpace++newtype DiffTime = DiffTime Micro+    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)++#if SHOW_INTERNAL+deriving instance Show DiffTime+#else+instance Show DiffTime where+    showsPrec p (DiffTime a) rest = showsPrec p a ('s' : rest)+#endif++instance VectorSpace DiffTime where+    type Scalar DiffTime = Rational+    {-# INLINE (*^) #-}+    s *^ DiffTime t = DiffTime (s *^ t)++instance HasBasis DiffTime where+    type Basis DiffTime = ()+    {-# INLINE basisValue #-}+    basisValue () = DiffTime (basisValue ())+    {-# INLINE decompose #-}+    decompose (DiffTime a) = decompose a+    {-# INLINE decompose' #-}+    decompose' (DiffTime a) = decompose' a++#if INSTANCE_NUM+deriving instance Num DiffTime+deriving instance Real DiffTime+deriving instance Fractional DiffTime+deriving instance RealFrac DiffTime+#endif++{-# INLINE microsecondsToDiffTime #-}+microsecondsToDiffTime :: Int64 -> DiffTime+microsecondsToDiffTime = DiffTime . Micro++------------------------------------------------------------------------++newtype NominalDiffTime = NominalDiffTime Micro+    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)++#if SHOW_INTERNAL+deriving instance Show NominalDiffTime+#else+instance Show NominalDiffTime where+    showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)+#endif++instance VectorSpace NominalDiffTime where+    type Scalar NominalDiffTime = Rational+    {-# INLINE (*^) #-}+    s *^ NominalDiffTime t = NominalDiffTime (s *^ t)++instance HasBasis NominalDiffTime where+    type Basis NominalDiffTime = ()+    {-# INLINE basisValue #-}+    basisValue () = NominalDiffTime (basisValue ())+    {-# INLINE decompose #-}+    decompose (NominalDiffTime a) = decompose a+    {-# INLINE decompose' #-}+    decompose' (NominalDiffTime a) = decompose' a++#if INSTANCE_NUM+deriving instance Num NominalDiffTime+deriving instance Real NominalDiffTime+deriving instance Fractional NominalDiffTime+deriving instance RealFrac NominalDiffTime+#endif++{-# INLINE microsecondsToNominalDiffTime #-}+microsecondsToNominalDiffTime :: Int64 -> NominalDiffTime+microsecondsToNominalDiffTime = NominalDiffTime . Micro++{-# INLINE posixDayLength #-}+posixDayLength :: NominalDiffTime+posixDayLength = NominalDiffTime (toMicro 86400)++------------------------------------------------------------------------++newtype UniversalTime = UniversalRep NominalDiffTime -- since MJD epoch+    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)++{-# INLINE modJulianDate #-}+modJulianDate :: Simple Iso UniversalTime Rational+modJulianDate = iso+    (\ (UniversalRep t) -> t ^/^ posixDayLength)+    (UniversalRep . (*^ posixDayLength))++------------------------------------------------------------------------++newtype UTCTime = UTCRep NominalDiffTime -- since MJD epoch+    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)++data UTCView = UTCTime+    { utctDay :: {-# UNPACK #-}!Day+    , utctDayTime :: {-# UNPACK #-}!DiffTime+    } deriving (Eq, Ord, Data, Typeable, Show)++instance NFData UTCView++_utctDay :: Simple Lens UTCTime Day+_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t)++_utctDayTime :: Simple Lens UTCTime DiffTime+_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t)++instance AffineSpace UTCTime where+    type Diff UTCTime = NominalDiffTime+    {-# INLINE (.-.) #-}+    UTCRep a .-. UTCRep b = a ^-^ b+    {-# INLINE (.+^) #-}+    UTCRep a .+^ d = UTCRep (a ^+^ d)++{-# INLINE utcTime #-}+utcTime :: Simple Iso UTCTime UTCView+utcTime = iso toView fromView where+    NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength++    {-# INLINE toView #-}+    toView :: UTCTime -> UTCView+    toView (UTCRep (NominalDiffTime a)) = UTCTime+            (ModifiedJulianDay mjd) (DiffTime dt) where+        (fromIntegral -> mjd, dt) = microDivMod a posixDay++    {-# INLINE fromView #-}+    fromView :: UTCView -> UTCTime+    fromView (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where+        a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt)+
src/Data/Thyme/Clock/POSIX.hs view
@@ -6,28 +6,18 @@ import Prelude import Control.Lens import Data.AdditiveGroup-import Data.AffineSpace import Data.Micro+import Data.Thyme.Clock.Internal import qualified Data.Time.Clock.POSIX as T-import Data.Thyme.Calendar.Internal-import Data.Thyme.Clock.Scale-import Data.Thyme.Clock.UTC+import Data.VectorSpace  type POSIXTime = NominalDiffTime  {-# INLINE posixTime #-} posixTime :: Simple Iso UTCTime POSIXTime-posixTime = iso toPOSIX fromPOSIX where-    unixEpochDay = ModifiedJulianDay 40587--    {-# INLINE toPOSIX #-}-    toPOSIX :: UTCTime -> POSIXTime-    toPOSIX t = t .-. review utcTime (UTCTime unixEpochDay zeroV)--    {-# INLINE fromPOSIX #-}-    fromPOSIX :: POSIXTime -> UTCTime-    fromPOSIX (NominalDiffTime d) = review utcTime $-        UTCTime unixEpochDay (DiffTime d)+posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch)+        (UTCRep . (^+^) unixEpoch) where+    unixEpoch = {-ModifiedJulianDay-}40587 *^ posixDayLength  -- TODO: reimplement without 'T.getPOSIXTime' to avoid 'Integer'? {-# INLINE getPOSIXTime #-}
− src/Data/Thyme/Clock/Scale.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- #hide-module Data.Thyme.Clock.Scale where--import Prelude-import Control.DeepSeq-import Data.AdditiveGroup-import Data.Basis-import Data.Data-import Data.Int-import Data.Ix-import Data.Micro-import Data.VectorSpace---- TODO: UniversalTime--newtype DiffTime = DiffTime Micro-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)--#if SHOW_INTERNAL-deriving instance Show DiffTime-#else-instance Show DiffTime where-    showsPrec p (DiffTime a) rest = showsPrec p a ('s' : rest)-#endif--instance VectorSpace DiffTime where-    type Scalar DiffTime = Rational-    {-# INLINE (*^) #-}-    s *^ DiffTime t = DiffTime (s *^ t)--instance HasBasis DiffTime where-    type Basis DiffTime = ()-    {-# INLINE basisValue #-}-    basisValue () = DiffTime (basisValue ())-    {-# INLINE decompose #-}-    decompose (DiffTime a) = decompose a-    {-# INLINE decompose' #-}-    decompose' (DiffTime a) = decompose' a--#if INSTANCE_NUM-deriving instance Num DiffTime-deriving instance Real DiffTime-deriving instance Fractional DiffTime-deriving instance RealFrac DiffTime-#endif--{-# INLINE microsecondsToDiffTime #-}-microsecondsToDiffTime :: Int64 -> DiffTime-microsecondsToDiffTime = DiffTime . Micro
+ src/Data/Thyme/Clock/TAI.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Data.Thyme.Clock.TAI+    ( AbsoluteTime+    , taiEpoch+    , LeapSecondTable+    , utcDayLength+    , absoluteTime+    , parseTAIUTCDAT+    ) where++import Prelude+import Control.Applicative+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.AffineSpace+import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.Basis+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.Char+import Data.Data+import Data.Either+import Data.Ix+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+#else+import qualified Data.Map as Map+#endif+import Data.Micro+import Data.Thyme.Calendar+import Data.Thyme.Clock.Internal+import Data.Thyme.Format.Internal+import Data.Thyme.LocalTime+import Data.VectorSpace+import System.Locale++newtype AbsoluteTime = AbsoluteTime DiffTime+    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)++instance Show AbsoluteTime where+    {-# INLINEABLE showsPrec #-}+    showsPrec p tai = showsPrec p lt . (++) " TAI" where+        lt = tai ^. from (absoluteTime (const zeroV)) . utcLocalTime utc++-- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI.+{-# INLINE taiEpoch #-}+taiEpoch :: AbsoluteTime+taiEpoch = AbsoluteTime zeroV++instance AffineSpace AbsoluteTime where+    type Diff AbsoluteTime = DiffTime+    {-# INLINE (.-.) #-}+    AbsoluteTime a .-. AbsoluteTime b = a ^-^ b+    {-# INLINE (.+^) #-}+    AbsoluteTime a .+^ d = AbsoluteTime (a ^+^ d)++type LeapSecondTable = Either UTCTime AbsoluteTime -> DiffTime++utcDayLength :: LeapSecondTable -> Day -> DiffTime+utcDayLength table day@((.+^ 1) -> next) =+        DiffTime posixDay ^+^ diff next ^-^ diff day where+    diff d = table . Left $ review utcTime (UTCTime d zeroV)+    NominalDiffTime posixDay = posixDayLength++{-# INLINE absoluteTime #-}+absoluteTime :: LeapSecondTable -> Simple Iso UTCTime AbsoluteTime+absoluteTime table = iso toTAI fromTAI where++    {-# INLINE toTAI #-}+    toTAI :: UTCTime -> AbsoluteTime+    toTAI ut@(UTCRep (NominalDiffTime u)) =+        AbsoluteTime (DiffTime u ^+^ table (Left ut))++    {-# INLINE fromTAI #-}+    fromTAI :: AbsoluteTime -> UTCTime+    fromTAI tai@(AbsoluteTime a) = UTCRep (NominalDiffTime u) where+        DiffTime u = a ^-^ table (Right tai)++-- | @tai-utc.dat@ from <http://maia.usno.navy.mil/ser7/tai-utc.dat>+{-# INLINEABLE parseTAIUTCDAT #-}+parseTAIUTCDAT :: ByteString -> LeapSecondTable+parseTAIUTCDAT = parse $ do+    y <- dec_ 5 <* P.skipSpace <?> "Year"+    let mons = map toUpper . snd <$> months defaultTimeLocale+    m <- succ <$> indexOf mons <* P.skipSpace <?> "Month"+    d <- dec_ 2 <?> "Day"+    tokens ["=", "JD"]+    -- TAI-UTC changes always happen at midnight, so just ignore ".5".+    mjd <- subtract 2400000{-.5-} <$> P.decimal+        <* P.string ".5" <?> "Julian Date .5"+    let ymd = YearMonthDay y m d+    unless (review gregorian ymd == ModifiedJulianDay mjd) . fail $+        show ymd ++ " is not Modified Julian Day " ++ show mjd++    tokens ["TAI", "-", "UTC", "="]+    b <- micro <?> "Base"+    tokens ["S", "+", "(", "MJD", "-"]+    o <- P.rational <?> "Offset"+    tokens [".", ")", "X"]+    c <- P.rational <* tokens ["S"] <?> "Coefficient"++    -- FIXME: confirm UTC↔TAI conversion for pre-1972.+    -- Do we round MJD? This is a guess:+    -- TAI-UTC =  b + c * (MJD(UTC) - o)+    let atUTC (UTCRep (NominalDiffTime t)) = DiffTime $+            b ^+^ (c * (t ^/^ posixDay - o)) *^ basisValue ()+    let c1' = recip (1 + c); c1'c = c1' * c+    -- TAI-UTC = (b + c * (MJD(TAI) - o)) / (1 + c)+    let atTAI (AbsoluteTime (DiffTime t)) = DiffTime $+            c1' *^ b ^+^ (c1'c * (t ^/^ posixDay - o)) *^ basisValue ()+    let begin = toRational mjd *^ posixDay+    let beginUTC = UTCRep (NominalDiffTime begin)+    let beginTAI = AbsoluteTime (DiffTime begin ^-^ atUTC beginUTC)+    return ((beginUTC, atUTC), (beginTAI, atTAI))++  where+    NominalDiffTime posixDay = posixDayLength+    tokens = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) P.skipSpace++    parse row = pair . unzip . rights . map (P.parseOnly row) . S.lines+    pair (look -> atUTC, look -> atTAI) = either atUTC atTAI+#if MIN_VERSION_containers(0,5,0)+    look l = \ t -> maybe zeroV (($ t) . snd) $ Map.lookupLE t (Map.fromList l)+#else+    look l = \ t -> case Map.splitLookup t (Map.fromList l) of+        (lt, eq, _) -> maybe zeroV ($ t) $ eq <|> fst <$> Map.maxView lt+#endif++    {-# INLINEABLE micro #-}+    micro :: Parser Micro+    micro = do+        s <- P.decimal <* P.string "."+        us10 <- either fail return . P.parseOnly P.decimal . S.take 7+            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit+        return $ Micro (s * 1000000 + div (us10 + 5) 10)+
− src/Data/Thyme/Clock/UTC.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}---- #hide-module Data.Thyme.Clock.UTC where--import Prelude-import Control.DeepSeq-import Control.Lens-import Data.AdditiveGroup-import Data.AffineSpace-import Data.Basis-import Data.Bits-import Data.Data-import Data.Int-import Data.Ix-import Data.Micro-import Data.Thyme.Calendar-import Data.Thyme.Clock.Scale-import Data.VectorSpace--newtype NominalDiffTime = NominalDiffTime Micro-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)--#if SHOW_INTERNAL-deriving instance Show NominalDiffTime-#else-instance Show NominalDiffTime where-    showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)-#endif--instance VectorSpace NominalDiffTime where-    type Scalar NominalDiffTime = Rational-    {-# INLINE (*^) #-}-    s *^ NominalDiffTime t = NominalDiffTime (s *^ t)--instance HasBasis NominalDiffTime where-    type Basis NominalDiffTime = ()-    {-# INLINE basisValue #-}-    basisValue () = NominalDiffTime (basisValue ())-    {-# INLINE decompose #-}-    decompose (NominalDiffTime a) = decompose a-    {-# INLINE decompose' #-}-    decompose' (NominalDiffTime a) = decompose' a--#if INSTANCE_NUM-deriving instance Num NominalDiffTime-deriving instance Real NominalDiffTime-deriving instance Fractional NominalDiffTime-deriving instance RealFrac NominalDiffTime-#endif--{-# INLINE posixDayLength #-}-posixDayLength :: NominalDiffTime-posixDayLength = NominalDiffTime (toMicro 86400)----------------------------------------------------------------------------newtype UTCTime = UTCPacked Int64-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)--data UTCView = UTCTime-    { utctDay :: {-# UNPACK #-}!Day-    , utctDayTime :: {-# UNPACK #-}!DiffTime-    } deriving (Eq, Ord, Data, Typeable, Show)--instance NFData UTCView--_utctDay :: Simple Lens UTCTime Day-_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t)--_utctDayTime :: Simple Lens UTCTime DiffTime-_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t)--instance AffineSpace UTCTime where-    type Diff UTCTime = NominalDiffTime-    {-# INLINE (.-.) #-}-    (view utcTime -> UTCTime da ta) .-. (view utcTime -> UTCTime db tb) =-        fromIntegral (da .-. db) *^ posixDayLength ^+^ NominalDiffTime td where-        DiffTime td = ta ^-^ tb-    {-# INLINE (.+^) #-}-    (view utcTime -> UTCTime day (DiffTime dt)) .+^ NominalDiffTime d-        = review utcTime $ UTCTime day (DiffTime (dt ^+^ d))--{-# INLINE utcTime #-}-utcTime :: Simple Iso UTCTime UTCView-utcTime = iso unpack pack where--    {-# INLINE unpack #-}-    unpack :: UTCTime -> UTCView-    unpack (UTCPacked n) = UTCTime-            (ModifiedJulianDay mjd) (DiffTime (Micro dt)) where-        mjd = shiftR n bitsDayTime-        dt = n .&. maskDayTime--    {-# INLINE pack #-}-    pack :: UTCView -> UTCTime-    pack (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) =-            UTCPacked (shiftL (mjd + dd) bitsDayTime .|. pt) where-        NominalDiffTime posixDay = posixDayLength-        (dd, Micro pt) = microDivMod dt posixDay--    {-# INLINE bitsDayTime #-}-    bitsDayTime :: Int-    bitsDayTime = 37 -- enough for 86400 microseconds--    {-# INLINE maskDayTime #-}-    maskDayTime :: Int64-    maskDayTime = shiftL 1 bitsDayTime - 1-
src/Data/Thyme/Format.hs view
@@ -10,6 +10,7 @@     , formatTime     , ParseTime (..)     , parseTime+    , readTime     , TimeParse (..)     , timeParser     ) where@@ -23,26 +24,23 @@ import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Basis import Data.Bits-import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy as SL import Data.Char import Data.Micro import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import Data.Thyme.Calendar.MonthDay+import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX-import Data.Thyme.Clock.Scale-import Data.Thyme.Clock.UTC+import Data.Thyme.Clock.TAI import Data.Thyme.Format.Internal import Data.Thyme.LocalTime import Data.Thyme.TH import Data.VectorSpace import System.Locale -type FormatS = Char -> ShowS class FormatTime t where-    showsTime :: TimeLocale -> t -> FormatS -> FormatS+    showsTime :: TimeLocale -> t -> (Char -> ShowS) -> Char -> ShowS  {-# INLINEABLE formatTime #-} formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String@@ -237,6 +235,16 @@         qr = microQuotRem -- rounds to 0 #endif +instance FormatTime UniversalTime where+    {-# INLINEABLE showsTime #-}+    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "UT1"} where+        lt = view (ut1LocalTime 0) t++instance FormatTime AbsoluteTime where+    {-# INLINEABLE showsTime #-}+    showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "TAI"} where+        lt = view (from (absoluteTime $ const zeroV) . utcLocalTime utc) t+ ------------------------------------------------------------------------  data TimeFlag@@ -415,7 +423,7 @@     micro :: Parser Micro     micro = do         us10 <- either fail return . P.parseOnly P.decimal . S.take 7-            . (`S.append` S.pack "000000") =<< P.takeWhile1 isDigit+            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit         return $ Micro (div (us10 + 5) 10)      {-# INLINE unixEpoch #-}@@ -439,9 +447,13 @@ {-# INLINEABLE parseTime #-} parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t parseTime l spec = either (const Nothing) Just-    . P.parseOnly (buildTime <$> timeParser l spec)-    . SL.toStrict . S.toLazyByteString . S.stringUtf8+    . P.parseOnly (buildTime <$> timeParser l spec) . utf8String +{-# INLINEABLE readTime #-}+readTime :: (ParseTime t) => TimeLocale -> String -> String -> t+readTime l spec = either error id+    . P.parseOnly (buildTime <$> timeParser l spec) . utf8String+ class ParseTime t where     buildTime :: TimeParse -> t @@ -516,15 +528,23 @@         then review posixTime tpPOSIXTime         else view (from zonedTime . _2) (buildTime tp) +instance ParseTime UniversalTime where+    {-# INLINE buildTime #-}+    buildTime (buildTime -> UTCRep t) = UniversalRep t++instance ParseTime AbsoluteTime where+    {-# INLINE buildTime #-}+    buildTime = view (absoluteTime $ const zeroV) <$> buildTime+ ------------------------------------------------------------------------  -- Dubiously pilfered from time-1.4.0.2 -- s/^.*-- \(.*\)\n.*\("[A-Z]\+"\).*"\([+-]\)\([0-9]\{2\}\):\([0-9]\{2\}\)", \(True\|False\).*$/    <|> zone \2 (($\3) \4 \5) \6 -- \1/ -- followed by !sort -r , because some names are prefixes of others. timeZoneParser :: Parser TimeZone-timeZoneParser+timeZoneParser = zone "TAI" 0 False <|> zone "UT1" 0 False -    =   zone "ZULU" (($+) 00 00) False --  Same as UTC+    <|> zone "ZULU" (($+) 00 00) False --  Same as UTC     <|> zone "Z" (($+) 00 00) False --  Same as UTC     <|> zone "YST" (($-) 09 00) False -- Yukon Standard Time     <|> zone "YDT" (($-) 08 00) True -- Yukon Daylight-Saving Time
src/Data/Thyme/Format/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Data.Thyme.Format.Internal where  import Prelude@@ -5,11 +7,34 @@ import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Builder as S-import qualified Data.ByteString.Lazy as L import Data.Char import Data.Int +#if MIN_VERSION_bytestring(0,10,0)+# if MIN_VERSION_bytestring(0,10,2)+import qualified Data.ByteString.Builder as B+# else+import qualified Data.ByteString.Lazy.Builder as B+# endif+import qualified Data.ByteString.Lazy as L+#else+import qualified Data.ByteString.UTF8 as U8+#endif++{-# INLINE utf8Char #-}+{-# INLINE utf8String #-}+utf8Char :: Char -> S.ByteString+utf8String :: String -> S.ByteString+#if MIN_VERSION_bytestring(0,10,0)+utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8+utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8+#else+utf8Char = U8.fromString . (:[])+utf8String = U8.fromString+#endif++------------------------------------------------------------------------+ {-# INLINE shows02 #-} shows02 :: Int -> String -> String shows02 n = if n < 10 then (:) '0' . shows n else shows n@@ -51,6 +76,10 @@  ------------------------------------------------------------------------ +{-# INLINE indexOf #-}+indexOf :: [String] -> Parser Int+indexOf = P.choice . zipWith (\ i s -> i <$ P.string (S.pack s)) [0..]+ {-# INLINE indexOfCI #-} indexOfCI :: [String] -> Parser Int indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..]@@ -74,7 +103,7 @@  {-# INLINE charU8 #-} charU8 :: Char -> Parser ()-charU8 c = () <$ P.string (L.toStrict . S.toLazyByteString . S.charUtf8 $ c)+charU8 c = () <$ P.string (utf8Char c)  -- | Number may be prefixed with '-' {-# INLINE negative #-}
src/Data/Thyme/LocalTime/Internal.hs view
@@ -16,8 +16,7 @@ import Data.Data import Data.Micro import Data.Thyme.Calendar-import Data.Thyme.Clock.Scale-import Data.Thyme.Clock.UTC+import Data.Thyme.Clock.Internal #if !SHOW_INTERNAL import Data.Thyme.Format.Internal #endif@@ -46,6 +45,14 @@         frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su #endif +-- | Hour zero+midnight :: TimeOfDay+midnight = TimeOfDay 0 0 zeroV++-- | Hour twelve+midday :: TimeOfDay+midday = TimeOfDay 12 0 zeroV+ {-# INLINE makeTimeOfDayValid #-} makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay makeTimeOfDayValid h m s@(DiffTime u) = TimeOfDay h m s@@ -70,7 +77,6 @@         ^+^ fromIntegral h *^ DiffTime (toMicro 3600)  type Minutes = Int-type Days = Int  -- | Add some minutes to a 'TimeOfDay'; result comes with a day adjustment. {-# INLINE addMinutes #-}@@ -79,17 +85,17 @@     (dd, h') = divMod (h + dh) 24     (dh, m') = divMod (m + dm) 60 -{-# INLINE timeOfDayFraction #-}-timeOfDayFraction :: Simple Iso Rational TimeOfDay-timeOfDayFraction = iso fromRatio toRatio . timeOfDay where+{-# INLINE dayFraction #-}+dayFraction :: Simple Iso TimeOfDay Rational+dayFraction = from timeOfDay . iso toRatio fromRatio where     NominalDiffTime posixDay = posixDayLength -    fromRatio :: Rational -> DiffTime-    fromRatio r = DiffTime (r *^ posixDay)-     toRatio :: DiffTime -> Rational     toRatio (DiffTime t) = t ^/^ posixDay +    fromRatio :: Rational -> DiffTime+    fromRatio r = DiffTime (r *^ posixDay)+ ------------------------------------------------------------------------ -- * Local Time @@ -120,7 +126,23 @@             (review timeOfDay utcToD) where         (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod --- TODO: ut1LocalTime+{-# INLINE ut1LocalTime #-}+ut1LocalTime :: Rational -> Simple Iso UniversalTime LocalTime+ut1LocalTime long = iso localise globalise where+    NominalDiffTime posixDay@(Micro usDay) = posixDayLength++    {-# INLINEABLE localise #-}+    localise :: UniversalTime -> LocalTime+    localise (UniversalRep (NominalDiffTime t)) = LocalTime+            (ModifiedJulianDay day) (view timeOfDay (DiffTime dt)) where+        (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay++    {-# INLINEABLE globalise #-}+    globalise :: LocalTime -> UniversalTime+    globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $+            Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where+        ModifiedJulianDay mjd = day+        DiffTime dt = review timeOfDay tod  ------------------------------------------------------------------------ -- * Zoned Time
src/Data/Thyme/LocalTime/TimeZone.hs view
@@ -14,8 +14,7 @@ import Control.Lens import Data.Micro import Data.Thyme.Calendar-import Data.Thyme.Clock.Scale-import Data.Thyme.Clock.UTC+import Data.Thyme.Clock.Internal import qualified Data.Time as T  getTimeZone :: UTCTime -> IO T.TimeZone
+ src/Data/Thyme/Time.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns #-}++-- | Compatibility between thyme and time.+module Data.Thyme.Time where++import Control.Lens+import Data.AffineSpace+import Data.Basis+import Data.Int+import Data.Micro+import Data.Thyme.Calendar+import Data.Thyme.Calendar.OrdinalDate+import Data.Thyme.Calendar.MonthDay+import Data.Thyme.Calendar.WeekDate+import Data.Thyme.Clock.Internal+import Data.Thyme.Clock.POSIX+import Data.Thyme.Clock.TAI+import Data.Thyme.LocalTime+import qualified Data.Time.Calendar as T+import qualified Data.Time.Clock as T+import qualified Data.Time.Clock.TAI as T+import qualified Data.Time.LocalTime as T++class Thyme a b where+    thyme :: Simple Iso a b++instance Thyme T.Day Day where+    {-# INLINE thyme #-}+    thyme = iso+        (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay)+        (T.ModifiedJulianDay . fromIntegral . toModifiedJulianDay)++instance Thyme T.UniversalTime UniversalTime where+    {-# INLINE thyme #-}+    thyme = iso T.getModJulianDate T.ModJulianDate . from modJulianDate++instance Thyme T.DiffTime DiffTime where+    {-# INLINE thyme #-}+    thyme = iso (microsecondsToDiffTime . round . (*) 1000000)+        ( \ (DiffTime (Micro t)) ->+            T.picosecondsToDiffTime $ toInteger t * 1000000 )++instance Thyme T.UTCTime UTCView where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.UTCTime d t) -> UTCTime (view thyme d) (view thyme t))+        (\ (UTCTime d t) -> T.UTCTime (review thyme d) (review thyme t))++instance Thyme T.UTCTime UTCTime where+    {-# INLINE thyme #-}+    thyme = thyme . from utcTime++instance Thyme T.NominalDiffTime NominalDiffTime where+    {-# INLINE thyme #-}+    thyme = iso (microsecondsToNominalDiffTime . round . (*) 1000000)+        (\ (NominalDiffTime t) -> fromRational $ t ^/^ basisValue ())++instance Thyme T.AbsoluteTime AbsoluteTime where+    {-# INLINE thyme #-}+    thyme = iso (`T.diffAbsoluteTime` T.taiEpoch)+            (`T.addAbsoluteTime` T.taiEpoch)+        . thyme . iso (taiEpoch .+^) (.-. taiEpoch)++instance Thyme T.TimeZone TimeZone where+    {-# INLINE thyme #-}+    thyme = id++instance Thyme T.TimeOfDay TimeOfDay where+    {-# INLINE thyme #-}+    thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m+            . microsecondsToDiffTime . round $ s * 1000000 )+        ( \ (TimeOfDay h m s) -> T.TimeOfDay h m+            . fromRational $ s ^/^ basisValue () )++instance Thyme T.LocalTime LocalTime where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.LocalTime d t) -> LocalTime (view thyme d) (view thyme t))+        (\ (LocalTime d t) -> T.LocalTime (review thyme d) (review thyme t))++instance Thyme T.ZonedTime ZonedTime where+    {-# INLINE thyme #-}+    thyme = iso+        (\ (T.ZonedTime t z) -> ZonedTime (view thyme t) (view thyme z))+        (\ (ZonedTime t z) -> T.ZonedTime (review thyme t) (review thyme z))++------------------------------------------------------------------------+-- * "Data.Time.Calendar"++{-# INLINE addDays #-}+addDays :: Days -> Day -> Day+addDays = flip (.+^)++{-# INLINE diffDays #-}+diffDays :: Day -> Day -> Days+diffDays = (.-.)++{-# INLINE toGregorian #-}+toGregorian :: Day -> (Year, Month, DayOfMonth)+toGregorian (view gregorian -> YearMonthDay y m d) = (y, m, d)++{-# INLINE fromGregorian #-}+fromGregorian :: Year -> Month -> DayOfMonth -> Day+fromGregorian y m d = review gregorian (YearMonthDay y m d)++{-# INLINE fromGregorianValid #-}+fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day+fromGregorianValid y m d = gregorianValid (YearMonthDay y m d)++{-# INLINE addGregorianMonthsClip #-}+addGregorianMonthsClip :: Months -> Day -> Day+addGregorianMonthsClip n = review gregorian+    . gregorianMonthsClip n . view gregorian++{-# INLINE addGregorianMonthsRollover #-}+addGregorianMonthsRollover :: Months -> Day -> Day+addGregorianMonthsRollover n = review gregorian+    . gregorianMonthsRollover n . view gregorian++{-# INLINE addGregorianYearsClip #-}+addGregorianYearsClip :: Years -> Day -> Day+addGregorianYearsClip n = review gregorian+    . gregorianYearsClip n . view gregorian++{-# INLINE addGregorianYearsRollover #-}+addGregorianYearsRollover :: Years -> Day -> Day+addGregorianYearsRollover n = review gregorian+    . gregorianYearsRollover n . view gregorian++------------------------------------------------------------------------+-- * "Data.Time.Calendar.MonthDay"++{-# INLINE dayOfYearToMonthAndDay #-}+dayOfYearToMonthAndDay :: Bool -> DayOfYear -> (Month, DayOfMonth)+dayOfYearToMonthAndDay leap (view (monthDay leap) -> MonthDay m d) = (m, d)++{-# INLINE monthAndDayToDayOfYear #-}+monthAndDayToDayOfYear :: Bool -> Month -> DayOfMonth -> DayOfYear+monthAndDayToDayOfYear leap m d = review (monthDay leap) (MonthDay m d)++{-# INLINE monthAndDayToDayOfYearValid #-}+monthAndDayToDayOfYearValid :: Bool -> Month -> DayOfMonth -> Maybe DayOfYear+monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d)++------------------------------------------------------------------------+-- * "Data.Time.Calendar.OrdinalDate"++{-# INLINE toOrdinalDate #-}+toOrdinalDate :: Day -> (Year, DayOfYear)+toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d)++{-# INLINE fromOrdinalDate #-}+fromOrdinalDate :: Year -> DayOfYear -> Day+fromOrdinalDate y d = review ordinalDate (OrdinalDate y d)++{-# INLINE fromOrdinalDateValid #-}+fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day+fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d)++{-# INLINE sundayStartWeek #-}+sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)+sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d)++{-# INLINE fromSundayStartWeek #-}+fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day+fromSundayStartWeek y w d = review sundayWeek (SundayWeek y w d)++{-# INLINE fromSundayStartWeekValid #-}+fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d)++{-# INLINE mondayStartWeek #-}+mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)+mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d)++{-# INLINE fromMondayStartWeek #-}+fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day+fromMondayStartWeek y w d = review mondayWeek (MondayWeek y w d)++{-# INLINE fromMondayStartWeekValid #-}+fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d)++------------------------------------------------------------------------+-- * "Data.Time.Calendar.WeekDate"++{-# INLINE toWeekDate #-}+toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek)+toWeekDate (view weekDate -> WeekDate y w d) = (y, w, d)++{-# INLINE fromWeekDate #-}+fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day+fromWeekDate y w d = review weekDate (WeekDate y w d)++{-# INLINE fromWeekDateValid #-}+fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day+fromWeekDateValid y w d = weekDateValid (WeekDate y w d)++------------------------------------------------------------------------+-- * "Data.Time.Clock"++{-# INLINE secondsToDiffTime #-}+secondsToDiffTime :: Int64 -> DiffTime+secondsToDiffTime a = DiffTime (Micro $ a * 1000000)++{-# INLINE picosecondsToDiffTime #-}+picosecondsToDiffTime :: Int64 -> DiffTime+picosecondsToDiffTime a = DiffTime (Micro $ div (a + 500000) 1000000)++{-# INLINE addUTCTime #-}+addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime+addUTCTime = flip (.+^)++{-# INLINE diffUTCTime #-}+diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime+diffUTCTime = (.-.)++------------------------------------------------------------------------+-- * "Data.Time.Clock.POSIX"++{-# INLINE posixSecondsToUTCTime #-}+posixSecondsToUTCTime :: POSIXTime -> UTCTime+posixSecondsToUTCTime = review posixTime++{-# INLINE utcTimeToPOSIXSeconds #-}+utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime+utcTimeToPOSIXSeconds = view posixTime++------------------------------------------------------------------------+-- * "Data.Time.Clock.TAI"++{-# INLINE addAbsoluteTime #-}+addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime+addAbsoluteTime = flip (.+^)++{-# INLINE diffAbsoluteTime #-}+diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime+diffAbsoluteTime = (.-.)++{-# INLINE utcToTAITime #-}+utcToTAITime :: LeapSecondTable -> UTCTime -> AbsoluteTime+utcToTAITime = view . absoluteTime++{-# INLINE taiToUTCTime #-}+taiToUTCTime :: LeapSecondTable -> AbsoluteTime -> UTCTime+taiToUTCTime = review . absoluteTime++------------------------------------------------------------------------+-- * "Data.Time.LocalTime"++{-# INLINE utcToLocalTimeOfDay #-}+utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)+utcToLocalTimeOfDay = addMinutes . timeZoneMinutes++{-# INLINE localToUTCTimeOfDay #-}+localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay)+localToUTCTimeOfDay = addMinutes . negate . timeZoneMinutes++{-# INLINE timeToTimeOfDay #-}+timeToTimeOfDay :: DiffTime -> TimeOfDay+timeToTimeOfDay = view timeOfDay++{-# INLINE timeOfDayToTime #-}+timeOfDayToTime :: TimeOfDay -> DiffTime+timeOfDayToTime = review timeOfDay++{-# INLINE dayFractionToTimeOfDay #-}+dayFractionToTimeOfDay :: Rational -> TimeOfDay+dayFractionToTimeOfDay = review dayFraction++{-# INLINE timeOfDayToDayFraction #-}+timeOfDayToDayFraction :: TimeOfDay -> Rational+timeOfDayToDayFraction = view dayFraction++{-# INLINE utcToLocalTime #-}+utcToLocalTime :: TimeZone -> UTCTime -> LocalTime+utcToLocalTime = view . utcLocalTime++{-# INLINE localTimeToUTC #-}+localTimeToUTC :: TimeZone -> LocalTime -> UTCTime+localTimeToUTC = review . utcLocalTime++{-# INLINE ut1ToLocalTime #-}+ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime+ut1ToLocalTime = view . ut1LocalTime++{-# INLINE localTimeToUT1 #-}+localTimeToUT1 :: Rational -> LocalTime -> UniversalTime+localTimeToUT1 = review . ut1LocalTime++{-# INLINE utcToZonedTime #-}+utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime+utcToZonedTime z t = view zonedTime (z, t)++{-# INLINE zonedTimeToUTC #-}+zonedTimeToUTC :: ZonedTime -> UTCTime+zonedTimeToUTC = snd . review zonedTime+
tests/sanity.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -15,8 +16,7 @@ import Criterion.Monad import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Basis-import qualified Data.ByteString.Builder as S-import qualified Data.ByteString.Lazy as SL+import Data.ByteString (ByteString) import Data.Monoid import Data.Thyme import qualified Data.Time as T@@ -28,6 +28,27 @@ import qualified Test.QuickCheck.Gen as Gen import Text.Printf +#if MIN_VERSION_bytestring(0,10,0)+# if MIN_VERSION_bytestring(0,10,2)+import qualified Data.ByteString.Builder as B+# else+import qualified Data.ByteString.Lazy.Builder as B+# endif+import qualified Data.ByteString.Lazy as L+#else+import qualified Data.ByteString.UTF8 as U8+#endif++{-# INLINE utf8String #-}+utf8String :: String -> ByteString+#if MIN_VERSION_bytestring(0,10,0)+utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8+#else+utf8String = U8.fromString+#endif++------------------------------------------------------------------------+ instance Arbitrary Day where     arbitrary = fmap (review gregorian) $ YearMonthDay         -- FIXME: We disagree with time on how many digits to use for year.@@ -101,8 +122,7 @@         = printTestCase desc (fmap toTime t == t') where     t = parseTime defaultTimeLocale spec s     t' = T.parseTime defaultTimeLocale spec s-    tp = P.parseOnly (timeParser defaultTimeLocale spec)-        . SL.toStrict . S.toLazyByteString . S.stringUtf8+    tp = P.parseOnly (timeParser defaultTimeLocale spec) . utf8String     desc = "input: " ++ show s ++ "\nthyme: " ++ show t         ++ "\ntime:  " ++ show t' ++ "\nstate: " ++ show (tp s)
thyme.cabal view
@@ -1,5 +1,5 @@ name:           thyme-version:        0.2.0.0+version:        0.2.1.0 synopsis:       A faster time library description:     A faster time library@@ -38,6 +38,10 @@     default: False     manual: True +flag utf8-string+    description: use utf8-string with bytestring < 0.10+    default: False+ library     hs-source-dirs: src     exposed-modules:@@ -46,30 +50,36 @@         Data.Thyme.Calendar.MonthDay         Data.Thyme.Calendar.OrdinalDate         Data.Thyme.Calendar.WeekDate+        Data.Thyme.Calendar.WeekdayOfMonth         Data.Thyme.Clock         Data.Thyme.Clock.POSIX+        Data.Thyme.Clock.TAI         Data.Thyme.Format         Data.Thyme.LocalTime+        Data.Thyme.Time     other-modules:         Data.Micro         Data.Thyme.Calendar.Internal-        Data.Thyme.Clock.Scale-        Data.Thyme.Clock.UTC+        Data.Thyme.Clock.Internal         Data.Thyme.Format.Internal         Data.Thyme.LocalTime.Internal         Data.Thyme.LocalTime.TimeZone         Data.Thyme.TH     build-depends:+        attoparsec >= 0.10,         base >= 4.5 && < 5,-        transformers >= 0.3,+        containers,         deepseq >= 1.2,-        vector-space >= 0.8,-        lens >= 3.7,+        lens >= 3.8,         old-locale >= 1.0,         template-haskell >= 2.6,-        bytestring >= 0.10.2,-        attoparsec >= 0.10,-        time >= 1.4+        time >= 1.4,+        transformers,+        vector-space >= 0.8+    if flag(utf8-string)+        build-depends: bytestring >= 0.9, utf8-string >= 0.3+    else+        build-depends: bytestring >= 0.10     ghc-options: -Wall     if flag(bug-for-bug)         cpp-options: -DBUG_FOR_BUG=1@@ -85,18 +95,20 @@     hs-source-dirs: tests     main-is: sanity.hs     build-depends:-        base >= 4.5 && < 5,-        transformers >= 0.3,-        vector-space >= 0.8,-        lens >= 3.7,-        old-locale >= 1.0,-        bytestring >= 0.10.2,-        attoparsec >= 0.10,-        random >= 1.0,-        QuickCheck >= 2.4,-        criterion >= 0.6,+        QuickCheck,+        attoparsec,+        base,+        bytestring,+        criterion,+        lens,+        old-locale,+        random,         thyme,-        time >= 1.4+        time,+        transformers,+        vector-space+    if flag(utf8-string)+        build-depends: utf8-string     ghc-options: -Wall  -- vim: et sw=4 ts=4 sts=4: