Higher-order effect of timer for Polysemy

Timer.hs

module Main where

import Data.Time.Clock.POSIX
import Control.Concurrent
import Polysemy
import Polysemy.Final
import Polysemy.Trace
import Polysemy.Error
import Data.Kind
import Polysemy.Final (interpretFinal)

currMs :: Integral b => IO b
currMs = getCurrentTime >>= pure . (1000*) . utcTimeToPOSIXSeconds >>= pure . round

data Timer (m :: Type -> Type) a where
  Time :: m a -> Timer m a

makeSem ''Timer

program :: Members '[Timer, Embed IO] r => Sem r ()
program = do
  -- here embed used for demo purposes
  -- output @String "foo"
  -- ret <- forkWithResults 20 subPrg
  -- subPrg
  time $ do
    subPrg
    time $ subPrg

subPrg :: Member (Embed IO) r  => Sem r ()
subPrg = embed $ threadDelay $ 3 * 10 ^ 6

runTimer :: Member (Embed IO) r => Sem (Timer ': r) a -> Sem r a
runTimer = interpretH $ \case
  Time prg -> do
    -- prepare computations
    (prg') <- (runT) prg
    -- seq
    a1  <- embed currMs
    res <- (raise . runTimer) prg'
    a2  <- embed currMs
    embed $ putStrLn $ show (a2 - a1)
    -- pass over
    pure res

main :: IO ()
main = do
  -- runM $ subPrg
  runM $ runTimer program