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 @@ -2,10 +2,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +#if SHOW_INTERNAL +{-# LANGUAGE StandaloneDeriving #-} +#endif {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -121,29 +123,80 @@ instance NFData OrdinalDate +-- Brief description of the toOrdinal computation. +-- +-- The length of the years in Gregorian calendar is periodic with +-- period of 400 years. There are 100 - 4 + 1 = 97 leap years in a +-- period, so the average length of a year is 365 + 97/400 = +-- 146097/400 days. +-- +-- Now, if you consider these -- let's call them nominal -- years, +-- then for any point in time, for any linear day number we can +-- determine which nominal year does it fall into by a single +-- division. Moreover, if we align the start of the calendar year 1 +-- with the start of the nominal year 1, then the calendar years and +-- nominal years never get too much out of sync. Specifically: +-- +-- * start of the first day of a calendar year might fall into the +-- preceding nominal year, but never more than by 1.5 days (591/400 +-- days, to be precise) +-- * the start of the last day of a calendar year always falls into +-- its nominal year (even for the leap years). +-- +-- So, to find out the calendar year for a given day, we calculate +-- which nominal year does its start fall. And, if we are not too +-- close to the end of year, we have the right calendar +-- year. Othewise, we just check whether it falls within the next +-- calendar year. +-- +-- Notes: to make the reasoning simpler and more efficient ('quot' is +-- faster than 'div') we do the computation directly only for positive +-- years (days after 1-1-1). For earlier dates we "transate" by an +-- integral number of 400 year periods, do the computation and +-- translate back. + {-# INLINE ordinalDate #-} ordinalDate :: Iso' Day OrdinalDate ordinalDate = iso toOrd fromOrd where {-# INLINEABLE toOrd #-} toOrd :: Day -> OrdinalDate - toOrd (ModifiedJulianDay mjd) = OrdinalDate year yd where - -- pilfered - a = mjd + 678575 - (quadcent, b) = divMod a 146097 - cent = min (div b 36524) 3 - c = b - cent * 36524 - (quad, d) = divMod c 1461 - y = min (div d 365) 3 - yd = d - y * 365 + 1 - year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 + toOrd (ModifiedJulianDay mjd) + | dayB0 <= 0 = case toOrdB0 dayInQC of + OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd + | otherwise = toOrdB0 dayB0 + where + dayB0 = mjd + 678575 + (quadCent, dayInQC) = dayB0 `divMod` 146097 + -- Input: days since 1-1-1. Precondition: has to be positive! + {-# INLINE toOrdB0 #-} + toOrdB0 :: Int -> OrdinalDate + toOrdB0 dayB0 = res + where + (y0, r) = (400 * dayB0) `quotRem` 146097 + d0 = dayInYear y0 dayB0 + d1 = dayInYear (y0 + 1) dayB0 + res = if r > 146097 - 600 && d1 > 0 + then OrdinalDate (y0 + 1 + 1) d1 + else OrdinalDate (y0 + 1) d0 + + -- Input: (year - 1) (day as days since 1-1-1) + -- Precondition: year is positive! + {-# INLINE dayInYear #-} + dayInYear :: Int -> Int -> Int + dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1 + where + leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2 + centuries = y0 `quot` 100 + {-# INLINEABLE fromOrd #-} fromOrd :: OrdinalDate -> Day fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where - -- pilfered - y = year - 1 - mjd = 365 * y + div y 4 - div y 100 + div y 400 - 678576 + years = year - 1 + centuries = years `div` 100 + leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2 + mjd = 365 * years + leaps - 678576 + clip 1 (if isLeapYear year then 366 else 365) yd clip a b = max a . min b 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 @@ -74,6 +74,11 @@ fromSeconds' :: (TimeDiff t) => Rational -> t fromSeconds' = (*^ basisValue ()) +{-# INLINE picoseconds #-} +picoseconds :: (TimeDiff t) => Iso' t Integer +picoseconds = microseconds . iso ((*) 1000000 . toInteger) + (\ ps -> fromInteger $ quot (ps + signum ps * 500000) 1000000) + ------------------------------------------------------------------------ -- not for public consumption diff --git a/src/Data/Thyme/Clock/POSIX.hsc b/src/Data/Thyme/Clock/POSIX.hsc --- a/src/Data/Thyme/Clock/POSIX.hsc +++ b/src/Data/Thyme/Clock/POSIX.hsc @@ -6,7 +6,9 @@ module Data.Thyme.Clock.POSIX ( posixDayLength - , module Data.Thyme.Clock.POSIX + , POSIXTime + , posixTime + , getPOSIXTime ) where import Prelude @@ -14,7 +16,6 @@ import Data.AdditiveGroup import Data.Thyme.Internal.Micro import Data.Thyme.Clock.Internal -import Data.VectorSpace #ifdef mingw32_HOST_OS import System.Win32.Time @@ -32,7 +33,8 @@ posixTime :: Iso' UTCTime POSIXTime posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch) (UTCRep . (^+^) unixEpoch) where - unixEpoch = {-ModifiedJulianDay-}40587 *^ posixDayLength + unixEpoch = review microseconds $ + {-ModifiedJulianDay-}40587 * {-posixDayLength-}86400000000 {-# INLINE getPOSIXTime #-} getPOSIXTime :: IO POSIXTime 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 @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "thyme.h" @@ -18,6 +19,9 @@ import Prelude import Control.Applicative +#if SHOW_INTERNAL +import Control.Arrow +#endif import Control.Lens import Control.Monad.Trans import Control.Monad.State.Strict @@ -483,6 +487,17 @@ ------------------------------------------------------------------------ +deriving instance Read UTCView +#if SHOW_INTERNAL +deriving instance Read Day +deriving instance Read TimeOfDay +deriving instance Read LocalTime +deriving instance Read ZonedTime +deriving instance Read TimeZone +instance Read UTCTime where + {-# INLINE readsPrec #-} + readsPrec n = fmap (first $ review utcTime) . readsPrec n +#else instance Read Day where {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ @@ -507,6 +522,7 @@ {-# INLINEABLE readsPrec #-} readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z" +#endif ------------------------------------------------------------------------ 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 @@ -29,6 +29,7 @@ import qualified Data.Time.Clock as T import qualified Data.Time.Clock.TAI as T import qualified Data.Time.LocalTime as T +import Unsafe.Coerce ------------------------------------------------------------------------ -- * Type conversion @@ -48,9 +49,12 @@ instance Thyme T.DiffTime DiffTime where {-# INLINE thyme #-} - thyme = iso (round . (*) 1000000) - (T.picosecondsToDiffTime . (*) 1000000 . toInteger) . from microseconds + thyme = iso unsafeCoerce unsafeCoerce . from picoseconds +instance Thyme T.NominalDiffTime NominalDiffTime where + {-# INLINE thyme #-} + thyme = iso unsafeCoerce unsafeCoerce . from picoseconds + instance Thyme T.UTCTime UTCView where {-# INLINE thyme #-} thyme = iso @@ -61,11 +65,6 @@ {-# INLINE thyme #-} thyme = thyme . from utcTime -instance Thyme T.NominalDiffTime NominalDiffTime where - {-# INLINE thyme #-} - thyme = iso (round . (*) 1000000) -- no picosecondsToNominalDiffTime D: - (fromRational . (% 1000000) . toInteger) . from microseconds - instance Thyme T.AbsoluteTime AbsoluteTime where {-# INLINE thyme #-} thyme = iso (`T.diffAbsoluteTime` T.taiEpoch) @@ -234,7 +233,8 @@ {-# INLINE picosecondsToDiffTime #-} picosecondsToDiffTime :: Int64 -> DiffTime -picosecondsToDiffTime a = DiffTime (Micro $ div (a + 500000) 1000000) +picosecondsToDiffTime a = DiffTime . Micro $ + quot (a + signum a * 500000) 1000000 {-# INLINE mkUTCTime #-} mkUTCTime :: Day -> DiffTime -> UTCTime diff --git a/tests/bench.hs b/tests/bench.hs --- a/tests/bench.hs +++ b/tests/bench.hs @@ -61,6 +61,8 @@ let years = view (gregorian . _ymdYear) <$> days let years' = (\ (y, _m, _d) -> y) . T.toGregorian <$> days' let mons = ((isLeapYear . ymdYear) &&& ymdMonth) . view gregorian <$> days + let yyds = (odYear &&& odDay) . view ordinalDate <$> days + let yyds' = ((fromIntegral . odYear) &&& odDay) . view ordinalDate <$> days let ords = ((isLeapYear . odYear) &&& odDay) . view ordinalDate <$> days let pxs = utcTimeToPOSIXSeconds <$> utcs let pxs' = T.utcTimeToPOSIXSeconds <$> utcs' @@ -80,6 +82,10 @@ , nf (toOrdinalDate <$>) days , nf (T.toOrdinalDate <$>) days' ) : + ( "fromOrdinalDate", 2.0 + , nf (uncurry fromOrdinalDate <$>) yyds + , nf (uncurry T.fromOrdinalDate <$>) yyds' ) : + ( "toGregorian", 4.3 , nf (toGregorian <$>) days , nf (T.toGregorian <$>) days' ) : @@ -158,4 +164,3 @@ ratio expected ((ratio / expected - 1) * 100) (if ratio >= expected then "OK." else "oh noes. D:") return (ratio >= expected) - diff --git a/tests/hlint.hs b/tests/hlint.hs --- a/tests/hlint.hs +++ b/tests/hlint.hs @@ -11,8 +11,6 @@ , "--cpp-include=include" , "--cpp-include=dist/build/autogen" , "--cpp-define=SHOW_INTERNAL=1" - , "-XNoUnboxedTuples" - , "-i", "Unused LANGUAGE pragma" , "-i", "Reduce duplication" , "-i", "Redundant lambda" , "-i", "Use if" diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -6,13 +6,14 @@ #endif import Prelude +import Control.Arrow import Control.Lens -import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as P import Data.ByteString (ByteString) import Data.Thyme import Data.Thyme.Time import qualified Data.Time as T +import qualified Data.Time.Calendar.OrdinalDate as T import System.Locale import Test.QuickCheck @@ -40,6 +41,13 @@ ------------------------------------------------------------------------ +prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool +prop_ShowRead a = (a, "") `elem` reads (show a) + +prop_toOrdinalDate :: Day -> Bool +prop_toOrdinalDate day = + fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day) + prop_formatTime :: Spec -> RecentTime -> Property prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t')) #if MIN_VERSION_QuickCheck(2,7,0) @@ -65,21 +73,21 @@ desc = "input: " ++ show s ++ "\nthyme: " ++ show t ++ "\ntime: " ++ show t' ++ "\nstate: " ++ show (tp s) -prop_ShowRead :: (Eq a, Show a, Read a) => a -> Bool -prop_ShowRead a = (a, "") `elem` reads (show a) - ------------------------------------------------------------------------ {-# ANN main "HLint: ignore Use list literal" #-} main :: IO () -main = (exit . all isSuccess <=< sequence) $ - quickCheckResult (prop_ShowRead :: Day -> Bool) : - quickCheckResult (prop_ShowRead :: DiffTime -> Bool) : - quickCheckResult (prop_ShowRead :: NominalDiffTime -> Bool) : - quickCheckResult (prop_ShowRead :: UTCTime -> Bool) : - quickCheckResult prop_formatTime : - quickCheckResult prop_parseTime : - [] - where +main = exit . all isSuccess =<< sequence + [ qc 10000 (prop_ShowRead :: Day -> Bool) + , qc 10000 (prop_ShowRead :: DiffTime -> Bool) + , qc 10000 (prop_ShowRead :: NominalDiffTime -> Bool) + , qc 10000 (prop_ShowRead :: UTCTime -> Bool) + , qc 10000 prop_toOrdinalDate + , qc 1000 prop_formatTime + , qc 1000 prop_parseTime + + ] where isSuccess r = case r of Success {} -> True; _ -> False + qc :: Testable prop => Int -> prop -> IO Result + qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n} diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,5 +1,5 @@ name: thyme -version: 0.3.5.2 +version: 0.3.5.3 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus @@ -160,7 +160,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests if flag(HLint) - build-depends: base, hlint >= 1.8.59 + build-depends: base, hlint >= 1.9 else buildable: False