non-negative-time-diff (empty) → 0.0.1
raw patch · 4 files changed
+273/−0 lines, 4 filesdep +aesondep +basedep +deepseq
Dependencies added: aeson, base, deepseq, directory, ghc-typelits-natnormalise, mtl, safecopy, time
Files
- LICENSE +32/−0
- changelog.md +4/−0
- non-negative-time-diff.cabal +141/−0
- src/Data/Time/Clock/NonNegativeTimeDiff.hs +96/−0
+ LICENSE view
@@ -0,0 +1,32 @@+This module is under this "3 clause" BSD license:++Copyright (c) 2025-2025, Daniil Iaitskov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of the contributors may not be used to endorse or+ promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ changelog.md view
@@ -0,0 +1,4 @@+# non-negative-time-diff changelog++## Version 0.0.1 2026-02-26+ * init
+ non-negative-time-diff.cabal view
@@ -0,0 +1,141 @@+cabal-version: 3.0+name: non-negative-time-diff+version: 0.0.1++synopsis: type safe diffUTCTime+description:+ Both arguments of @diffUTCTime@ function from @time@ package have the+ same type. It is easy to mix them.+ + > f = do+ > started <- getCurrentTime+ > threadDelay 10_000_000+ > ended <- getCurrentTime+ > pure $ started `diffUTCTime` ended+ + This package provides a stricter @diffUTCTime@ that significantly+ reduces possibility of mixing its arguments by an accident.+ + > import Data.Time.Clock.NonNegativeTimeDiff+ > f = do+ > started <- getCurrentTime+ > threadDelay 10_000_000+ > ended <- getTimeAfter started+ > pure $ ended `diffUTCTime` started+ + == STM use case+ #stm-use-case#+ + The STM package is shipped without a function to get current time. Let’s+ consider a situtation like this:+ + > data Ctx+ > = Ctx { m :: Map Int UTCTime+ > , s :: TVar NominalDiffTime+ > , q :: TQueue Int+ > }+ >+ > f (c :: Ctx) = do+ > now <- getCurrentTime+ > atomically $ do+ > i <- readTQueue q+ > lookup i c.m >>= \case+ > Nothing -> pure ()+ > Just t -> modifyTVar' c.s (+ diffUTCTime now t)+ + @now@ might be less than @t@ because the queue might be empty by the+ time @f@ is invoked. The package API can correct the above snippet as+ follows:+ + > data Ctx+ > = Ctx { m :: Map Int UtcBox+ > , s :: TVar NominalDiffTime+ > , q :: TQueue Int+ > }+ >+ > f (c :: Ctx) = do+ > atomically $ do+ > i <- readTQueue q+ > lookup i c.m >>= \case+ > Nothing -> pure ()+ > Just t ->+ > doAfter tb \t -> do+ > now <- getTimeAfter t+ > modifyTVar' c.s (+ diffUTCTime now t)+ + == File access time+ #file-access-time#+ + Another popular usecase where original @diffUTCTime@ might be misused.+ + > isFileOlderThan :: FilePath -> NominalDiffTime -> IO Bool+ > isFileOlderThan fp maxAge = do+ > now <- getCurrentTime+ > mt <- getModificationTime fp+ > when (mt `diffUTCTime` now > maxAge) $ do+ > removeFile fp+ + File age is always negative in the above example - this eventually would+ cause a space leak on disk.+ + Corrected version:+ + > isFileOlderThan :: FilePath -> NominalDiffTime -> IO Bool+ > isFileOlderThan fp maxAge =+ > getModificationTime fp >>= (`doAfter` \mt -> do+ > now <- getTimeAfter mt+ > when (now `diffUTCTime` mt > maxAge) $ do+ > removeFile fp)+ + == Requirements+ #requirements#+ + Unboxing @UtcBox@ values requires a GHC+ <https://hackage.haskell.org/package/ghc-typelits-natnormalise natnormalise plugin>:+ + > {-# GHC_OPTIONS -fplugin GHC.TypeLits.Normalise #-}+homepage: http://github.com/yaitskov/non-negative-time-diff+license: BSD-3-Clause+license-file: LICENSE+author: Daniil Iaitskov+maintainer: dyaitskov@gmail.com+copyright: Daniil Iaitkov 2026+category: System+build-type: Simple+bug-reports: https://github.com/yaitskov/non-negative-time-diff/issues++extra-doc-files:+ changelog.md+tested-with:+ GHC == 9.12.2++source-repository head+ type:+ git+ location:+ https://github.com/yaitskov/non-negative-time-diff.git++common base+ default-language: GHC2024+ ghc-options: -Wall -fplugin GHC.TypeLits.Normalise+ default-extensions:+ DefaultSignatures+ NoImplicitPrelude+ TypeFamilies+ ViewPatterns+ build-depends:+ , base >=4.7 && < 5++library+ import: base+ hs-source-dirs: src+ exposed-modules:+ Data.Time.Clock.NonNegativeTimeDiff+ build-depends:+ , aeson < 3+ , deepseq < 2+ , directory < 2+ , ghc-typelits-natnormalise < 1+ , mtl < 3+ , safecopy < 1+ , time < 2
+ src/Data/Time/Clock/NonNegativeTimeDiff.hs view
@@ -0,0 +1,96 @@+module Data.Time.Clock.NonNegativeTimeDiff+ ( UtcBox+ , UTCTime+ , mkUtcBox+ , ClockMonad (..)+ , diffUTCTime+ , doAfter+ , toNominalDiffTime+ , NominalDiffTime+ , getModificationTime+ ) where++import Control.DeepSeq ( NFData(..) )+import Control.Monad.Trans ( MonadIO(liftIO), MonadTrans(..) )+import Data.Aeson ( FromJSON(parseJSON), ToJSON(toJSON) )+import Data.Coerce ( coerce )+import Data.Time.Clock qualified as C+import Data.SafeCopy+ ( SafeCopy(putCopy, getCopy), contain, safeGet, safePut )+import GHC.Conc ( STM, unsafeIOToSTM )+import GHC.Generics ( Generic )+import GHC.TypeLits ( TypeError, type (+), type (<=?), ErrorMessage(Text), Nat )+import GHC.TypeError ( Assert )+import Prelude+import System.Directory qualified as D++newtype UTCTime (n :: Nat)+ = UTCTime+ { unUTCTime :: C.UTCTime }+ deriving newtype (Show, Eq, Ord, Generic, Read, NFData)++class Monad m => ClockMonad m where+ getCurrentTime :: m (UTCTime 0)+ getTimeAfter :: UTCTime n -> m (UTCTime (n + 1))++data UtcBox = forall n. UtcBox (UTCTime n)++mkUtcBox :: UTCTime n -> UtcBox+mkUtcBox = UtcBox++instance NFData UtcBox where+ rnf (UtcBox u) = rnf u+instance Eq UtcBox where+ (UtcBox (UTCTime a)) == (UtcBox (UTCTime b)) = a == b+instance Ord UtcBox where+ (UtcBox (UTCTime a)) `compare` (UtcBox (UTCTime b)) = a `compare` b+instance Show UtcBox where+ show (UtcBox (UTCTime ut)) = show ut+instance ToJSON UtcBox where+ toJSON (UtcBox u) = toJSON $ unUTCTime u+instance FromJSON UtcBox where+ parseJSON x = UtcBox . UTCTime <$> parseJSON x+instance SafeCopy UtcBox where+ putCopy (UtcBox (UTCTime ut)) = contain $ safePut ut+ getCopy= contain $ UtcBox . UTCTime <$> safeGet++doAfter :: ClockMonad m => UtcBox -> (forall n. (UTCTime n -> m b)) -> m b+doAfter (UtcBox u) m = m u++getModificationTime :: MonadIO m => FilePath -> m UtcBox+getModificationTime fp = UtcBox . UTCTime <$> liftIO (D.getModificationTime fp)++instance ClockMonad IO where+ getCurrentTime = UTCTime <$> liftIO C.getCurrentTime+ getTimeAfter _ = UTCTime <$> liftIO C.getCurrentTime++instance ClockMonad STM where+ getCurrentTime = unsafeIOToSTM getCurrentTime+ getTimeAfter x = unsafeIOToSTM (getTimeAfter x)++instance (ClockMonad m, MonadTrans t) => ClockMonad (t m) where+ getCurrentTime = lift getCurrentTime+ getTimeAfter x = lift $ getTimeAfter x+++newtype NominalDiffTime+ = NominalDiffTime+ { toNominalDiffTime :: C.NominalDiffTime+ } deriving newtype (Show, Eq, Ord, Read, Num, Enum, Fractional, Real, RealFrac, NFData)++diffUTCTime ::+ (Assert (a + 1 <=? b)+ (TypeError (Text "First argument might be less than the second"))) =>+ UTCTime b -> UTCTime a -> NominalDiffTime+diffUTCTime (coerce -> b) (coerce -> a) = NominalDiffTime $ b `C.diffUTCTime` a++_testDiff :: UTCTime 2 -> UTCTime 1 -> NominalDiffTime+_testDiff a b = a `diffUTCTime` b++_testBox :: ClockMonad m => UtcBox -> m NominalDiffTime+_testBox b =+ doAfter b (\sa -> do+ n <- getTimeAfter sa+ m <- getTimeAfter n+ pure $ n `diffUTCTime` sa + m `diffUTCTime` sa + (m `diffUTCTime` n)+ )