diff --git a/src/Data/Micro.hs b/src/Data/Micro.hs --- a/src/Data/Micro.hs +++ b/src/Data/Micro.hs @@ -56,41 +56,6 @@ toMicro :: Rational -> Micro toMicro r = Micro (fromInteger $ 1000000 * numerator r `div` denominator r) -#if INSTANCE_NUM -instance Num Micro where - {-# INLINE (+) #-} - {-# INLINE (-) #-} - {-# INLINE (*) #-} - {-# INLINE negate #-} - {-# INLINE abs #-} - {-# INLINE signum #-} - {-# INLINE fromInteger #-} - Micro a + Micro b = Micro (a + b) - Micro a - Micro b = Micro (a - b) - Micro a * Micro b = Micro (quot a 1000 * quot b 1000) - negate (Micro a) = Micro (negate a) - abs (Micro a) = Micro (abs a) - signum (Micro a) = Micro (signum a * 1000000) - fromInteger a = Micro (fromInteger a * 1000000) - -instance Real Micro where - {-# INLINE toRational #-} - toRational (Micro a) = toInteger a % 1000000 - -instance Fractional Micro where - {-# INLINE (/) #-} - {-# INLINE recip #-} - {-# INLINE fromRational #-} - Micro a / Micro b = Micro (quot (a * 1000) (b * 1000)) - recip (Micro a) = Micro (quot 1000000 a) - fromRational = toMicro - -instance RealFrac Micro where - {-# INLINE properFraction #-} - properFraction a = (fromIntegral q, r) where - (q, r) = microQuotRem a (Micro 1000000) -#endif - {-# INLINE microQuotRem #-} {-# INLINE microDivMod #-} microQuotRem, microDivMod :: Micro -> Micro -> (Int64, Micro) 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 @@ -17,6 +17,8 @@ import Data.Int import Data.Ix import Data.Thyme.Format.Internal +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V type Years = Int type Months = Int @@ -90,6 +92,32 @@ 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 a b = max a . min b + +------------------------------------------------------------------------ +-- Lookup tables for Data.Thyme.Calendar.MonthDay + +{-# NOINLINE monthLengths #-} +{-# NOINLINE monthLengthsLeap #-} +monthLengths, monthLengthsLeap :: Vector Days +monthLengths = V.fromList [31,28,31,30,31,30,31,31,30,31,30,31] +monthLengthsLeap = V.fromList [31,29,31,30,31,30,31,31,30,31,30,31] + -- J F M A M J J A S O N D + +{-# NOINLINE monthDays #-} +monthDays :: Vector ({-Month-}Int8, {-DayOfMonth-}Int8) +monthDays = V.generate 365 go where + first = V.prescanl' (+) 0 monthLengths + go yd = (fromIntegral m, fromIntegral d) where + m = maybe 12 id $ V.findIndex (yd <) first + d = succ yd - V.unsafeIndex first (pred m) + +{-# NOINLINE monthDaysLeap #-} +monthDaysLeap :: Vector ({-Month-}Int8, {-DayOfMonth-}Int8) +monthDaysLeap = V.generate 366 go where + first = V.prescanl' (+) 0 monthLengthsLeap + go yd = (fromIntegral m, fromIntegral d) where + m = maybe 12 id $ V.findIndex (yd <) first + d = succ yd - V.unsafeIndex first (pred m) ------------------------------------------------------------------------ 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,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | Julian or Gregorian. module Data.Thyme.Calendar.MonthDay @@ -14,9 +15,9 @@ import Control.Lens import Control.Monad import Data.Data -import qualified Data.Time.Calendar.MonthDay as T import Data.Thyme.Calendar.Internal import Data.Thyme.TH +import qualified Data.Vector.Unboxed as V data MonthDay = MonthDay { mdMonth :: {-# UNPACK #-}!Month @@ -30,25 +31,32 @@ {-# INLINE monthDay #-} monthDay :: Bool -> Iso' DayOfYear MonthDay monthDay leap = iso fromOrdinal toOrdinal where - -- TODO: Calls non-inlineable code from @time@. Pilfer and optimise? + (lastDay, lengths, table, ok) = if leap + then (365, monthLengthsLeap, monthDaysLeap, -1) + else (364, monthLengths, monthDays, -2) {-# INLINE fromOrdinal #-} fromOrdinal :: DayOfYear -> MonthDay - fromOrdinal yd = MonthDay m d where - (m, d) = T.dayOfYearToMonthAndDay leap yd + 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 m d) = T.monthAndDayToDayOfYear leap m d + 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 <= T.monthLength leap m) + <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m) -{-# INLINE monthLength #-} +{-# INLINEABLE monthLength #-} monthLength :: Bool -> Month -> Days -monthLength = T.monthLength +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/Clock.hs b/src/Data/Thyme/Clock.hs --- a/src/Data/Thyme/Clock.hs +++ b/src/Data/Thyme/Clock.hs @@ -1,6 +1,28 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | 'Num', 'Real', 'Fractional' and 'RealFrac' instances for 'DiffTime' and +-- 'NominalDiffTime' are only available by importing "Data.Thyme.Time". In +-- their stead, instances of 'Data.AdditiveGroup.AdditiveGroup', +-- 'Data.Basis.HasBasis' and 'Data.VectorSpace.VectorSpace' are given here. +-- Addition and subtraction are performed with the 'Data.AdditiveGroup.^+^' +-- and 'Data.AdditiveGroup.^-^' operators from +-- 'Data.AdditiveGroup.AdditiveGroup', while 'Data.VectorSpace.*^' scales by +-- a 'Rational'. To find the ratio of two time differences, define: +-- +-- @ +-- (^\/^) :: ('Data.Basis.HasBasis' v, 'Data.Basis.Basis' v ~ (), 'Data.VectorSpace.Scalar' v ~ s, 'Prelude.Fractional' s) => v -> v -> s +-- (^\/^) = ('Prelude./') '`Data.Function.on`' flip 'Data.Basis.decompose'' () +-- @ +-- +-- Finally, write @n 'Data.VectorSpace.*^' 'Data.Basis.basisValue' ()@ where +-- literals are expected. +-- +-- 'UniversalTime' and 'UTCTime' are instances of +-- 'Data.AffineSpace.AffineSpace', with @'Data.AffineSpace.Diff' +-- 'UniversalTime' ≡ 'DiffTime'@, and @'Data.AffineSpace.Diff' 'UTCTime' ≡ +-- 'NominalDiffTime'@. + module Data.Thyme.Clock ( -- * Universal Time UniversalTime 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 @@ -55,13 +55,6 @@ {-# INLINE decompose' #-} decompose' (DiffTime a) = decompose' a -#if INSTANCE_NUM -deriving instance Num DiffTime -deriving instance Real DiffTime -deriving instance Fractional DiffTime -deriving instance RealFrac DiffTime -#endif - {-# INLINE microDiffTime #-} microDiffTime :: Iso' Int64 DiffTime microDiffTime = iso (DiffTime . Micro) (\ (DiffTime (Micro u)) -> u) @@ -94,13 +87,6 @@ decompose (NominalDiffTime a) = decompose a {-# INLINE decompose' #-} decompose' (NominalDiffTime a) = decompose' a - -#if INSTANCE_NUM -deriving instance Num NominalDiffTime -deriving instance Real NominalDiffTime -deriving instance Fractional NominalDiffTime -deriving instance RealFrac NominalDiffTime -#endif {-# INLINE microNominalDiffTime #-} microNominalDiffTime :: Iso' Int64 NominalDiffTime diff --git a/src/Data/Thyme/Time.hs b/src/Data/Thyme/Time.hs --- a/src/Data/Thyme/Time.hs +++ b/src/Data/Thyme/Time.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} --- | This module provides compatibility wrappers for the things that @thyme@ --- does differently from @time@, and allows it to be used as a drop-in --- replacement for the latter, with the exceptions noted below: +-- | This module provides compatibility instances and wrappers for the +-- things that @thyme@ does differently from @time@, and allows it to be +-- used as a drop-in replacement for the latter, with the exceptions noted +-- below: -- -- * When constructing an 'UTCTime' or 'UniversalTime', use 'mkUTCTime' or -- 'mkModJulianDate' in place of @UTCTime@ or @ModJulianDate@. @@ -46,6 +50,50 @@ import qualified Data.Time.Clock.TAI as T import qualified Data.Time.LocalTime as T +instance Num Micro where + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE (*) #-} + {-# INLINE negate #-} + {-# INLINE abs #-} + {-# INLINE signum #-} + {-# INLINE fromInteger #-} + Micro a + Micro b = Micro (a + b) + Micro a - Micro b = Micro (a - b) + Micro a * Micro b = Micro (quot a 1000 * quot b 1000) + negate (Micro a) = Micro (negate a) + abs (Micro a) = Micro (abs a) + signum (Micro a) = Micro (signum a * 1000000) + fromInteger a = Micro (fromInteger a * 1000000) + +instance Real Micro where + {-# INLINE toRational #-} + toRational (Micro a) = toInteger a % 1000000 + +instance Fractional Micro where + {-# INLINE (/) #-} + {-# INLINE recip #-} + {-# INLINE fromRational #-} + Micro a / Micro b = Micro (quot (a * 1000) (b * 1000)) + recip (Micro a) = Micro (quot 1000000 a) + fromRational = toMicro + +instance RealFrac Micro where + {-# INLINE properFraction #-} + properFraction a = (fromIntegral q, r) where + (q, r) = microQuotRem a (Micro 1000000) + +deriving instance Num DiffTime +deriving instance Real DiffTime +deriving instance Fractional DiffTime +deriving instance RealFrac DiffTime + +deriving instance Num NominalDiffTime +deriving instance Real NominalDiffTime +deriving instance Fractional NominalDiffTime +deriving instance RealFrac NominalDiffTime + +------------------------------------------------------------------------ -- * Type conversion class Thyme a b | b -> a where diff --git a/tests/Common.hs b/tests/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Common.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Common where + +import Prelude +import Control.Applicative +import Control.Lens +import Data.Basis +import Data.Thyme +import Data.VectorSpace +import System.Exit +import Test.QuickCheck +import qualified Test.QuickCheck.Gen as Gen + +exit :: Bool -> IO () +exit b = exitWith $ if b then ExitSuccess else ExitFailure 1 + +------------------------------------------------------------------------ + +instance Arbitrary Day where + arbitrary = fmap (review gregorian) $ YearMonthDay + -- FIXME: We disagree with time on how many digits to use for year. + <$> choose (1000, 9999) <*> choose (1, 12) <*> choose (1, 31) + +instance Arbitrary DiffTime where + arbitrary = (^*) (basisValue ()) . toRational <$> (choose (0, 86400.999999) :: Gen Double) + +instance Arbitrary UTCTime where + arbitrary = fmap (review utcTime) $ UTCTime <$> arbitrary <*> arbitrary + +------------------------------------------------------------------------ + +newtype Spec = Spec String deriving (Show) + +instance Arbitrary Spec where + arbitrary = do + -- Pick a non-overlapping day spec generator. + day <- Gen.elements + [ spec {-YearMonthDay-}"DFYyCBbhmde" + , spec {-OrdinalDate-}"YyCj" + -- TODO: time only consider the presence of %V as + -- indication that it should parse as WeekDate + , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa" + , spec {-SundayWeek-}"YyCUuwAa" + , spec {-MondayWeek-}"YyCWuwAa" + ] :: Gen (Gen String) + -- Pick a non-overlapping day & tod spec generator. + time <- Gen.frequency + [ (16, pure $ Gen.frequency + [ (8, day) + , (4, rod) + , (2, h12) + , (1, sec) + , (1, spec {-TimeZone-}"zZ") + ] ) + -- TODO: these are broken due to issues above and below + -- , (2, pure $ spec {-aggregate-}"crXx") + , (1, pure $ spec {-UTCTime-}"s") + ] :: Gen (Gen String) + fmap (Spec . unwords) . listOf1 $ frequency + [(16, time), (4, string), (1, pure "%%")] + where + spec = Gen.elements . fmap (\ c -> ['%', c]) + string = filter ('%' /=) <$> arbitrary + -- TODO: time discards %q %Q or %p %P after setting %S or hours + -- respectively. Fudge it by always including %q and %p at end. + -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ" + rod = spec {-RestOfDay-}"RHkMqQ" + sec = (++ " %q") <$> spec {-seconds-}"ST" + h12 = (++ " %p") <$> spec {-12-hour-}"Il" + diff --git a/tests/bench.hs b/tests/bench.hs new file mode 100644 --- /dev/null +++ b/tests/bench.hs @@ -0,0 +1,129 @@ +import Prelude +import Control.Arrow +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Criterion +import Criterion.Analysis +import Criterion.Config +import Criterion.Environment +import Criterion.Monad +import Data.Basis +import Data.Monoid +import Data.Thyme +import Data.Thyme.Calendar.OrdinalDate +import Data.Thyme.Calendar.MonthDay +import Data.Thyme.Time +import qualified Data.Time as T +import qualified Data.Time.Calendar.OrdinalDate as T +import qualified Data.Time.Calendar.WeekDate as T +import qualified Data.Time.Calendar.MonthDay as T +import qualified Data.Time.Clock.POSIX as T +import Data.VectorSpace +import Test.QuickCheck as QC +import Test.QuickCheck.Gen as QC +import System.Locale + +import System.Random +import Text.Printf + +import Common + +main :: IO () +main = do + utcs <- unGen (vectorOf samples arbitrary) <$> newStdGen <*> pure 0 + let utcs' = review thyme <$> (utcs :: [UTCTime]) + now <- getCurrentTime + let now' = review thyme now + let strs = T.formatTime defaultTimeLocale spec <$> utcs' + let dt = 86405 *^ basisValue () + let dt' = review thyme dt + let days = utctDay . unUTCTime <$> utcs + let days' = T.utctDay <$> utcs' + let mons = ((isLeapYear . ymdYear) &&& ymdMonth) . view gregorian <$> days + let ords = ((isLeapYear . odYear) &&& odDay) . view ordinalDate <$> days + + let config = defaultConfig {cfgVerbosity = Last (Just Quiet)} + (exit . and <=< withConfig config) $ do + env <- measureEnvironment + ns <- getConfigItem $ fromLJ cfgResamples + mapM (benchMean env ns) $ + + -- Calendar + ( "addDays", 1.0 + , nf (addDays 28 <$>) days + , nf (T.addDays 28 <$>) days' ) : + + ( "toOrdinalDate", 2.5 + , nf (toOrdinalDate <$>) days + , nf (T.toOrdinalDate <$>) days' ) : + + ( "toGregorian", 3.5 + , nf (toGregorian <$>) days + , nf (T.toGregorian <$>) days' ) : + + ( "showGregorian", 3.3 + , nf (showGregorian <$>) days + , nf (T.showGregorian <$>) days' ) : + + ( "toWeekDate", 2.6 + , nf (toWeekDate <$>) days + , nf (T.toWeekDate <$>) days' ) : + + ( "monthLength", 1.5 + , nf (uncurry monthLength <$>) mons + , nf (uncurry T.monthLength <$>) mons ) : + + ( "dayOfYearToMonthAndDay", 2.2 + , nf (uncurry dayOfYearToMonthAndDay <$>) ords + , nf (uncurry T.dayOfYearToMonthAndDay <$>) ords ) : + + -- Clock + ( "addUTCTime", 85 + , nf (addUTCTime dt <$>) utcs + , nf (T.addUTCTime dt' <$>) utcs' ) : + + ( "diffUTCTime", 21 + , nf (diffUTCTime now <$>) utcs + , nf (T.diffUTCTime now' <$>) utcs' ) : + + ( "utcTimeToPOSIXSeconds", 10 + , nf (utcTimeToPOSIXSeconds <$>) utcs + , nf (T.utcTimeToPOSIXSeconds <$>) utcs' ) : + + -- LocalTime + ( "timeToTimeOfDay", 70 + , nf (timeToTimeOfDay <$>) (utctDayTime . unUTCTime <$> utcs) + , nf (T.timeToTimeOfDay <$>) (T.utctDayTime <$> utcs') ) : + + ( "utcToLocalTime", 30 + , nf (utcToLocalTime utc <$>) utcs + , nf (T.utcToLocalTime T.utc <$>) utcs' ) : + + -- Format + ( "formatTime", 9 + , nf (formatTime defaultTimeLocale spec <$>) utcs + , nf (T.formatTime defaultTimeLocale spec <$>) utcs' ) : + + ( "parseTime", 4.5 + , nf (parse <$>) strs + , nf (parse' <$>) strs ) : + + [] + + where + samples = 32 + spec = "%F %G %V %u %j %T %s" + parse = parseTime defaultTimeLocale spec :: String -> Maybe UTCTime + parse' = T.parseTime defaultTimeLocale spec :: String -> Maybe T.UTCTime + + benchMean env n (name, expected, us, them) = do + ours <- flip analyseMean n =<< runBenchmark env us + theirs <- flip analyseMean n =<< runBenchmark env them + let ratio = theirs / ours + liftIO . void $ printf "%-23s: %6.1fns, %5.1f×; expected %4.1f× : %s\n" + name (ours * 1000000000 / fromIntegral samples) ratio expected + (if ratio >= expected then "OK." else "oh noes. D:") + return (ratio >= expected) + diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -1,34 +1,19 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} import Prelude -import Control.Applicative import Control.Lens import Control.Monad -import Control.Monad.IO.Class -import Criterion -import Criterion.Analysis -import Criterion.Config -import Criterion.Environment -import Criterion.Monad import qualified Data.Attoparsec.ByteString.Char8 as P -import Data.Basis import Data.ByteString (ByteString) -import Data.Monoid import Data.Thyme import Data.Thyme.Time import qualified Data.Time as T -import Data.VectorSpace -import System.Exit import System.Locale -import System.Random import Test.QuickCheck -import qualified Test.QuickCheck.Gen as Gen -import Text.Printf +import Common + #if MIN_VERSION_bytestring(0,10,0) # if MIN_VERSION_bytestring(0,10,2) import qualified Data.ByteString.Builder as B @@ -51,60 +36,6 @@ ------------------------------------------------------------------------ -instance Arbitrary Day where - arbitrary = fmap (review gregorian) $ YearMonthDay - -- FIXME: We disagree with time on how many digits to use for year. - <$> choose (1000, 9999) <*> choose (1, 12) <*> choose (1, 31) - -instance Arbitrary DiffTime where - arbitrary = (^*) (basisValue ()) . toRational <$> (choose (0, 86400.999999) :: Gen Double) - -instance Arbitrary UTCTime where - arbitrary = fmap (review utcTime) $ UTCTime <$> arbitrary <*> arbitrary - ------------------------------------------------------------------------- - -newtype Spec = Spec String deriving (Show) - -instance Arbitrary Spec where - arbitrary = do - -- Pick a non-overlapping day spec generator. - day <- Gen.elements - [ spec {-YearMonthDay-}"DFYyCBbhmde" - , spec {-OrdinalDate-}"YyCj" - -- TODO: time only consider the presence of %V as - -- indication that it should parse as WeekDate - , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa" - , spec {-SundayWeek-}"YyCUuwAa" - , spec {-MondayWeek-}"YyCWuwAa" - ] :: Gen (Gen String) - -- Pick a non-overlapping day & tod spec generator. - time <- Gen.frequency - [ (16, pure $ Gen.frequency - [ (8, day) - , (4, rod) - , (2, h12) - , (1, sec) - , (1, spec {-TimeZone-}"zZ") - ] ) - -- TODO: these are broken due to issues above and below - -- , (2, pure $ spec {-aggregate-}"crXx") - , (1, pure $ spec {-UTCTime-}"s") - ] :: Gen (Gen String) - fmap (Spec . unwords) . listOf1 $ frequency - [(16, time), (4, string), (1, pure "%%")] - where - spec = Gen.elements . fmap (\ c -> ['%', c]) - string = filter ('%' /=) <$> arbitrary - -- TODO: time discards %q %Q or %p %P after setting %S or hours - -- respectively. Fudge it by always including %q and %p at end. - -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ" - rod = spec {-RestOfDay-}"RHkMqQ" - sec = (++ " %q") <$> spec {-seconds-}"ST" - h12 = (++ " %p") <$> spec {-12-hour-}"Il" - ------------------------------------------------------------------------- - prop_formatTime :: Spec -> UTCTime -> Property prop_formatTime (Spec spec) t@(review thyme -> t') = printTestCase desc (s == s') where @@ -125,39 +56,10 @@ ------------------------------------------------------------------------ main :: IO () -main = do - correct <- fmap (all isSuccess) . mapM quickCheckResult $ +main = (exit . all isSuccess <=< mapM quickCheckResult) $ prop_formatTime : prop_parseTime : [] - - ts <- Gen.unGen (vectorOf 10 arbitrary) <$> newStdGen <*> pure 0 - let ts' = review thyme <$> (ts :: [UTCTime]) - let ss = T.formatTime defaultTimeLocale spec <$> ts' - fast <- fmap and . withConfig config $ do - env <- measureEnvironment - ns <- getConfigItem $ fromLJ cfgResamples - mapM (benchMean env ns) $ - ( "formatTime", 9 - , nf (formatTime defaultTimeLocale spec <$>) ts - , nf (T.formatTime defaultTimeLocale spec <$>) ts' ) : - ( "parseTime", 4.5, nf (parse <$>) ss, nf (parse' <$>) ss ) : - [] - - exitWith $ if correct && fast then ExitSuccess else ExitFailure 1 where isSuccess r = case r of Success {} -> True; _ -> False - config = defaultConfig {cfgVerbosity = Last (Just Quiet)} - - spec = "%F %G %V %u %j %T %s" - parse = parseTime defaultTimeLocale spec :: String -> Maybe UTCTime - parse' = T.parseTime defaultTimeLocale spec :: String -> Maybe T.UTCTime - - benchMean env n (name, expected, us, them) = do - ours <- flip analyseMean n =<< runBenchmark env us - theirs <- flip analyseMean n =<< runBenchmark env them - let ratio = theirs / ours - liftIO . void $ printf - "%s: %.1f× faster; expected %.1f×.\n" name ratio expected - return (ratio >= expected) diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,5 +1,5 @@ name: thyme -version: 0.2.2.0 +version: 0.2.3.0 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus @@ -26,11 +26,6 @@ default: True manual: True -flag instance-num - description: instance Num (Nominal)DiffTime - default: True - manual: True - flag show-internal description: instance Show of internal representation default: False @@ -76,12 +71,11 @@ template-haskell >= 2.6, time >= 1.4, transformers, + vector >= 0.9, vector-space >= 0.8 ghc-options: -Wall if flag(bug-for-bug) cpp-options: -DBUG_FOR_BUG=1 - if flag(instance-num) - cpp-options: -DINSTANCE_NUM=1 if flag(show-internal) cpp-options: -DSHOW_INTERNAL=1 if flag(Werror) @@ -91,16 +85,32 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: sanity.hs + other-modules: Common build-depends: QuickCheck, attoparsec, base, bytestring, + lens, + old-locale, + text, + thyme, + time, + vector-space + ghc-options: -Wall + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: bench.hs + other-modules: Common + build-depends: + QuickCheck, + base, criterion, lens, old-locale, random, - text, thyme, time, transformers,