Clock.hs

-- | A clock effect for reading the current time and time zone.
--
-- Putting wall-clock reads behind an effect keeps time-dependent code testable:
-- 'runClock' uses the system clock, while 'runClockConst', 'runClockState' and
-- 'runClockList' supply deterministic times for tests.
module Atelier.Effects.Clock
    ( Clock
    , UTCTime
    , TimeZone
    , currentTime
    , currentTimeZone
    , runIO
    , runConst
    , runState
    , runList
    )
where

import Data.Time (UTCTime, getCurrentTime)
import Data.Time.LocalTime (TimeZone, getCurrentTimeZone, utc)
import Effectful (Effect, IOE)
import Effectful.Dispatch.Dynamic (interpret_, reinterpret)
import Effectful.State.Static.Shared (State, evalState, get, put)
import Effectful.TH (makeEffect)


-- | Effect for reading the current time and time zone.
data Clock :: Effect where
    -- | The current wall-clock time, in UTC.
    CurrentTime :: Clock m UTCTime
    -- | The system's current time zone.
    CurrentTimeZone :: Clock m TimeZone


makeEffect ''Clock


-- | Interpret 'Clock' against the real system clock.
runIO :: (IOE :> es) => Eff (Clock : es) a -> Eff es a
runIO = interpret_ $ \case
    CurrentTime -> liftIO getCurrentTime
    CurrentTimeZone -> liftIO getCurrentTimeZone


-- | Interpret 'Clock' so 'currentTime' always returns a fixed time. The time
-- zone is reported as 'utc'.
runConst :: UTCTime -> Eff (Clock : es) a -> Eff es a
runConst time = interpret_ $ \case
    CurrentTime -> pure time
    CurrentTimeZone -> pure utc


-- | Interpret 'Clock' so 'currentTime' reads from a mutable 'State' cell,
-- letting a test advance \"now\" explicitly. The time zone is reported as 'utc'.
runState :: (State UTCTime :> es) => Eff (Clock : es) a -> Eff es a
runState = interpret_ $ \case
    CurrentTime -> get
    CurrentTimeZone -> pure utc


-- | Scripted interpreter for testing: returns times from a pre-loaded list in
-- order. Each 'currentTime' call pops the next item. Crashes if the list is
-- exhausted.
runList :: [UTCTime] -> Eff (Clock : es) a -> Eff es a
runList times = reinterpret (evalState times) $ \_ -> \case
    CurrentTime ->
        get >>= \case
            [] -> error "runClockList: no more times in queue"
            t : ts -> put ts >> pure t
    CurrentTimeZone -> pure utc