thyme 0.2.4.1 → 0.3.0.0

raw patch · 23 files changed

+547/−322 lines, 23 filesdep +Cabaldep +directorydep +filepathdep ~QuickCheckdep ~basedep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, directory, filepath, system-posix-redirect

Dependency ranges changed: QuickCheck, base, lens, text

API changes (from Hackage documentation)

Files

• include/thyme.h +3/−0
• src/Data/Micro.hs +5/−2
• src/Data/Thyme.hs +1/−1
• src/Data/Thyme/Calendar.hs +34/−31
• src/Data/Thyme/Calendar/Internal.hs +136/−37
• src/Data/Thyme/Calendar/MonthDay.hs +2/−49
• src/Data/Thyme/Calendar/OrdinalDate.hs +16/−2
• src/Data/Thyme/Calendar/WeekDate.hs +38/−2
• src/Data/Thyme/Calendar/WeekdayOfMonth.hs +23/−8
• src/Data/Thyme/Clock.hs +7/−7
• src/Data/Thyme/Clock/Internal.hs +52/−71
• src/Data/Thyme/Clock/TAI.hs +8/−5
• src/Data/Thyme/Format.hs +16/−16
• src/Data/Thyme/Format/Human.hs +20/−23
• src/Data/Thyme/LocalTime.hs +1/−1
• src/Data/Thyme/LocalTime/Internal.hs +38/−14
• src/Data/Thyme/LocalTime/TimeZone.hs +3/−4
• src/Data/Thyme/Time/Core.hs +20/−20
• tests/Common.hs +11/−15
• tests/bench.hs +6/−6
• tests/rewrite.hs +78/−0
• tests/sanity.hs +5/−5
• thyme.cabal +24/−3

@@ -0,0 +1,3 @@+#define INSTANCES_USUAL     Eq, Ord, Data, Typeable+#define INSTANCES_NEWTYPE   INSTANCES_USUAL, Enum, Ix, NFData+#define INSTANCES_MICRO     INSTANCES_NEWTYPE, Bounded, Random, Arbitrary

@@ -5,6 +5,8 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} +#include "thyme.h"+ module Data.Micro where  import Prelude@@ -16,6 +18,8 @@ import Data.Ix import Data.Ratio import Data.VectorSpace+import System.Random+import Test.QuickCheck  #if !SHOW_INTERNAL import Control.Monad@@ -27,8 +31,7 @@ import Text.Read #endif -newtype Micro = Micro Int64-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)+newtype Micro = Micro Int64 deriving (INSTANCES_MICRO)  #if SHOW_INTERNAL deriving instance Show Micro

@@ -22,7 +22,7 @@ -- <http://hackage.haskell.org/package/enummapset-th>. In any case the 'Ord' -- instances are much faster, if you must use 'Data.Map.Map'. ----- "Data.Thyme.Time" is a drop-in compatibility module for exising code.+-- "Data.Thyme.Time" is a drop-in compatibility module for existing code.  module Data.Thyme     ( module Data.Thyme.Calendar

