Moved back to dynamic dispatch and bench function
This commit is contained in:
parent
d781295480
commit
cc0c6bc1e9
@ -2,8 +2,9 @@ module Effects.Time (
|
||||
currentTime,
|
||||
currentTimeB,
|
||||
currentTimeT,
|
||||
Time,
|
||||
benchFunction,
|
||||
runTimeEff,
|
||||
Time,
|
||||
)
|
||||
where
|
||||
|
||||
@ -12,41 +13,31 @@ import Chronos qualified as C
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy.Builder qualified as T
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.TH
|
||||
|
||||
import Effectful.Dispatch.Static
|
||||
data Time :: Effect where
|
||||
CurrentTime :: Time m C.Time
|
||||
CurrentTimeB :: Time m T.Builder
|
||||
CurrentTimeT :: Time m Text
|
||||
BenchFunction :: m a -> Time m (Timespan, a)
|
||||
|
||||
data Time :: Effect
|
||||
|
||||
type instance DispatchOf Time = 'Static 'WithSideEffects
|
||||
newtype instance StaticRep Time = Time ()
|
||||
|
||||
currentTime ::
|
||||
Time :> es =>
|
||||
Eff es C.Time
|
||||
currentTime = do
|
||||
Time _ <- getStaticRep
|
||||
unsafeEff_ now
|
||||
|
||||
currentTimeB ::
|
||||
Time :> es =>
|
||||
Eff es T.Builder
|
||||
currentTimeB = do
|
||||
Time _ <- getStaticRep
|
||||
unsafeEff_ $
|
||||
builder_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
|
||||
<$> now
|
||||
|
||||
currentTimeT ::
|
||||
Time :> es =>
|
||||
Eff es Text
|
||||
currentTimeT = do
|
||||
Time _ <- getStaticRep
|
||||
unsafeEff_ $
|
||||
encode_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
|
||||
<$> now
|
||||
makeEffect ''Time
|
||||
|
||||
runTimeEff ::
|
||||
IOE :> es =>
|
||||
(IOE :> es) =>
|
||||
Eff (Time : es) a ->
|
||||
Eff es a
|
||||
runTimeEff = evalStaticRep (Time ())
|
||||
runTimeEff = interpret $ \env -> \case
|
||||
CurrentTime -> liftIO now
|
||||
CurrentTimeB ->
|
||||
builder_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
|
||||
<$> liftIO now
|
||||
CurrentTimeT ->
|
||||
encode_YmdHMS (SubsecondPrecisionFixed 4) w3c . timeToDatetime
|
||||
<$> liftIO now
|
||||
BenchFunction f -> do
|
||||
s <- liftIO now
|
||||
!d <- localSeqUnlift env $ \unlift -> unlift f
|
||||
e <- liftIO now
|
||||
pure (C.width $ s ... e, d)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user