Synchronous setTimeout with Purescript and the ContT monad

settimeout.purs

module Main where

import Data.Function
import Debug.Trace
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Control.Monad.Eff

foreign import data Timeout :: !
type Milliseconds = Number
type TOF eff = Eff (timeout :: Timeout | eff)

foreign import setTimeoutImpl
  """function setTimeoutImpl(ms, f) {
    return function() {
      setTimeout(f, ms);
      return {};
    };
  }""" :: forall eff. Fn2 Milliseconds (TOF eff Unit) (TOF eff Unit)

setTimeoutCont :: forall eff. Milliseconds -> ContT Unit (TOF eff) Unit
setTimeoutCont ms = ContT $ \k -> (runFn2 setTimeoutImpl) ms (k unit)

demo :: forall eff. ContT Unit (Eff (timeout :: Timeout, trace :: Trace | eff)) Unit
demo = do
  lprint "Do"
  stc 500
  lprint "you"
  stc 500
  lprint "really"
  stc 500
  lprint "wanna"
  stc 500
  lprint "huuuurt me?"
  stc 1000
  lprint "Do"
  stc 500
  lprint "you"
  stc 500
  lprint "really"
  stc 500
  lprint "wanna"
  stc 500
  lprint "maaaake me cry?"
    where
      lprint = lift <<< print
      stc = setTimeoutCont

main = runContT demo (\ _ -> return unit)