@@ -4,14 +4,20 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for the+-- various calendar types reflect this fact. That said, the calendar+-- calculations by themselves work perfectly fine for a wider range of+-- dates, subject to the size of 'Int' for your platform.+ module Data.Thyme.Calendar     ( Years, Months, Days     -- * Days-    , Day (..)+    , Day (..), modifiedJulianDay     -- * Gregorian calendar     , Year, Month, DayOfMonth     , YearMonthDay (..)     , isLeapYear+    , yearMonthDay, gregorian, gregorianValid, showGregorian     , module Data.Thyme.Calendar     ) where @@ -19,44 +25,42 @@ import Control.Applicative import Control.Category import Control.Lens+import Data.AdditiveGroup import Data.Thyme.Calendar.Internal-import Data.Thyme.Calendar.MonthDay-import Data.Thyme.Format.Internal+import Data.Thyme.Clock.Internal import Data.Thyme.TH+import System.Random+import Test.QuickCheck -{-# INLINE yearMonthDay #-}-yearMonthDay :: Iso' OrdinalDate YearMonthDay-yearMonthDay = iso fromOrdinal toOrdinal where+-- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal",+-- therefore these orphan 'Bounded' instances must live here.+instance Bounded Day where+    minBound = minBound ^. _utctDay+    maxBound = maxBound ^. _utctDay -    {-# INLINEABLE fromOrdinal #-}-    fromOrdinal :: OrdinalDate -> YearMonthDay-    fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where-        MonthDay m d = view (monthDay (isLeapYear y)) yd+instance Bounded YearMonthDay where+    minBound = minBound ^. gregorian+    maxBound = maxBound ^. gregorian -    {-# INLINEABLE toOrdinal #-}-    toOrdinal :: YearMonthDay -> OrdinalDate-    toOrdinal (YearMonthDay y m d) = OrdinalDate y $-        review (monthDay (isLeapYear y)) (MonthDay m d)+instance Random Day where+    randomR r = over _1 (^. _utctDay) . randomR range where+        -- upper bound is one Micro second before the next day+        range = r & _2 %~ succ & both %~ toMidnight & _2 %~ pred+        toMidnight = (utcTime #) . flip UTCTime zeroV+    random = randomR (minBound, maxBound) -{-# INLINE gregorian #-}-gregorian :: Iso' Day YearMonthDay-gregorian = ordinalDate . yearMonthDay+instance Random YearMonthDay where+    randomR = randomIsoR gregorian+    random = over _1 (^. gregorian) . random -{-# INLINEABLE gregorianValid #-}-gregorianValid :: YearMonthDay -> Maybe Day-gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y-    <$> monthDayValid (isLeapYear y) (MonthDay m d)+instance Arbitrary Day where+    arbitrary = ModifiedJulianDay+        <$> choose ((minBound, maxBound) & both %~ toModifiedJulianDay) -{-# INLINEABLE showGregorian #-}-showGregorian :: Day -> String-showGregorian (view gregorian -> YearMonthDay y m d) =-    showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ ""+instance Arbitrary YearMonthDay where+    arbitrary = view gregorian <$> arbitrary -#if SHOW_INTERNAL-deriving instance Show Day-#else-instance Show Day where show = showGregorian-#endif+------------------------------------------------------------------------  {-# INLINE gregorianMonthLength #-} gregorianMonthLength :: Year -> Month -> Days@@ -92,6 +96,5 @@ gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d  -- * Lenses-thymeLenses ''Day thymeLenses ''YearMonthDay 

@@ -1,10 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} +#include "thyme.h"+ module Data.Thyme.Calendar.Internal where  import Prelude@@ -19,6 +22,8 @@ import Data.Thyme.Format.Internal import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V+import System.Random+import Test.QuickCheck  type Years = Int type Months = Int@@ -27,16 +32,54 @@ -- | The Modified Julian Day is a standard count of days, with zero being -- the day 1858-11-17. newtype Day = ModifiedJulianDay-    { toModifiedJulianDay :: Int64-    } deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)+    { toModifiedJulianDay :: Int+    } deriving (INSTANCES_NEWTYPE)  instance AffineSpace Day where     type Diff Day = Days     {-# INLINE (.-.) #-}-    ModifiedJulianDay a .-. ModifiedJulianDay b = fromIntegral (a - b)+    ModifiedJulianDay a .-. ModifiedJulianDay b = a - b     {-# INLINE (.+^) #-}-    ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + fromIntegral d)+    ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + d) +{-# INLINE modifiedJulianDay #-}+modifiedJulianDay :: Iso' Day Int+modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay++{-# INLINE yearMonthDay #-}+yearMonthDay :: Iso' OrdinalDate YearMonthDay+yearMonthDay = iso fromOrdinal toOrdinal where++    {-# INLINEABLE fromOrdinal #-}+    fromOrdinal :: OrdinalDate -> YearMonthDay+    fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where+        MonthDay m d = yd ^. monthDay (isLeapYear y)++    {-# INLINEABLE toOrdinal #-}+    toOrdinal :: YearMonthDay -> OrdinalDate+    toOrdinal (YearMonthDay y m d) = OrdinalDate y $+        monthDay (isLeapYear y) # MonthDay m d++{-# INLINE gregorian #-}+gregorian :: Iso' Day YearMonthDay+gregorian = ordinalDate . yearMonthDay++{-# INLINEABLE gregorianValid #-}+gregorianValid :: YearMonthDay -> Maybe Day+gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y+    <$> monthDayValid (isLeapYear y) (MonthDay m d)++{-# INLINEABLE showGregorian #-}+showGregorian :: Day -> String+showGregorian (view gregorian -> YearMonthDay y m d) =+    showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ ""++#if SHOW_INTERNAL+deriving instance Show Day+#else+instance Show Day where show = showGregorian+#endif+ ------------------------------------------------------------------------  type Year = Int@@ -47,7 +90,7 @@     { ymdYear :: {-# UNPACK #-}!Year     , ymdMonth :: {-# UNPACK #-}!Month     , ymdDay :: {-# UNPACK #-}!DayOfMonth-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData YearMonthDay @@ -62,7 +105,7 @@ data OrdinalDate = OrdinalDate     { odYear :: {-# UNPACK #-}!Year     , odDay :: {-# UNPACK #-}!DayOfYear-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData OrdinalDate @@ -72,8 +115,7 @@      {-# INLINEABLE toOrd #-}     toOrd :: Day -> OrdinalDate-    toOrd (ModifiedJulianDay mjd) = OrdinalDate-            (fromIntegral year) (fromIntegral yd) where+    toOrd (ModifiedJulianDay mjd) = OrdinalDate year yd where         -- pilfered         a = mjd + 678575         (quadcent, b) = divMod a 146097@@ -88,9 +130,9 @@     fromOrd :: OrdinalDate -> Day     fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where         -- pilfered-        y = fromIntegral (year - 1)+        y = year - 1         mjd = 365 * y + div y 4 - div y 100 + div y 400 - 678576-            + clip 1 (if isLeapYear year then 366 else 365) (fromIntegral yd)+            + clip 1 (if isLeapYear year then 366 else 365) yd         clip a b = max a . min b  ------------------------------------------------------------------------@@ -119,8 +161,66 @@         m = maybe 12 id $ V.findIndex (yd <) first         d = succ yd - V.unsafeIndex first (pred m) +-- | No good home for this within the current hierarchy. This will do.+{-# INLINEABLE randomIsoR #-}+randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g)+randomIsoR l r = over _1 (^. l) . randomR (over both (l #) r)+ ------------------------------------------------------------------------ +data MonthDay = MonthDay+    { mdMonth :: {-# UNPACK #-}!Month+    , mdDay :: {-# UNPACK #-}!DayOfMonth+    } deriving (INSTANCES_USUAL, Show)++instance NFData MonthDay++instance Bounded MonthDay where+    minBound = MonthDay 1 1+    maxBound = MonthDay 12 31++instance Random MonthDay where+    randomR r g = randomIsoR (monthDay leap) r g' where+        (isLeapYear -> leap, g') = random g+    random = randomR (minBound, maxBound)++instance Arbitrary MonthDay where+    arbitrary = choose (minBound, maxBound)++-- | Convert between day of year in the Gregorian or Julian calendars, and+-- month and day of month. First arg is leap year flag.+{-# INLINE monthDay #-}+monthDay :: Bool -> Iso' DayOfYear MonthDay+monthDay leap = iso fromOrdinal toOrdinal where+    (lastDay, lengths, table, ok) = if leap+        then (365, monthLengthsLeap, monthDaysLeap, -1)+        else (364, monthLengths, monthDays, -2)++    {-# INLINE fromOrdinal #-}+    fromOrdinal :: DayOfYear -> MonthDay+    fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where+        (fromIntegral -> m, fromIntegral -> d) = V.unsafeIndex table i++    {-# INLINE toOrdinal #-}+    toOrdinal :: MonthDay -> DayOfYear+    toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where+        m = max 1 . min 12 $ month+        l = V.unsafeIndex lengths (pred m)+        d = max 1 . min l $ day+        k = if m <= 2 then 0 else ok++{-# INLINEABLE monthDayValid #-}+monthDayValid :: Bool -> MonthDay -> Maybe DayOfYear+monthDayValid leap md@(MonthDay m d) = monthDay leap # md+    <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m)++{-# INLINEABLE monthLength #-}+monthLength :: Bool -> Month -> Days+monthLength leap = V.unsafeIndex ls . max 0 . min 11 . pred where+    ls = if leap then monthLengthsLeap else monthLengths++------------------------------------------------------------------------+ type WeekOfYear = Int type DayOfWeek = Int @@ -131,7 +231,7 @@     { wdYear :: {-# UNPACK #-}!Year     , wdWeek :: {-# UNPACK #-}!WeekOfYear     , wdDay :: {-# UNPACK #-}!DayOfWeek-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData WeekDate @@ -149,16 +249,16 @@  {-# INLINE toWeekOrdinal #-} toWeekOrdinal :: OrdinalDate -> Day -> WeekDate-toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = WeekDate y1-        (fromIntegral $ w1 + 1) (fromIntegral $ d7mod + 1) where+toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) =+        WeekDate y1 (w1 + 1) (d7mod + 1) where     -- pilfered and refactored; no idea what foo and bar mean     d = mjd + 2     (d7div, d7mod) = divMod d 7-    foo :: Year -> {-WeekOfYear-1-}Int64-    foo y = bar $ review ordinalDate (OrdinalDate y 6)-    bar :: Day -> {-WeekOfYear-1-}Int64+    foo :: Year -> {-WeekOfYear-1-}Int+    foo y = bar $ ordinalDate # OrdinalDate y 6+    bar :: Day -> {-WeekOfYear-1-}Int     bar (ModifiedJulianDay k) = d7div - div k 7-    w0 = bar $ ModifiedJulianDay (d - fromIntegral yd + 4)+    w0 = bar $ ModifiedJulianDay (d - yd + 4)     (y1, w1) = case w0 of         -1 -> (y0 - 1, foo (y0 - 1))         52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)@@ -167,15 +267,14 @@ {-# INLINE lastWeekOfYear #-} lastWeekOfYear :: Year -> WeekOfYear lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where-    wd = view (from ordinalDate . weekDate) (OrdinalDate y 365)+    wd = OrdinalDate y 365 ^. from ordinalDate . weekDate  {-# INLINE fromWeekLast #-} fromWeekLast :: WeekOfYear -> WeekDate -> Day fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where     -- pilfered and refactored-    ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6)-    mjd = k - mod k 7 - 10 + clip 1 7 (fromIntegral d)-        + fromIntegral (clip 1 wMax w) * 7+    ModifiedJulianDay k = ordinalDate # OrdinalDate y 6+    mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7     clip a b = max a . min b  {-# INLINEABLE weekDateValid #-}@@ -198,7 +297,7 @@     { swYear :: {-# UNPACK #-}!Year     , swWeek :: {-# UNPACK #-}!WeekOfYear     , swDay :: {-# UNPACK #-}!DayOfWeek-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData SundayWeek @@ -213,27 +312,27 @@     {-# INLINEABLE fromSunday #-}     fromSunday :: SundayWeek -> Day     fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where-        ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1         -- following are all 0-based year days         firstSunday = mod (4 - firstDay) 7-        yd = firstSunday + 7 * (fromIntegral w - 1) + fromIntegral d+        yd = firstSunday + 7 * (w - 1) + d  {-# INLINE toSundayOrdinal #-} toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek-toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = SundayWeek y-        (fromIntegral $ d7div - div k 7) (fromIntegral d7mod) where+toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =+        SundayWeek y (d7div - div k 7) d7mod where     d = mjd + 3-    k = d - fromIntegral yd+    k = d - yd     (d7div, d7mod) = divMod d 7  {-# INLINEABLE sundayWeekValid #-} sundayWeekValid :: SundayWeek -> Maybe Day sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd)         <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where-    ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1     -- following are all 0-based year days     firstSunday = mod (4 - firstDay) 7-    yd = firstSunday + 7 * (fromIntegral w - 1) + fromIntegral d+    yd = firstSunday + 7 * (w - 1) + d     lastDay = if isLeapYear y then 365 else 364  ------------------------------------------------------------------------@@ -246,7 +345,7 @@     { mwYear :: {-# UNPACK #-}!Year     , mwWeek :: {-# UNPACK #-}!WeekOfYear     , mwDay :: {-# UNPACK #-}!DayOfWeek-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData MondayWeek @@ -261,26 +360,26 @@     {-# INLINEABLE fromMonday #-}     fromMonday :: MondayWeek -> Day     fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where-        ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+        ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1         -- following are all 0-based year days         firstMonday = mod (5 - firstDay) 7-        yd = firstMonday + 7 * (fromIntegral w - 1) + fromIntegral d - 1+        yd = firstMonday + 7 * (w - 1) + d - 1  {-# INLINE toMondayOrdinal #-} toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek-toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = MondayWeek y-        (fromIntegral $ d7div - div k 7) (fromIntegral $ d7mod + 1) where+toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) =+        MondayWeek y (d7div - div k 7) (d7mod + 1) where     d = mjd + 2-    k = d - fromIntegral yd+    k = d - yd     (d7div, d7mod) = divMod d 7  {-# INLINEABLE mondayWeekValid #-} mondayWeekValid :: MondayWeek -> Maybe Day mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd)         <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where-    ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+    ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1     -- following are all 0-based year days     firstMonday = mod (5 - firstDay) 7-    yd = firstMonday + 7 * (fromIntegral w - 1) + fromIntegral d - 1+    yd = firstMonday + 7 * (w - 1) + d - 1     lastDay = if isLeapYear y then 365 else 364 

