diff --git a/include/thyme.h b/include/thyme.h --- a/include/thyme.h +++ b/include/thyme.h @@ -1,3 +1,3 @@ -#define INSTANCES_USUAL Eq, Ord, Data, Typeable +#define INSTANCES_USUAL Eq, Ord, Data, Typeable, Generic #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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -18,6 +19,7 @@ import Data.Ix import Data.Ratio import Data.VectorSpace +import GHC.Generics (Generic) import System.Random import Test.QuickCheck 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 @@ -72,6 +72,7 @@ $ min (gregorianMonthLength y' m') d where ((+) y -> y', (+) 1 -> m') = divMod (m + n - 1) 12 +{-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-} {-# INLINEABLE gregorianMonthsRollover #-} gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of 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,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -22,6 +23,7 @@ import Data.Thyme.Format.Internal import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V +import GHC.Generics (Generic) import System.Random import Test.QuickCheck @@ -145,6 +147,7 @@ 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 +{-# ANN monthDays "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDays #-} monthDays :: Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDays = V.generate 365 go where @@ -153,6 +156,7 @@ m = maybe 12 id $ V.findIndex (yd <) first d = succ yd - V.unsafeIndex first (pred m) +{-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDaysLeap #-} monthDaysLeap :: Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDaysLeap = V.generate 366 go where diff --git a/src/Data/Thyme/Calendar/Julian.hs b/src/Data/Thyme/Calendar/Julian.hs new file mode 100644 --- /dev/null +++ b/src/Data/Thyme/Calendar/Julian.hs @@ -0,0 +1,88 @@ +{-# 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/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,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} @@ -17,6 +18,7 @@ import Data.Thyme.Calendar import Data.Thyme.Calendar.Internal import Data.Thyme.TH +import GHC.Generics (Generic) import System.Random import Test.QuickCheck @@ -49,7 +51,7 @@ toWeekday day@(view ordinalDate -> ord) = WeekdayOfMonth y m n wd where YearMonthDay y m d = ord ^. yearMonthDay WeekDate _ _ wd = toWeekOrdinal ord day - n = div (d - 1) 7 + n = 1 + div (d - 1) 7 {-# INLINEABLE fromWeekday #-} fromWeekday :: WeekdayOfMonth -> Day @@ -76,4 +78,3 @@ -- * Lenses thymeLenses ''WeekdayOfMonth - 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,4 +1,11 @@ --- | 'Num', 'Real', 'Fractional' and 'RealFrac' instances for 'DiffTime' and +-- | Types and functions for +-- and +-- . +-- +-- If you don't care about leap seconds, keep to 'UTCTime' and +-- 'NominalDiffTime' for your clock calculations, and you'll be fine. +-- +-- 'Num', 'Real', 'Fractional' and 'RealFrac' instances for 'DiffTime' and -- 'NominalDiffTime' are only available by importing "Data.Thyme.Time". In -- their stead are instances of 'Data.AdditiveGroup.AdditiveGroup', -- 'Data.Basis.HasBasis' and 'Data.VectorSpace.VectorSpace', with @@ -43,6 +50,7 @@ import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX +-- | Get the current UTC time from the system clock. getCurrentTime :: IO UTCTime getCurrentTime = fmap (review posixTime) getPOSIXTime 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -- workaround {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} @@ -23,6 +24,7 @@ import Data.Micro import Data.Thyme.Calendar.Internal import Data.VectorSpace +import GHC.Generics (Generic) import System.Random import Test.QuickCheck @@ -33,22 +35,23 @@ import Text.Read (readPrec) #endif --- | Time differences, encompassing both 'DiffTime' and 'NominalDiffTime'. +-- | Time intervals, encompassing both 'DiffTime' and 'NominalDiffTime'. -- --- FIXME: still affected by ? +-- [@Issues@] 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. +-- | Convert a time interval to some 'Fractional' type. {-# INLINE toSeconds #-} toSeconds :: (TimeDiff t, Fractional n) => t -> n toSeconds = (* recip 1000000) . fromIntegral . view microseconds --- | Make a time difference from some 'Real' type. +-- | Make a time interval from some 'Real' type. -- --- Where speed is a concern, make sure @n@ is one of 'Float', 'Double', --- 'Int', 'Int64' or 'Integer', for which @RULES@ have been provided. +-- [@Performance@] Try to make sure @n@ is one of 'Float', 'Double', 'Int', +-- 'Int64' or 'Integer', for which rewrite @RULES@ have been provided. {-# INLINE fromSeconds #-} fromSeconds :: (Real n, TimeDiff t) => n -> t fromSeconds = fromSeconds' . toRational @@ -84,6 +87,15 @@ ------------------------------------------------------------------------ +-- | An absolute time interval as measured by a clock. +-- +-- 'DiffTime' forms an 'AdditiveGroup'―so can be added using '^+^' (or '^-^' +-- for subtraction), and also an instance of 'VectorSpace'―so can be scaled +-- using '*^', where +-- +-- @ +-- type 'Scalar' 'DiffTime' = 'Rational' +-- @ newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) #if SHOW_INTERNAL @@ -118,6 +130,20 @@ ------------------------------------------------------------------------ +-- | A time interval as measured by UTC, that does not take leap-seconds +-- into account. +-- +-- For instance, the difference between @23:59:59@ and @00:00:01@ on the +-- following day is always 2 seconds of 'NominalDiffTime', regardless of +-- whether a leap-second took place. +-- +-- 'NominalDiffTime' forms an 'AdditiveGroup'―so can be added using '^+^' +-- (or '^-^' for subtraction), and also an instance of 'VectorSpace'―so can +-- be scaled using '*^', where +-- +-- @ +-- type 'Scalar' 'NominalDiffTime' = 'Rational' +-- @ newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup) #if SHOW_INTERNAL @@ -150,15 +176,26 @@ {-# INLINE microseconds #-} microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro) +-- | The nominal length of a POSIX day: precisely 86400 SI seconds. {-# INLINE posixDayLength #-} posixDayLength :: NominalDiffTime posixDayLength = microseconds # 86400000000 ------------------------------------------------------------------------ --- Represented as a 'NominalDiffTime' since MJD epoch. +-- | The principal form of universal time, namely +-- . +-- +-- 'UniversalTime' is defined by the rotation of the Earth around its axis +-- relative to the Sun. Thus the length of a day by this definition varies +-- from one to the next, and is never exactly 86400 SI seconds unlike +-- or +-- 'AbsoluteTime'. The difference between UT1 and UTC is +-- . newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO) +-- | View 'UniversalTime' as a fractional number of days since the +-- . {-# INLINE modJulianDate #-} modJulianDate :: Iso' UniversalTime Rational modJulianDate = iso @@ -167,9 +204,29 @@ ------------------------------------------------------------------------ --- Represented as a 'NominalDiffTime' since MJD epoch. +-- | : +-- the most common form of universal time for civil timekeeping. It is +-- synchronised with 'AbsoluteTime' and both tick in increments of SI +-- seconds, but UTC includes occasional leap-seconds so that it does not +-- drift too far from 'UniversalTime'. +-- +-- 'UTCTime' is an instance of 'AffineSpace', with +-- +-- @ +-- type 'Diff' 'UTCTime' = 'NominalDiffTime' +-- @ +-- +-- Use '.+^' to add (or '.-^' to subtract) time intervals of type +-- 'NominalDiffTime', and '.-.' to get the interval between 'UTCTime's. +-- +-- [@Performance@] Internally this is a 64-bit count of 'microseconds' since +-- the MJD epoch, so '.+^', '.-^' and '.-.' ought to be fairly fast. +-- +-- [@Issues@] 'UTCTime' currently +-- . newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO) +-- | Unpacked 'UTCTime', partly for compatibility with @time@. data UTCView = UTCTime { utctDay :: {-# UNPACK #-}!Day , utctDayTime :: {-# UNPACK #-}!DiffTime @@ -177,9 +234,11 @@ instance NFData UTCView +-- | 'Lens'' for the 'Day' component of an 'UTCTime'. _utctDay :: Lens' UTCTime Day _utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t) +-- | 'Lens'' for the time-of-day component of an 'UTCTime'. _utctDayTime :: Lens' UTCTime DiffTime _utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t) @@ -190,6 +249,12 @@ {-# INLINE (.+^) #-} UTCRep a .+^ d = UTCRep (a ^+^ d) +-- | View 'UTCTime' as an 'UTCView', comprising a 'Day' along with +-- a 'DiffTime' offset since midnight. +-- +-- This is an improper lens: 'utctDayTime' offsets outside the range of +-- @['zeroV', 'posixDayLength')@ will carry over into the day part, with the +-- expected behaviour. {-# INLINE utcTime #-} utcTime :: Iso' UTCTime UTCView utcTime = iso toView fromView where 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -41,6 +42,7 @@ import Data.Thyme.Format.Internal import Data.Thyme.LocalTime import Data.VectorSpace +import GHC.Generics (Generic) import System.Locale import System.Random (Random) import Test.QuickCheck 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 @@ -37,6 +37,7 @@ humanTimeDiff d = humanTimeDiffs d "" -- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form. +{-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-} humanTimeDiffs :: (TimeDiff d) => d -> ShowS humanTimeDiffs td = (if signed < 0 then (:) '-' else id) . diff where signed@(Micro . abs -> us) = td ^. microseconds diff --git a/src/Data/Thyme/Format/Internal.hs b/src/Data/Thyme/Format/Internal.hs --- a/src/Data/Thyme/Format/Internal.hs +++ b/src/Data/Thyme/Format/Internal.hs @@ -41,6 +41,7 @@ shows02 :: Int -> ShowS shows02 n = if n < 10 then (:) '0' . shows n else shows n +{-# ANN shows_2 "HLint: ignore Use camelCase" #-} {-# INLINE shows_2 #-} shows_2 :: Int -> ShowS shows_2 n = if n < 10 then (:) ' ' . shows n else shows n 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -27,6 +28,7 @@ #endif import Data.Thyme.LocalTime.TimeZone import Data.VectorSpace +import GHC.Generics (Generic) import System.Random import Test.QuickCheck diff --git a/tests/bench.hs b/tests/bench.hs --- a/tests/bench.hs +++ b/tests/bench.hs @@ -28,6 +28,7 @@ import Common +{-# ANN main "HLint: ignore Use list literal" #-} main :: IO () main = do utcs <- unGen (vectorOf samples arbitrary) <$> newStdGen <*> pure 0 diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,20 @@ +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Exit + +main :: IO () +main = (`unless` exitFailure) . null =<< hlint + [ "src", "tests" + , "--cpp-define=HLINT" + , "--cpp-include=include" + , "--cpp-define=SHOW_INTERNAL=1" + , "-XNoUnboxedTuples" + , "-i", "Unused LANGUAGE pragma" + , "-i", "Reduce duplication" + , "-i", "Redundant lambda" + , "-i", "Use if" + , "-i", "Use import/export shortcut" + ] + diff --git a/tests/rewrite.hs b/tests/rewrite.hs --- a/tests/rewrite.hs +++ b/tests/rewrite.hs @@ -31,6 +31,8 @@ [ "build", "--ghc-option=-ddump-rule-firings" ] useless +{-# ANN hook ("HLint: ignore Evaluate" :: String) #-} +{-# ANN hook ("HLint: ignore Use if" :: String) #-} hook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () hook pd lbi uh bf = do -- more reliable way to force a rebuild? diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -58,6 +58,7 @@ ------------------------------------------------------------------------ +{-# ANN main "HLint: ignore Use list literal" #-} main :: IO () main = (exit . all isSuccess <=< sequence) $ quickCheckResult (prop_ShowRead :: Day -> Bool) : diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,5 +1,5 @@ name: thyme -version: 0.3.0.1 +version: 0.3.0.2 synopsis: A faster time library description: Thyme is a rewrite of the fine @time@ library, with a particular focus @@ -28,6 +28,11 @@ default: True manual: True +flag HLint + description: include HLint as a Cabal test-suite + default: False + manual: True + flag show-internal description: instance Show of internal representation default: False @@ -44,6 +49,7 @@ exposed-modules: Data.Thyme Data.Thyme.Calendar + Data.Thyme.Calendar.Julian Data.Thyme.Calendar.MonthDay Data.Thyme.Calendar.OrdinalDate Data.Thyme.Calendar.WeekDate @@ -80,6 +86,8 @@ transformers, vector >= 0.9, vector-space >= 0.8 + if impl(ghc < 7.6.1) + build-depends: ghc-prim ghc-options: -Wall if flag(bug-for-bug) cpp-options: -DBUG_FOR_BUG=1 @@ -121,6 +129,16 @@ text, thyme ghc-options: -Wall + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: tests + if flag(HLint) + build-depends: base, hlint >= 1.8.53 + else + buildable: False benchmark bench type: exitcode-stdio-1.0