diff --git a/include/thyme.h b/include/thyme.h new file mode 100644 --- /dev/null +++ b/include/thyme.h @@ -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 diff --git a/src/Data/Micro.hs b/src/Data/Micro.hs --- a/src/Data/Micro.hs +++ b/src/Data/Micro.hs @@ -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 diff --git a/src/Data/Thyme.hs b/src/Data/Thyme.hs --- a/src/Data/Thyme.hs +++ b/src/Data/Thyme.hs @@ -22,7 +22,7 @@ -- . 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 diff --git a/src/Data/Thyme/Calendar.hs b/src/Data/Thyme/Calendar.hs --- a/src/Data/Thyme/Calendar.hs +++ b/src/Data/Thyme/Calendar.hs @@ -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 diff --git a/src/Data/Thyme/Calendar/Internal.hs b/src/Data/Thyme/Calendar/Internal.hs --- a/src/Data/Thyme/Calendar/Internal.hs +++ b/src/Data/Thyme/Calendar/Internal.hs @@ -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 diff --git a/src/Data/Thyme/Calendar/MonthDay.hs b/src/Data/Thyme/Calendar/MonthDay.hs --- a/src/Data/Thyme/Calendar/MonthDay.hs +++ b/src/Data/Thyme/Calendar/MonthDay.hs @@ -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 diff --git a/src/Data/Thyme/Calendar/OrdinalDate.hs b/src/Data/Thyme/Calendar/OrdinalDate.hs --- a/src/Data/Thyme/Calendar/OrdinalDate.hs +++ b/src/Data/Thyme/Calendar/OrdinalDate.hs @@ -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 diff --git a/src/Data/Thyme/Calendar/WeekDate.hs b/src/Data/Thyme/Calendar/WeekDate.hs --- a/src/Data/Thyme/Calendar/WeekDate.hs +++ b/src/Data/Thyme/Calendar/WeekDate.hs @@ -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 diff --git a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs --- a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs +++ b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs @@ -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) diff --git a/src/Data/Thyme/Clock.hs b/src/Data/Thyme/Clock.hs --- a/src/Data/Thyme/Clock.hs +++ b/src/Data/Thyme/Clock.hs @@ -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' diff --git a/src/Data/Thyme/Clock/Internal.hs b/src/Data/Thyme/Clock/Internal.hs --- a/src/Data/Thyme/Clock/Internal.hs +++ b/src/Data/Thyme/Clock/Internal.hs @@ -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 . -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 ? +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 diff --git a/src/Data/Thyme/Clock/TAI.hs b/src/Data/Thyme/Clock/TAI.hs --- a/src/Data/Thyme/Clock/TAI.hs +++ b/src/Data/Thyme/Clock/TAI.hs @@ -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 diff --git a/src/Data/Thyme/Format.hs b/src/Data/Thyme/Format.hs --- a/src/Data/Thyme/Format.hs +++ b/src/Data/Thyme/Format.hs @@ -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) ------------------------------------------------------------------------ diff --git a/src/Data/Thyme/Format/Human.hs b/src/Data/Thyme/Format/Human.hs --- a/src/Data/Thyme/Format/Human.hs +++ b/src/Data/Thyme/Format/Human.hs @@ -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', ..} diff --git a/src/Data/Thyme/LocalTime.hs b/src/Data/Thyme/LocalTime.hs --- a/src/Data/Thyme/LocalTime.hs +++ b/src/Data/Thyme/LocalTime.hs @@ -24,7 +24,7 @@ utcToLocalZonedTime :: UTCTime -> IO ZonedTime utcToLocalZonedTime time = do tz <- getTimeZone time - return (view zonedTime (tz, time)) + return $ (tz, time) ^. zonedTime ------------------------------------------------------------------------ -- * Lenses diff --git a/src/Data/Thyme/LocalTime/Internal.hs b/src/Data/Thyme/LocalTime/Internal.hs --- a/src/Data/Thyme/LocalTime/Internal.hs +++ b/src/Data/Thyme/LocalTime/Internal.hs @@ -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 diff --git a/src/Data/Thyme/LocalTime/TimeZone.hs b/src/Data/Thyme/LocalTime/TimeZone.hs --- a/src/Data/Thyme/LocalTime/TimeZone.hs +++ b/src/Data/Thyme/LocalTime/TimeZone.hs @@ -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 diff --git a/src/Data/Thyme/Time/Core.hs b/src/Data/Thyme/Time/Core.hs --- a/src/Data/Thyme/Time/Core.hs +++ b/src/Data/Thyme/Time/Core.hs @@ -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 diff --git a/tests/Common.hs b/tests/Common.hs --- a/tests/Common.hs +++ b/tests/Common.hs @@ -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 ------------------------------------------------------------------------ diff --git a/tests/bench.hs b/tests/bench.hs --- a/tests/bench.hs +++ b/tests/bench.hs @@ -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' ) : diff --git a/tests/rewrite.hs b/tests/rewrite.hs new file mode 100644 --- /dev/null +++ b/tests/rewrite.hs @@ -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" + ] + diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -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 diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -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