thyme 0.3.0.2 → 0.3.0.3
raw patch · 5 files changed
+44/−120 lines, 5 files
Files
- src/Data/Thyme/Calendar/Julian.hs +0/−88
- src/Data/Thyme/Format.hs +26/−15
- tests/bench.hs +16/−14
- tests/sanity.hs +1/−1
- thyme.cabal +1/−2
− src/Data/Thyme/Calendar/Julian.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}--#include "thyme.h"---- | Proleptic Julian Dates-module Data.Thyme.Calendar.Julian- ( OrdinalDate (..), Year, DayOfYear- , module Data.Thyme.Calendar.Julian- , _odYear, _odDay- ) where--import Prelude-import Control.Applicative-{- import Control.DeepSeq -}-import Control.Monad-import Control.Lens-{- import Data.Data -}-import Data.Thyme.Calendar-import Data.Thyme.Calendar.Internal-import Data.Thyme.Calendar.OrdinalDate-{- import Data.Thyme.TH -}-{- import System.Random -}-{- import Test.QuickCheck -}--{-# INLINE julianOrdinal #-}-julianOrdinal :: Iso' Day OrdinalDate-julianOrdinal = iso toOrdinal fromOrdinal where-- {-# INLINEABLE toOrdinal #-}- toOrdinal :: Day -> OrdinalDate- toOrdinal (ModifiedJulianDay mjd) = OrdinalDate {..} where- (quad, d) = divMod (mjd + 678577) 1461- yoff = min (div d 365) 3- odDay = d - (yoff * 365) + 1- odYear = quad * 4 + yoff + 1-- {-# INLINEABLE fromOrdinal #-}- fromOrdinal :: OrdinalDate -> Day- fromOrdinal OrdinalDate {..} = ModifiedJulianDay mjd where- yd = clip 1 (if isJulianLeapYear odYear then 366 else 365) odDay- clip a b = max a . min b- y = odYear - 1- mjd = yd + 365 * y + div y 4 - 678578--{-# INLINEABLE julianOrdinalValid #-}-julianOrdinalValid :: OrdinalDate -> Maybe Day-julianOrdinalValid OrdinalDate {..} = ModifiedJulianDay mjd- <$ guard (1 <= odDay && odDay <= lastDay) where- lastDay = if isJulianLeapYear odYear then 366 else 365- y = odYear - 1- mjd = odDay + 365 * y + div y 4 - 678578--{-# INLINE isJulianLeapYear #-}-isJulianLeapYear :: Year -> Bool-isJulianLeapYear y = mod y 4 == 0----------------------------------------------------------------------------{-# INLINE julianYearMonthDay #-}-julianYearMonthDay :: Iso' OrdinalDate YearMonthDay-julianYearMonthDay = iso fromOrdinal toOrdinal where-- {-# INLINEABLE fromOrdinal #-}- fromOrdinal :: OrdinalDate -> YearMonthDay- fromOrdinal OrdinalDate {..} = YearMonthDay odYear m d where- MonthDay m d = odDay ^. monthDay (isJulianLeapYear odYear)-- {-# INLINEABLE toOrdinal #-}- toOrdinal :: YearMonthDay -> OrdinalDate- toOrdinal YearMonthDay {..} = OrdinalDate ymdYear yd where- yd = monthDay (isJulianLeapYear ymdYear) # MonthDay ymdMonth ymdDay--{-# INLINE julianYearMonthDayValid #-}-julianYearMonthDayValid :: YearMonthDay -> Maybe OrdinalDate-julianYearMonthDayValid YearMonthDay {..} = OrdinalDate ymdYear- <$> monthDayValid (isJulianLeapYear ymdYear) (MonthDay ymdMonth ymdDay)----------------------------------------------------------------------------{-# INLINE julian #-}-julian :: Iso' Day YearMonthDay-julian = julianOrdinal . julianYearMonthDay--{-# INLINE julianValid #-}-julianValid :: YearMonthDay -> Maybe Day-julianValid ymd = review julianOrdinal <$> julianYearMonthDayValid ymd-
src/Data/Thyme/Format.hs view
@@ -309,8 +309,10 @@ -- Hour 'H' -> lift (dec0 2) >>= setHour24 'I' -> lift (dec0 2) >>= setHour12- 'k' -> lift (dec_ 2 <|> dec_ 1) >>= setHour24- 'l' -> lift (dec_ 2 <|> dec_ 1) >>= setHour12+ 'k' -> (lift (dec_ 2) >>= setHour24)+ <|> (lift (dec_ 1) >>= setHour24)+ 'l' -> (lift (dec_ 2) >>= setHour12)+ <|> (lift (dec_ 1) >>= setHour12) -- Minute 'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec -- Second@@ -320,8 +322,7 @@ >>= assign _tpSecFrac >> go rspec -- Year- -- FIXME: should full years / centuries be fixed width?- 'Y' -> lift (negative P.decimal) >>= setYear+ 'Y' -> fullYear 'y' -> lift (dec0 2) >>= setCenturyYear 'C' -> lift (dec0 2) >>= setCentury -- Month@@ -331,14 +332,15 @@ 'm' -> lift (dec0 2) >>= setMonth -- DayOfMonth 'd' -> lift (dec0 2) >>= setDayOfMonth- 'e' -> lift (dec_ 2 <|> dec_ 1) >>= setDayOfMonth+ 'e' -> (lift (dec_ 2) >>= setDayOfMonth)+ <|> (lift (dec_ 1) >>= setDayOfMonth) -- DayOfYear 'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> flag IsOrdinalDate .= True >> go rspec -- Year (WeekDate) -- FIXME: problematic if input contains both %Y and %G- 'G' -> flag IsWeekDate .= True >> lift (dec0 4) >>= setYear+ 'G' -> flag IsWeekDate .= True >> fullYear 'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear 'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury -- WeekOfYear@@ -377,6 +379,15 @@ flag PostMeridiem .= pm flag TwelveHour .= True go rspec+ -- NOTE: if a greedy parse fails or causes a later failure,+ -- then backtrack and only accept 4-digit years; see #5.+ fullYear = year (negative P.decimal) <|> year (dec0 4) where+ year p = do+ (c, y) <- (`divMod` 100) <$> lift p+ flag HasCentury .= True+ _tpCentury .= c+ _tpCenturyYear .= y+ go rspec setHour12 h = do flag TwelveHour .= True _tpHour .= h@@ -385,11 +396,6 @@ flag TwelveHour .= False _tpHour .= h go rspec- setYear ((`divMod` 100) -> (c, y)) = do- flag HasCentury .= True- _tpCentury .= c- _tpCenturyYear .= y- go rspec setCenturyYear y = do _tpCenturyYear .= y; go rspec setCentury c = do _tpCentury .= c@@ -417,7 +423,7 @@ lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec) c : rspec | isAscii c -> lift (P.char c) >> go rspec c : rspec -> lift (charU8 c) >> go rspec- "" -> lift P.skipSpace+ "" -> return () {-# INLINE micro #-} micro :: Parser Micro@@ -444,19 +450,24 @@ tpPOSIXTime = zeroV tpTimeZone = utc +{-# INLINE buildTimeParser #-}+buildTimeParser :: (ParseTime t) => TimeLocale -> String -> Parser t+buildTimeParser l spec = buildTime+ <$ P.skipSpace <*> timeParser l spec <* P.skipSpace <* P.endOfInput+ {-# INLINEABLE parseTime #-} parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t parseTime l spec = either (const Nothing) Just- . P.parseOnly (buildTime <$> timeParser l spec) . utf8String+ . P.parseOnly (buildTimeParser l spec) . utf8String {-# INLINEABLE readTime #-} readTime :: (ParseTime t) => TimeLocale -> String -> String -> t readTime l spec = either error id- . P.parseOnly (buildTime <$> timeParser l spec) . utf8String+ . P.parseOnly (buildTimeParser l spec) . utf8String {-# INLINEABLE readsTime #-} readsTime :: (ParseTime t) => TimeLocale -> String -> ReadS t-readsTime l spec = parserToReadS (buildTime <$> timeParser l spec)+readsTime l = parserToReadS . buildTimeParser l ------------------------------------------------------------------------
tests/bench.hs view
@@ -54,36 +54,36 @@ , nf (addDays 28 <$>) days , nf (T.addDays 28 <$>) days' ) : - ( "toOrdinalDate", 2.5+ ( "toOrdinalDate", 2.7 , nf (toOrdinalDate <$>) days , nf (T.toOrdinalDate <$>) days' ) : - ( "toGregorian", 3.5+ ( "toGregorian", 4.3 , nf (toGregorian <$>) days , nf (T.toGregorian <$>) days' ) : - ( "showGregorian", 3.3+ ( "showGregorian", 3.8 , nf (showGregorian <$>) days , nf (T.showGregorian <$>) days' ) : - ( "toWeekDate", 2.6+ ( "toWeekDate", 2.5 , nf (toWeekDate <$>) days , nf (T.toWeekDate <$>) days' ) : - ( "monthLength", 1.5+ ( "monthLength", 1.8 , nf (uncurry monthLength <$>) mons , nf (uncurry T.monthLength <$>) mons ) : - ( "dayOfYearToMonthAndDay", 2.2+ ( "dayOfYearToMonthAndDay", 4.3 , nf (uncurry dayOfYearToMonthAndDay <$>) ords , nf (uncurry T.dayOfYearToMonthAndDay <$>) ords ) : -- Clock- ( "addUTCTime", 95+ ( "addUTCTime", 85 , nf (addUTCTime dt <$>) utcs , nf (T.addUTCTime dt' <$>) utcs' ) : - ( "diffUTCTime", 21+ ( "diffUTCTime", 22 , nf (diffUTCTime now <$>) utcs , nf (T.diffUTCTime now' <$>) utcs' ) : @@ -92,20 +92,20 @@ , nf (T.utcTimeToPOSIXSeconds <$>) utcs' ) : -- LocalTime- ( "timeToTimeOfDay", 45+ ( "timeToTimeOfDay", 40 , nf (timeToTimeOfDay <$>) (utctDayTime . unUTCTime <$> utcs) , nf (T.timeToTimeOfDay <$>) (T.utctDayTime <$> utcs') ) : - ( "utcToLocalTime", 20+ ( "utcToLocalTime", 22 , nf (utcToLocalTime utc <$>) utcs , nf (T.utcToLocalTime T.utc <$>) utcs' ) : -- Format- ( "formatTime", 8+ ( "formatTime", 7.5 , nf (formatTime defaultTimeLocale spec <$>) utcs , nf (T.formatTime defaultTimeLocale spec <$>) utcs' ) : - ( "parseTime", 4.5+ ( "parseTime", 5.2 , nf (parse <$>) strs , nf (parse' <$>) strs ) : @@ -121,8 +121,10 @@ 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+ liftIO . void $ printf+ "%-23s: %6.1fns, %5.1f×; expected %4.1f× : %+3.0f%% %s\n"+ name (ours * 1000000000 / fromIntegral samples)+ ratio expected ((ratio / expected - 1) * 100) (if ratio >= expected then "OK." else "oh noes. D:") return (ratio >= expected)
tests/sanity.hs view
@@ -49,7 +49,7 @@ 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+ tp = P.parse (timeParser defaultTimeLocale spec) . utf8String desc = "input: " ++ show s ++ "\nthyme: " ++ show t ++ "\ntime: " ++ show t' ++ "\nstate: " ++ show (tp s)
thyme.cabal view
@@ -1,5 +1,5 @@ name: thyme-version: 0.3.0.2+version: 0.3.0.3 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus@@ -49,7 +49,6 @@ exposed-modules: Data.Thyme Data.Thyme.Calendar- Data.Thyme.Calendar.Julian Data.Thyme.Calendar.MonthDay Data.Thyme.Calendar.OrdinalDate Data.Thyme.Calendar.WeekDate