diff --git a/src/Data/Thyme/Calendar/Julian.hs b/src/Data/Thyme/Calendar/Julian.hs deleted file mode 100644 --- a/src/Data/Thyme/Calendar/Julian.hs +++ /dev/null @@ -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 - 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 @@ -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 ------------------------------------------------------------------------ diff --git a/tests/bench.hs b/tests/bench.hs --- a/tests/bench.hs +++ b/tests/bench.hs @@ -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) diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -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) diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -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