data-effects 0.1.0.0 → 0.1.1.0

raw patch · 5 files changed

+102/−3 lines, 5 filesdep +lensdep +textdep +timedep ~data-effects-thPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lens, text, time

Dependency ranges changed: data-effects-th

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +1/−1
• data-effects.cabal +6/−2
• src/Data/Effect/Concurrent/Timer.hs +67/−0
• src/Data/Effect/Except.hs +24/−0

@@ -1,1 +1,5 @@ # Revision history for data-effects++## 0.1.1.0 -- 2024-09-01+* Added 'Timer' effects.+* Added convenience functions for error handling with the Except effect.

@@ -11,7 +11,7 @@ the [Heftia](https://github.com/sayo-hs/heftia) extensible effects library.  ## Your contributions are welcome!-Please see [CONTRIBUTING.md](CONTRIBUTING.md).+Please see [CONTRIBUTING.md](https://github.com/sayo-hs/data-effects/blob/ef706ef3fa547de01ce6bb5636af911354e53b58/CONTRIBUTING.md).  ## Credits Parts of this project have been adapted or inspired by the following resources:

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               data-effects-version:            0.1.0.0+version:            0.1.1.0  -- A short (one-line) description of the package. synopsis: A basic framework for effect systems based on effects represented by GADTs.@@ -60,6 +60,7 @@         Data.Effect.Resource         Data.Effect.Fresh         Data.Effect.Concurrent.Thread+        Data.Effect.Concurrent.Timer         Data.Effect.Unlift         Data.Effect.ShiftReset         Data.Effect.KVStore@@ -86,9 +87,12 @@     build-depends:         base                        ^>= 4.16.4.0,         data-effects-core           ^>= 0.1,-        data-effects-th             ^>= 0.1,+        data-effects-th             ^>= 0.1.1,         these                       ^>= 1.2,         data-default                ^>= 0.7.1,+        text                        ^>= 1.2.5,+        lens                        ^>= 5.2.3,+        time                        ^>= 1.11.1,      hs-source-dirs:   src     ghc-options:      -Wall

@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+Copyright   :  (c) 2024 Yamada Ryo+License     :  MPL-2.0 (see the file LICENSE)+Maintainer  :  ymdfield@outlook.jp+Stability   :  experimental+Portability :  portable+-}+module Data.Effect.Concurrent.Timer where++import Control.Monad (when)+import Data.Effect.Coroutine (Yield, yield)+import Data.Function (fix)+import Data.Functor ((<&>))+import Data.Time (DiffTime)++data Timer a where+    Clock :: Timer DiffTime+    Sleep :: DiffTime -> Timer ()+makeEffectF [''Timer]++withElapsedTime :: (Timer <: m, Monad m) => (m DiffTime -> m a) -> m a+withElapsedTime f = do+    start <- clock+    f $ clock <&> (`subtract` start)++measureTime :: (Timer <: m, Monad m) => m a -> m (DiffTime, a)+measureTime m = withElapsedTime \elapsedTime -> do+    r <- m+    elapsedTime <&> (,r)++sleepUntil :: (Timer <: m, Monad m) => DiffTime -> m (Maybe DiffTime)+sleepUntil t = do+    now <- clock+    when (t > now) do+        sleep $ t - now+    pure if t < now then Just (now - t) else Nothing++runCyclic :: (Timer <: m, Monad m) => m DiffTime -> m () -> m a+runCyclic deltaTime a = do+    t0 <- clock+    flip fix t0 \next t -> do+        t' <- (t +) <$> deltaTime+        a+        delay <- sleepUntil t'+        next $ maybe t' (t' +) delay++runPeriodic :: (Timer <: m, Monad m) => DiffTime -> m () -> m a+runPeriodic interval = runCyclic (pure interval)+{-# INLINE runPeriodic #-}++periodicTimer :: forall m a. (Timer <: m, Yield () () <: m, Monad m) => DiffTime -> m a+periodicTimer interval = runPeriodic interval $ yield ()+{-# INLINE periodicTimer #-}++cyclicTimer :: forall m a. (Timer <: m, Yield () DiffTime <: m, Monad m) => m a+cyclicTimer = runCyclic (yield ()) (pure ())+{-# INLINE cyclicTimer #-}++data CyclicTimer a where+    Wait :: DiffTime -> CyclicTimer ()+makeEffectF [''CyclicTimer]

@@ -20,3 +20,27 @@     Catch :: f a -> (e -> f a) -> Catch e f a  makeEffect [''Throw] [''Catch]++liftEither :: (Throw e <: f, Applicative f) => Either e a -> f a+liftEither = either throw pure+{-# INLINE liftEither #-}++joinEither :: (Throw e <: m, Monad m) => m (Either e a) -> m a+joinEither = (>>= either throw pure)+{-# INLINE joinEither #-}++joinExcept :: Monad m => Either (m a) a -> m a+joinExcept = either id pure+{-# INLINE joinExcept #-}++exc :: Monad m => m (Either (m a) a) -> m a+exc = (>>= either id pure)+{-# INLINE exc #-}++withExcept :: (Catch e <<: f, Throw e <: f, Applicative f) => f a -> (e -> f ()) -> f a+withExcept thing after = thing `catch` \e -> after e *> throw e+{-# INLINE withExcept #-}++onExcept :: forall e f a. (Catch e <<: f, Throw e <: f, Applicative f) => f a -> f () -> f a+onExcept thing after = thing `withExcept` \(_ :: e) -> after+{-# INLINE onExcept #-}