@@ -1,62 +1,15 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}  -- | Julian or Gregorian. module Data.Thyme.Calendar.MonthDay-    ( Month, DayOfMonth+    ( Month, DayOfMonth, MonthDay (..)+    , monthDay, monthDayValid, monthLength     , module Data.Thyme.Calendar.MonthDay     ) where  import Prelude-import Control.Applicative-import Control.DeepSeq-import Control.Lens-import Control.Monad-import Data.Data import Data.Thyme.Calendar.Internal import Data.Thyme.TH-import qualified Data.Vector.Unboxed as V--data MonthDay = MonthDay-    { mdMonth :: {-# UNPACK #-}!Month-    , mdDay :: {-# UNPACK #-}!DayOfMonth-    } deriving (Eq, Ord, Data, Typeable, Show)--instance NFData MonthDay---- | Convert between day of year in the Gregorian or Julian calendars, and--- month and day of month. First arg is leap year flag.-{-# INLINE monthDay #-}-monthDay :: Bool -> Iso' DayOfYear MonthDay-monthDay leap = iso fromOrdinal toOrdinal where-    (lastDay, lengths, table, ok) = if leap-        then (365, monthLengthsLeap, monthDaysLeap, -1)-        else (364, monthLengths, monthDays, -2)--    {-# INLINE fromOrdinal #-}-    fromOrdinal :: DayOfYear -> MonthDay-    fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where-        (fromIntegral -> m, fromIntegral -> d) = V.unsafeIndex table i--    {-# INLINE toOrdinal #-}-    toOrdinal :: MonthDay -> DayOfYear-    toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where-        m = max 1 . min 12 $ month-        l = V.unsafeIndex lengths (pred m)-        d = max 1 . min l $ day-        k = if m <= 2 then 0 else ok--{-# 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 <= monthLength leap m)--{-# INLINEABLE monthLength #-}-monthLength :: Bool -> Month -> Days-monthLength leap = V.unsafeIndex ls . max 0 . min 11 . pred where-    ls = if leap then monthLengthsLeap else monthLengths  -- * Lenses thymeLenses ''MonthDay

@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | ISO 8601 Ordinal Date format @@ -13,12 +13,26 @@ import Control.Applicative import Control.Lens import Control.Monad+import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import Data.Thyme.TH+import System.Random+import Test.QuickCheck +instance Bounded OrdinalDate where+    minBound = minBound ^. ordinalDate+    maxBound = maxBound ^. ordinalDate++instance Random OrdinalDate where+    randomR = randomIsoR ordinalDate+    random = over _1 (^. ordinalDate) . random++instance Arbitrary OrdinalDate where+    arbitrary = view ordinalDate <$> arbitrary+ {-# INLINE ordinalDateValid #-} ordinalDateValid :: OrdinalDate -> Maybe Day-ordinalDateValid od@(OrdinalDate y d) = review ordinalDate od+ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od     <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365)  -- * Lenses

@@ -1,6 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Various Week Date formats module Data.Thyme.Calendar.WeekDate@@ -15,9 +14,46 @@     ) where  import Prelude+import Control.Applicative+import Control.Lens import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.Internal import Data.Thyme.TH+import System.Random+import Test.QuickCheck++instance Bounded WeekDate where+    minBound = minBound ^. weekDate+    maxBound = maxBound ^. weekDate++instance Bounded SundayWeek where+    minBound = minBound ^. sundayWeek+    maxBound = maxBound ^. sundayWeek++instance Bounded MondayWeek where+    minBound = minBound ^. mondayWeek+    maxBound = maxBound ^. mondayWeek++instance Random WeekDate where+    randomR = randomIsoR weekDate+    random = over _1 (^. weekDate) . random++instance Random SundayWeek where+    randomR = randomIsoR sundayWeek+    random = over _1 (^. sundayWeek) . random++instance Random MondayWeek where+    randomR = randomIsoR mondayWeek+    random = over _1 (^. mondayWeek) . random++instance Arbitrary WeekDate where+    arbitrary = view weekDate <$> arbitrary++instance Arbitrary SundayWeek where+    arbitrary = view sundayWeek <$> arbitrary++instance Arbitrary MondayWeek where+    arbitrary = view mondayWeek <$> arbitrary  -- * Lenses thymeLenses ''WeekDate

@@ -1,7 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +#include "thyme.h"+ module Data.Thyme.Calendar.WeekdayOfMonth where  import Prelude@@ -13,18 +16,30 @@ import Data.Data import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal-import Data.Thyme.Calendar.MonthDay import Data.Thyme.TH+import System.Random+import Test.QuickCheck  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)+    } deriving (INSTANCES_USUAL, Show)  instance NFData WeekdayOfMonth +instance Bounded WeekdayOfMonth where+    minBound = minBound ^. weekdayOfMonth+    maxBound = maxBound ^. weekdayOfMonth++instance Random WeekdayOfMonth where+    randomR = randomIsoR weekdayOfMonth+    random = over _1 (^. weekdayOfMonth) . random++instance Arbitrary WeekdayOfMonth where+    arbitrary = view weekdayOfMonth <$> arbitrary+ {-# INLINE weekdayOfMonth #-} weekdayOfMonth :: Iso' Day WeekdayOfMonth weekdayOfMonth = iso toWeekday fromWeekday where@@ -32,16 +47,16 @@     {-# INLINEABLE toWeekday #-}     toWeekday :: Day -> WeekdayOfMonth     toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where-        YearMonthDay y m d = view yearMonthDay ord+        YearMonthDay y m d = ord ^. yearMonthDay         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+        refOrd = yearMonthDay # YearMonthDay y m+            (if n < 0 then monthLength (isLeapYear y) m else 1)+        refDay = ordinalDate # refOrd         WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay         s = signum n         wo = s * (wd - wd1)@@ -52,8 +67,8 @@ 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+    refOrd = yearMonthDay # YearMonthDay y m (if n < 0 then len else 1)+    refDay = ordinalDate # refOrd     WeekDate _ _ wd1 = toWeekOrdinal refOrd refDay     s = signum n     wo = s * (wd - wd1)

@@ -5,13 +5,15 @@ -- @'Data.VectorSpace.Scalar' 'DiffTime' ≡ 'Data.VectorSpace.Scalar' -- 'NominalDiffTime' ≡ 'Rational'@. -----  Convert between time intervals and 'Rational's with 'seconds', or more---  generally between any 'Real' or 'Fractional' using 'fromSeconds' and---  'toSeconds'. If you must convert between 'DiffTime' and---  'NominalDiffTime', compose 'microDiffTime' and 'microNominalDiffTime'.+--  Using 'fromSeconds' and 'toSeconds' to convert between 'TimeDiff's and+--  other numeric types. If you really must coerce between 'DiffTime' and+--  'NominalDiffTime', @'view' ('microseconds' . 'from' 'microseconds')@. -- -- 'UTCTime' is an instance of 'Data.AffineSpace.AffineSpace', with -- @'Data.AffineSpace.Diff' 'UTCTime' ≡ 'NominalDiffTime'@.+--+-- 'UTCTime' is not Y294K-compliant. Please file a bug report on GitHub when+-- this becomes a problem.  module Data.Thyme.Clock (     -- * Universal Time@@ -20,17 +22,15 @@      -- * Absolute intervals     , DiffTime-    , microDiffTime      -- * UTC     , UTCTime, UTCView (..)     , utcTime     , NominalDiffTime-    , microNominalDiffTime     , module Data.Thyme.Clock      -- * Time interval conversion-    , seconds+    , TimeDiff (..)     , toSeconds, fromSeconds     , toSeconds', fromSeconds' 

@@ -7,6 +7,8 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} +#include "thyme.h"+ module Data.Thyme.Clock.Internal where  import Prelude@@ -19,8 +21,10 @@ import Data.Int import Data.Ix import Data.Micro-import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal import Data.VectorSpace+import System.Random+import Test.QuickCheck  #if !SHOW_INTERNAL import Control.Monad@@ -29,79 +33,58 @@ import Text.Read (readPrec) #endif --- | Workaround for GHC refusing to match RULES for functions with equality--- constraints; see <http://hackage.haskell.org/trac/ghc/ticket/7611>.-class (HasBasis t, Basis t ~ ()) => TimeDiff t where-    microTimeDiff :: t -> Micro-instance TimeDiff DiffTime where microTimeDiff (DiffTime d) = d-instance TimeDiff NominalDiffTime where microTimeDiff (NominalDiffTime d) = d---- | Time interval as a 'Rational' number of seconds. Compose with 'simple'--- or 'simply' 'view' / 'review' to avoid ambiguous type variables.-{-# INLINE seconds #-}-seconds :: (HasBasis s, Basis s ~ (), HasBasis t, Basis t ~ ()) => Iso s t (Scalar s) (Scalar t)-seconds = iso (`decompose'` ()) (*^ basisValue ())---- | Convert a time interval to some 'Fractional' type.+-- | Time differences, encompassing both 'DiffTime' and 'NominalDiffTime'. ----- @--- toSeconds :: (HasBasis s, Basis s ~ (), Scalar s ~ a, Real a, Fractional n) => s -> n--- @+-- FIXME: still affected by <http://hackage.haskell.org/trac/ghc/ticket/7611>?+class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where+    -- | Escape hatch; avoid.+    microseconds :: Iso' t Int64++-- | Convert a time difference to some 'Fractional' type. {-# INLINE toSeconds #-}-toSeconds :: (TimeDiff s, Real (Scalar s), Fractional n) => s -> n-toSeconds = realToFrac . simply view seconds+toSeconds :: (TimeDiff t, Fractional n) => t -> n+toSeconds = (* recip 1000000) . fromIntegral . view microseconds --- | Make a time interval from some 'Real' type. 'Rational'-avoiding rewrite--- rules included for 'Double', 'Float', 'Integer', 'Int' and 'Int64'.+-- | Make a time difference from some 'Real' type. ----- @--- fromSeconds :: (HasBasis t, Basis t ~ (), Scalar t ~ b, Real n, Fractional b) => n -> t--- @+-- Where speed is a concern, make sure @n@ is one of 'Float', 'Double',+-- 'Int', 'Int64' or 'Integer', for which @RULES@ have been provided. {-# INLINE fromSeconds #-}-fromSeconds :: (TimeDiff t, Real n, Fractional (Scalar t)) => n -> t-fromSeconds = simply review seconds . realToFrac+fromSeconds :: (Real n, TimeDiff t) => n -> t+fromSeconds = fromSeconds' . toRational  -- | Type-restricted 'toSeconds' to avoid constraint-defaulting warnings. {-# INLINE toSeconds' #-}-toSeconds' :: (HasBasis s, Basis s ~ ()) => s -> Scalar s-toSeconds' = simply view seconds+toSeconds' :: (TimeDiff t) => t -> Rational+toSeconds' = (`decompose'` ())  -- | Type-restricted 'fromSeconds' to avoid constraint-defaulting warnings. {-# INLINE fromSeconds' #-}-fromSeconds' :: (HasBasis t, Basis t ~ ()) => Scalar t -> t-fromSeconds' = simply review seconds+fromSeconds' :: (TimeDiff t) => Rational -> t+fromSeconds' = (*^ basisValue ()) -{-# RULES+------------------------------------------------------------------------+-- not for public consumption -"toSeconds∷DiffTime→Fractional"-    toSeconds = (/ 1000000) . fromIntegral . review microDiffTime-"toSeconds∷NominalDiffTime→Fractional"-    toSeconds = (/ 1000000) . fromIntegral . review microNominalDiffTime+fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t+fromSecondsRealFrac _ = review microseconds . round . (*) 1000000 -"fromSeconds∷Double→DiffTime"-    fromSeconds = view microDiffTime . round . (*) (1000000 :: Double)-"fromSeconds∷Double→NominalDiffTime"-    fromSeconds = view microNominalDiffTime . round . (*) (1000000 :: Double)+fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t+fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral -"fromSeconds∷Float→DiffTime"-    fromSeconds = view microDiffTime . round . (*) (1000000 :: Float)-"fromSeconds∷Float→NominalDiffTime"-    fromSeconds = view microNominalDiffTime . round . (*) (1000000 :: Float)+{-# RULES -"fromSeconds∷Integer→{,Nominal}DiffTime"-    fromSeconds = fromSeconds . (fromInteger :: Integer -> Int64)-"fromSeconds∷Int→{,Nominal}DiffTime"-    fromSeconds = fromSeconds . (fromIntegral :: Int -> Int64)+"fromSeconds∷Float"     fromSeconds = fromSecondsRealFrac (0 :: Float)+"fromSeconds∷Double"    fromSeconds = fromSecondsRealFrac (0 :: Double)+"fromSeconds∷Int"       fromSeconds = fromSecondsIntegral (0 :: Int)+"fromSeconds∷Int64"     fromSeconds = fromSecondsIntegral (0 :: Int64)+"fromSeconds∷Integer"   fromSeconds = fromSecondsIntegral (0 :: Integer) -"fromSeconds∷Int64→DiffTime"-    fromSeconds = view microDiffTime . (*) 1000000-"fromSeconds∷Int64→NominalDiffTime"-    fromSeconds = view microNominalDiffTime . (*) 1000000 #-}+  #-}  ------------------------------------------------------------------------ -newtype DiffTime = DiffTime Micro-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)+newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)  #if SHOW_INTERNAL deriving instance Show DiffTime@@ -129,14 +112,13 @@     {-# INLINE decompose' #-}     decompose' (DiffTime a) = decompose' a -{-# INLINE microDiffTime #-}-microDiffTime :: Iso' Int64 DiffTime-microDiffTime = iso (DiffTime . Micro) (\ (DiffTime (Micro u)) -> u)+instance TimeDiff DiffTime where+    {-# INLINE microseconds #-}+    microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro)  ------------------------------------------------------------------------ -newtype NominalDiffTime = NominalDiffTime Micro-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)+newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)  #if SHOW_INTERNAL deriving instance Show NominalDiffTime@@ -164,35 +146,34 @@     {-# INLINE decompose' #-}     decompose' (NominalDiffTime a) = decompose' a -{-# INLINE microNominalDiffTime #-}-microNominalDiffTime :: Iso' Int64 NominalDiffTime-microNominalDiffTime = iso (NominalDiffTime . Micro)-    (\ (NominalDiffTime (Micro u)) -> u)+instance TimeDiff NominalDiffTime where+    {-# INLINE microseconds #-}+    microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro)  {-# INLINE posixDayLength #-} posixDayLength :: NominalDiffTime-posixDayLength = NominalDiffTime (toMicro 86400)+posixDayLength = microseconds # 86400000000  ------------------------------------------------------------------------ -newtype UniversalTime = UniversalRep NominalDiffTime -- since MJD epoch-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)+-- Represented as a 'NominalDiffTime' since MJD epoch.+newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO)  {-# INLINE modJulianDate #-} modJulianDate :: Iso' UniversalTime Rational-modJulianDate = iso ( \ (UniversalRep t) ->-        simply view seconds t / simply view seconds posixDayLength )+modJulianDate = iso+    (\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength)     (UniversalRep . (*^ posixDayLength))  ------------------------------------------------------------------------ -newtype UTCTime = UTCRep NominalDiffTime -- since MJD epoch-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)+-- Represented as a 'NominalDiffTime' since MJD epoch.+newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO)  data UTCView = UTCTime     { utctDay :: {-# UNPACK #-}!Day     , utctDayTime :: {-# UNPACK #-}!DiffTime-    } deriving (Eq, Ord, Data, Typeable, Show)+    } deriving (INSTANCES_USUAL, Show)  instance NFData UTCView 

@@ -6,6 +6,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +#include "thyme.h"+ module Data.Thyme.Clock.TAI     ( AbsoluteTime     , taiEpoch@@ -40,9 +42,10 @@ import Data.Thyme.LocalTime import Data.VectorSpace import System.Locale+import System.Random (Random)+import Test.QuickCheck -newtype AbsoluteTime = AbsoluteTime DiffTime-    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)+newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO)  instance Show AbsoluteTime where     {-# INLINEABLE showsPrec #-}@@ -66,7 +69,7 @@ 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)+    diff d = table . Left $ utcTime # UTCTime d zeroV     NominalDiffTime posixDay = posixDayLength  {-# INLINE absoluteTime #-}@@ -96,7 +99,7 @@     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 $+    unless (gregorian # ymd == ModifiedJulianDay mjd) . fail $         show ymd ++ " is not Modified Julian Day " ++ show mjd      tokens ["TAI", "-", "UTC", "="]@@ -118,7 +121,7 @@     return ((beginUTC, atUTC), (beginTAI, atTAI))    where-    toMJD t = simply view seconds t / simply view seconds posixDayLength+    toMJD t = toSeconds t / toSeconds posixDayLength     tokens = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) P.skipSpace      parse row = pair . unzip . rights . map (P.parseOnly row) . S.lines

@@ -26,10 +26,10 @@ import Data.Bits import qualified Data.ByteString.Char8 as S import Data.Char+import Data.Int 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.TAI@@ -206,7 +206,7 @@     {-# INLINEABLE showsTime #-}     showsTime l d@(view ordinalDate -> ordinal)         = showsTime l ordinal-        . showsTime l (view yearMonthDay ordinal)+        . showsTime l (ordinal ^. yearMonthDay)         . showsTime l (toWeekOrdinal ordinal d)         . showsTime l (toSundayOrdinal ordinal d)         . showsTime l (toMondayOrdinal ordinal d)@@ -226,9 +226,9 @@     {-# INLINEABLE showsTime #-}     showsTime l t = \ def c -> case c of         's' -> shows . fst $ qr s (Micro 1000000)-        _ -> showsTime l (view zonedTime (utc, t)) def c+        _ -> showsTime l ((utc, t) ^. zonedTime) def c       where-        NominalDiffTime s = view posixTime t+        NominalDiffTime s = t ^. posixTime #if BUG_FOR_BUG         qr = microDivMod -- rounds down #else@@ -238,12 +238,12 @@ instance FormatTime UniversalTime where     {-# INLINEABLE showsTime #-}     showsTime l t = showsTime l $ ZonedTime lt utc {timeZoneName = "UT1"} where-        lt = view (ut1LocalTime 0) t+        lt = t ^. ut1LocalTime 0  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+        lt = t ^. from (absoluteTime $ const zeroV) . utcLocalTime utc  ------------------------------------------------------------------------ @@ -358,7 +358,7 @@             -- UTCTime             's' -> do                 s <- lift (negative P.decimal)-                _tpPOSIXTime .= fromSeconds (s :: Int)+                _tpPOSIXTime .= fromSeconds (s :: Int64)                 flag IsPOSIXTime .= True                 go rspec @@ -539,12 +539,12 @@ instance ParseTime Day where     {-# INLINE buildTime #-}     buildTime tp@TimeParse {..}-        | tp ^. flag IsOrdinalDate = review ordinalDate (buildTime tp)-        | tp ^. flag IsGregorian = review gregorian (buildTime tp)-        | tp ^. flag IsWeekDate = review weekDate (buildTime tp)-        | tp ^. flag IsSundayWeek = review sundayWeek (buildTime tp)-        | tp ^. flag IsMondayWeek = review mondayWeek (buildTime tp)-        | otherwise = review ordinalDate (buildTime tp)+        | tp ^. flag IsOrdinalDate = ordinalDate # buildTime tp+        | tp ^. flag IsGregorian = gregorian # buildTime tp+        | tp ^. flag IsWeekDate = weekDate # buildTime tp+        | tp ^. flag IsSundayWeek = sundayWeek # buildTime tp+        | tp ^. flag IsMondayWeek = mondayWeek # buildTime tp+        | otherwise = ordinalDate # buildTime tp         -- TODO: Better conflict handling when multiple flags are set?  instance ParseTime TimeZone where@@ -558,8 +558,8 @@ instance ParseTime UTCTime where     {-# INLINE buildTime #-}     buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime-        then review posixTime tpPOSIXTime-        else view (from zonedTime . _2) (buildTime tp)+        then posixTime # tpPOSIXTime+        else buildTime tp ^. from zonedTime . _2  instance ParseTime UniversalTime where     {-# INLINE buildTime #-}@@ -567,7 +567,7 @@  instance ParseTime AbsoluteTime where     {-# INLINE buildTime #-}-    buildTime = view (absoluteTime $ const zeroV) <$> buildTime+    buildTime tp = buildTime tp ^. absoluteTime (const zeroV)  ------------------------------------------------------------------------ 

@@ -11,6 +11,7 @@     ) where  import Prelude+import Control.Arrow import Control.Applicative import Control.Lens hiding (singular) import Control.Monad@@ -37,8 +38,8 @@  -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. humanTimeDiffs :: (TimeDiff d) => d -> ShowS-humanTimeDiffs (microTimeDiff -> signed@(Micro (Micro . abs -> us)))-        = (if signed < Micro 0 then (:) '-' else id) . diff where+humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where+    signed@(Micro . abs -> us) = td ^. microseconds     diff = maybe id id . getFirst . fold $         zipWith (approx us . unit) (tail units) units @@ -63,27 +64,23 @@         half = Micro . fst $ microQuotRem unit (Micro 2)     inflection = if n == 1 then singular else plural -times :: String -> Rational -> Unit -> Unit-times ((++) . (:) ' ' -> singular) r Unit {unit}-    = Unit {unit = r *^ unit, plural = singular . (:) 's', ..}- units :: [Unit]-units = scanl (&) usec-    [ times "millisecond" 1000-    , times "second"      1000-    , times "minute"      60-    , times "hour"        60-    , times "day"         24-    , times "week"        7-    , times "month"       (30.4368 / 7)-    , times "year"        12-    , times "decade"      10-    , set _plural (" centuries" ++)-    . times "century"     10-    , set _plural (" millennia" ++)-    . times "millennium"  10-{-     , times "aeon"       1000000 -}-    , const (Unit maxBound id id)+units = scanl (&)+    (Unit (Micro 1) (" microsecond" ++) (" microseconds" ++))+    [ times "millisecond"   1000+    , times "second"        1000+    , times "minute"        60+    , times "hour"          60+    , times "day"           24+    , times "week"          7+    , times "month"         (30.4368 / 7)+    , times "year"          12+    , times "decade"        10+    , times "century"       10 >>> set _plural (" centuries" ++)+    , times "millennium"    10 >>> set _plural (" millennia" ++)+    , const (Unit maxBound id id) -- upper bound needed for humanTimeDiffs.diff     ] where-    usec = Unit (Micro 1) (" microsecond" ++) (" microseconds" ++)+    times :: String -> Rational -> Unit -> Unit+    times ((++) . (:) ' ' -> singular) r Unit {unit}+        = Unit {unit = r *^ unit, plural = singular . (:) 's', ..} 

@@ -24,7 +24,7 @@ utcToLocalZonedTime :: UTCTime -> IO ZonedTime utcToLocalZonedTime time = do     tz <- getTimeZone time-    return (view zonedTime (tz, time))+    return $ (tz, time) ^. zonedTime  ------------------------------------------------------------------------ -- * Lenses

@@ -7,6 +7,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} +#include "thyme.h"+ module Data.Thyme.LocalTime.Internal where  import Prelude hiding ((.))@@ -18,13 +20,15 @@ import Data.AffineSpace import Data.Data import Data.Micro-import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal import Data.Thyme.Clock.Internal #if !SHOW_INTERNAL import Data.Thyme.Format.Internal #endif import Data.Thyme.LocalTime.TimeZone import Data.VectorSpace+import System.Random+import Test.QuickCheck  ------------------------------------------------------------------------ -- * Time of day@@ -35,7 +39,7 @@     { todHour :: {-# UNPACK #-}!Hour     , todMin :: {-# UNPACK #-}!Minute     , todSec :: {-# UNPACK #-}!DiffTime-    } deriving (Eq, Ord, Data, Typeable)+    } deriving (INSTANCES_USUAL)  instance NFData TimeOfDay @@ -50,6 +54,25 @@         frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su #endif +instance Bounded TimeOfDay where+    minBound = TimeOfDay 0 0 zeroV+    maxBound = TimeOfDay 23 59 (microseconds # 60999999)++instance Random TimeOfDay where+    randomR = randomIsoR timeOfDay+    random = over _1 (^. timeOfDay) . random++instance Arbitrary TimeOfDay where+    arbitrary = do+        h <- choose (0, 23)+        m <- choose (0, 59)+        let DiffTime ml = minuteLength h m+        TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml)++{-# INLINE minuteLength #-}+minuteLength :: Hour -> Minute -> DiffTime+minuteLength h m = fromSeconds' $ if h == 23 && m == 59 then 61 else 60+ -- | Hour zero midnight :: TimeOfDay midnight = TimeOfDay 0 0 zeroV@@ -60,9 +83,9 @@  {-# INLINE makeTimeOfDayValid #-} makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay-makeTimeOfDayValid h m s@(DiffTime u) = TimeOfDay h m s+makeTimeOfDayValid h m s = TimeOfDay h m s     <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59)-    <* guard (Micro 0 <= u && u < Micro 61000000)+    <* guard (zeroV <= s && s < minuteLength h m)  {-# INLINE timeOfDay #-} timeOfDay :: Iso' DiffTime TimeOfDay@@ -96,7 +119,7 @@      {-# INLINEABLE toRatio #-}     toRatio :: DiffTime -> Rational-    toRatio t = simply view seconds t / simply view seconds posixDayLength+    toRatio t = toSeconds t / toSeconds posixDayLength      {-# INLINEABLE fromRatio #-}     fromRatio :: Rational -> DiffTime@@ -108,7 +131,7 @@ data LocalTime = LocalTime     { localDay :: {-# UNPACK #-}!Day     , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay-    } deriving (Eq, Ord, Data, Typeable)+    } deriving (INSTANCES_USUAL)  instance NFData LocalTime @@ -126,12 +149,12 @@     {-# INLINEABLE localise #-}     localise :: UTCView -> LocalTime     localise (UTCTime day dt) = LocalTime (day .+^ dd) tod where-        (dd, tod) = addMinutes timeZoneMinutes (view timeOfDay dt)+        (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay)      {-# INLINEABLE globalise #-}     globalise :: LocalTime -> UTCView     globalise (LocalTime day tod) = UTCTime (day .+^ dd)-            (review timeOfDay utcToD) where+            (timeOfDay # utcToD) where         (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod  {-# INLINE ut1LocalTime #-}@@ -142,15 +165,16 @@     {-# INLINEABLE localise #-}     localise :: UniversalTime -> LocalTime     localise (UniversalRep (NominalDiffTime t)) = LocalTime-            (ModifiedJulianDay day) (view timeOfDay (DiffTime dt)) where+            (ModifiedJulianDay $ fromIntegral day)+            (DiffTime dt ^. timeOfDay) 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+        ModifiedJulianDay (fromIntegral -> mjd) = day+        DiffTime dt = timeOfDay # tod  ------------------------------------------------------------------------ -- * Zoned Time@@ -158,7 +182,7 @@ data ZonedTime = ZonedTime     { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime     , zonedTimeZone :: !TimeZone-    } deriving (Eq, Ord, Data, Typeable)+    } deriving (INSTANCES_USUAL)  instance NFData ZonedTime where     rnf ZonedTime {..} = rnf zonedTimeZone@@ -169,11 +193,11 @@      {-# INLINE toZoned #-}     toZoned :: (TimeZone, UTCTime) -> ZonedTime-    toZoned (tz, time) = ZonedTime (view (utcLocalTime tz) time) tz+    toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz      {-# INLINE fromZoned #-}     fromZoned :: ZonedTime -> (TimeZone, UTCTime)-    fromZoned (ZonedTime lt tz) = (tz, review (utcLocalTime tz) lt)+    fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt)  #if SHOW_INTERNAL deriving instance Show ZonedTime

@@ -17,10 +17,9 @@  {-# INLINEABLE getTimeZone #-} getTimeZone :: UTCTime -> IO T.TimeZone-getTimeZone time = T.getTimeZone (T.UTCTime day dayTime) where-    day = T.ModifiedJulianDay (fromIntegral mjd)-    dayTime = fromRational (simply view seconds dt)-    UTCTime (ModifiedJulianDay mjd) dt = view utcTime time+getTimeZone t = T.getTimeZone $ T.UTCTime day (toSeconds dt) where+    day = T.ModifiedJulianDay (toInteger mjd)+    UTCTime (ModifiedJulianDay mjd) dt = t ^. utcTime  {-# INLINE getCurrentTimeZone #-} getCurrentTimeZone :: IO T.TimeZone

@@ -39,7 +39,7 @@     {-# INLINE thyme #-}     thyme = iso         (ModifiedJulianDay . fromInteger . T.toModifiedJulianDay)-        (T.ModifiedJulianDay . fromIntegral . toModifiedJulianDay)+        (T.ModifiedJulianDay . toInteger . toModifiedJulianDay)  instance Thyme T.UniversalTime UniversalTime where     {-# INLINE thyme #-}@@ -48,13 +48,13 @@ instance Thyme T.DiffTime DiffTime where     {-# INLINE thyme #-}     thyme = iso (round . (*) 1000000)-        (T.picosecondsToDiffTime . (*) 1000000 . toInteger) . microDiffTime+        (T.picosecondsToDiffTime . (*) 1000000 . toInteger) . from microseconds  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))+        (\ (T.UTCTime d t) -> UTCTime (d ^. thyme) (t ^. thyme))+        (\ (UTCTime d t) -> T.UTCTime (thyme # d) (thyme # t))  instance Thyme T.UTCTime UTCTime where     {-# INLINE thyme #-}@@ -63,7 +63,7 @@ instance Thyme T.NominalDiffTime NominalDiffTime where     {-# INLINE thyme #-}     thyme = iso (round . (*) 1000000) -- no picosecondsToNominalDiffTime D:-        (fromRational . (% 1000000) . toInteger) . microNominalDiffTime+        (fromRational . (% 1000000) . toInteger) . from microseconds  instance Thyme T.AbsoluteTime AbsoluteTime where     {-# INLINE thyme #-}@@ -77,22 +77,22 @@  instance Thyme T.TimeOfDay TimeOfDay where     {-# INLINE thyme #-}-    thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m-            . view microDiffTime . round $ s * 1000000 )-        ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational-            . (% 1000000) . toInteger $ review microDiffTime s )+    thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m $+            microseconds # round (s * 1000000) )+        ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational $+            toInteger (s ^. microseconds) % 1000000 )  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))+        (\ (T.LocalTime d t) -> LocalTime (d ^. thyme) (t ^. thyme))+        (\ (LocalTime d t) -> T.LocalTime (thyme # d) (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))+        (\ (T.ZonedTime t z) -> ZonedTime (t ^. thyme) (z ^. thyme))+        (\ (ZonedTime t z) -> T.ZonedTime (thyme # t) (thyme # z))  {-# INLINE toThyme #-} toThyme :: (Thyme a b) => a -> b@@ -119,7 +119,7 @@  {-# INLINE fromGregorian #-} fromGregorian :: Year -> Month -> DayOfMonth -> Day-fromGregorian y m d = review gregorian (YearMonthDay y m d)+fromGregorian y m d = gregorian # YearMonthDay y m d  {-# INLINE fromGregorianValid #-} fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day@@ -154,7 +154,7 @@  {-# INLINE monthAndDayToDayOfYear #-} monthAndDayToDayOfYear :: Bool -> Month -> DayOfMonth -> DayOfYear-monthAndDayToDayOfYear leap m d = review (monthDay leap) (MonthDay m d)+monthAndDayToDayOfYear leap m d = monthDay leap # MonthDay m d  {-# INLINE monthAndDayToDayOfYearValid #-} monthAndDayToDayOfYearValid :: Bool -> Month -> DayOfMonth -> Maybe DayOfYear@@ -169,7 +169,7 @@  {-# INLINE fromOrdinalDate #-} fromOrdinalDate :: Year -> DayOfYear -> Day-fromOrdinalDate y d = review ordinalDate (OrdinalDate y d)+fromOrdinalDate y d = ordinalDate # OrdinalDate y d  {-# INLINE fromOrdinalDateValid #-} fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day@@ -181,7 +181,7 @@  {-# INLINE fromSundayStartWeek #-} fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day-fromSundayStartWeek y w d = review sundayWeek (SundayWeek y w d)+fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d  {-# INLINE fromSundayStartWeekValid #-} fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day@@ -193,7 +193,7 @@  {-# INLINE fromMondayStartWeek #-} fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day-fromMondayStartWeek y w d = review mondayWeek (MondayWeek y w d)+fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d  {-# INLINE fromMondayStartWeekValid #-} fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day@@ -208,7 +208,7 @@  {-# INLINE fromWeekDate #-} fromWeekDate :: Year -> WeekOfYear -> DayOfWeek -> Day-fromWeekDate y w d = review weekDate (WeekDate y w d)+fromWeekDate y w d = weekDate # WeekDate y w d  {-# INLINE fromWeekDateValid #-} fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day@@ -236,7 +236,7 @@  {-# INLINE mkUTCTime #-} mkUTCTime :: Day -> DiffTime -> UTCTime-mkUTCTime d t = review utcTime (UTCTime d t)+mkUTCTime d t = utcTime # UTCTime d t  {-# INLINE unUTCTime #-} unUTCTime :: UTCTime -> UTCView

@@ -4,7 +4,9 @@ import Prelude import Control.Applicative import Control.Lens+import Data.AdditiveGroup import Data.Thyme+import Data.Thyme.Clock.POSIX import System.Exit import Test.QuickCheck import qualified Test.QuickCheck.Gen as Gen@@ -14,22 +16,16 @@  ------------------------------------------------------------------------ -instance Arbitrary Day where-    arbitrary = ModifiedJulianDay <$> arbitrary--instance Arbitrary DiffTime where-    arbitrary = view microDiffTime <$> arbitrary--instance Arbitrary NominalDiffTime where-    arbitrary = view microNominalDiffTime <$> arbitrary+-- FIXME: We disagree with time on how many digits to use for year.+newtype RecentTime = RecentTime UTCTime deriving (Show) -instance Arbitrary UTCTime where-    arbitrary = fmap (review utcTime) $ UTCTime-            <$> (ModifiedJulianDay <$> choose (mjd0, mjd1))-            <*> (view microDiffTime <$> choose (0, 86400999999)) where-        -- FIXME: We disagree with time on how many digits to use for year.-        ModifiedJulianDay mjd0 = review gregorian $ YearMonthDay 1000 1 1-        ModifiedJulianDay mjd1 = review gregorian $ YearMonthDay 9999 12 31+instance Arbitrary RecentTime where+    arbitrary = fmap (RecentTime . review utcTime) $ UTCTime+            <$> choose (minDay, maxDay)+            <*> choose (zeroV, pred dayLength) where+        minDay = gregorian # YearMonthDay 1000 1 1+        maxDay = gregorian # YearMonthDay 9999 12 13+        dayLength = posixDayLength ^. microseconds . from microseconds  ------------------------------------------------------------------------ 

@@ -33,10 +33,10 @@     utcs <- unGen (vectorOf samples arbitrary) <$> newStdGen <*> pure 0     let utcs' = review thyme <$> (utcs :: [UTCTime])     now <- getCurrentTime-    let now' = review thyme now+    let now' = thyme # now     let strs = T.formatTime defaultTimeLocale spec <$> utcs'     let dt = fromSeconds' 86405-    let dt' = review thyme dt+    let dt' = thyme # dt     let days = utctDay . unUTCTime <$> utcs     let days' = T.utctDay <$> utcs'     let mons = ((isLeapYear . ymdYear) &&& ymdMonth) . view gregorian <$> days@@ -78,7 +78,7 @@                 , nf (uncurry T.dayOfYearToMonthAndDay <$>) ords ) :              -- Clock-            ( "addUTCTime", 85+            ( "addUTCTime", 95                 , nf (addUTCTime dt <$>) utcs                 , nf (T.addUTCTime dt' <$>) utcs' ) : @@ -91,16 +91,16 @@                 , nf (T.utcTimeToPOSIXSeconds <$>) utcs' ) :              -- LocalTime-            ( "timeToTimeOfDay", 70+            ( "timeToTimeOfDay", 45                 , nf (timeToTimeOfDay <$>) (utctDayTime . unUTCTime <$> utcs)                 , nf (T.timeToTimeOfDay <$>) (T.utctDayTime <$> utcs') ) : -            ( "utcToLocalTime", 30+            ( "utcToLocalTime", 20                 , nf (utcToLocalTime utc <$>) utcs                 , nf (T.utcToLocalTime T.utc <$>) utcs' ) :              -- Format-            ( "formatTime", 9+            ( "formatTime", 8                 , nf (formatTime defaultTimeLocale spec <$>) utcs                 , nf (T.formatTime defaultTimeLocale spec <$>) utcs' ) : 

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++import Prelude+import Control.Monad+import Data.Int+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import Data.Thyme.Time+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup+import System.Directory+import System.Exit+import System.FilePath+import System.Posix.Redirect+import System.Random++main :: IO ()+main = do+    defaultMainWithHooksArgs simpleUserHooks+        { buildHook = hook }+        [ "build", "--ghc-option=-ddump-rule-firings" ]+    useless++hook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+hook pd lbi uh bf = do+    -- more reliable way to force a rebuild?+    forM_ ["hi", "o"] $ \ suf -> removeFile $+        buildDir lbi </> "rewrite" </> "rewrite-tmp" </> "Main" <.> suf++    (err, (out, _)) <- redirectStderr . redirectStdout $+        buildHook simpleUserHooks pd lbi uh bf+    let std = T.decodeUtf8 err `T.append` T.decodeUtf8 out++    let fired = foldr ( maybe id (flip (Map.insertWith (+)) (1 :: Int))+            . T.stripPrefix "Rule fired: " ) Map.empty (T.lines std)+    let unmatched = wanted `Map.difference` fired+    case Map.null unmatched of+        True -> mapM_ print (Map.toList $ fired `Map.intersection` wanted)+        False -> do+            putStrLn "Unmatched rules:"+            mapM_ (T.putStrLn . T.append "  ") (Map.keys unmatched)+            exitWith (ExitFailure 1)++useless :: IO ()+useless = do+    print =<< (fmap fromSeconds (randomIO :: IO Float)   :: IO DiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Double)  :: IO NominalDiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Int)     :: IO NominalDiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Int64)   :: IO DiffTime)+    print =<< (fmap fromSeconds (randomIO :: IO Integer) :: IO DiffTime)+    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO NominalDiffTime)+    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO DiffTime)+    print =<< (fmap realToFrac (randomIO :: IO DiffTime) :: IO Double)+    print =<< (fmap realToFrac (randomIO :: IO NominalDiffTime) :: IO Double)+    print =<< (fmap realToFrac (randomIO :: IO Float) :: IO NominalDiffTime)+    print =<< (fmap realToFrac (randomIO :: IO Integer) :: IO DiffTime)++wanted :: Map Text ()+wanted = Map.fromList $ flip (,) () `fmap`+    [ "fromSeconds∷Float"+    , "fromSeconds∷Double"+    , "fromSeconds∷Int"+    , "fromSeconds∷Int64"+    , "fromSeconds∷Integer"+    , "realToFrac∷DiffTime→NominalDiffTime"+    , "realToFrac∷NominalDiffTime→DiffTime"+    , "realToFrac∷DiffTime→Fractional"+    , "realToFrac∷NominalDiffTime→Fractional"+    , "realToFrac∷Real→DiffTime"+    , "realToFrac∷Real→NominalDiffTime"+    ]+

@@ -36,17 +36,17 @@  ------------------------------------------------------------------------ -prop_formatTime :: Spec -> UTCTime -> Property-prop_formatTime (Spec spec) t@(review thyme -> t')+prop_formatTime :: Spec -> RecentTime -> Property+prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t'))         = printTestCase desc (s == s') where     s = formatTime defaultTimeLocale spec t     s' = T.formatTime defaultTimeLocale spec t'     desc = "thyme: " ++ s ++ "\ntime:  " ++ s' -prop_parseTime :: Spec -> UTCTime -> Property-prop_parseTime (Spec spec) orig+prop_parseTime :: Spec -> RecentTime -> Property+prop_parseTime (Spec spec) (RecentTime orig)         = printTestCase desc (fmap (review thyme) t == t') where-    s = T.formatTime defaultTimeLocale spec (review thyme orig)+    s = T.formatTime defaultTimeLocale spec (thyme # orig)     t = parseTime defaultTimeLocale spec s :: Maybe UTCTime     t' = T.parseTime defaultTimeLocale spec s     tp = P.parseOnly (timeParser defaultTimeLocale spec) . utf8String

@@ -1,5 +1,5 @@ name:           thyme-version:        0.2.4.1+version:        0.3.0.0 synopsis:       A faster time library description:     Thyme is a rewrite of the fine @time@ library, with a particular focus@@ -16,6 +16,8 @@ build-type:     Simple cabal-version:  >= 1.8 stability:      experimental+extra-source-files:+    include/thyme.h  source-repository head     type:       git@@ -37,6 +39,7 @@     manual: True  library+    include-dirs: include     hs-source-dirs: src     exposed-modules:         Data.Thyme@@ -62,15 +65,17 @@         Data.Thyme.LocalTime.TimeZone         Data.Thyme.TH     build-depends:+        QuickCheck >= 2.4,         attoparsec >= 0.10,         base >= 4.5 && < 5,         bytestring >= 0.9,         containers,         deepseq >= 1.2,-        lens >= 3.8,+        lens >= 3.9,         old-locale >= 1.0,-        text >= 0.11,+        random,         template-haskell >= 2.6,+        text >= 0.11,         time >= 1.4,         transformers,         vector >= 0.9,@@ -99,6 +104,22 @@         thyme,         time,         vector-space+    ghc-options: -Wall++test-suite rewrite+    type: exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is: rewrite.hs+    build-depends:+        Cabal,+        base,+        containers,+        directory,+        filepath,+        random,+        system-posix-redirect >= 1.1,+        text,+        thyme     ghc-options: -Wall  benchmark bench