Sleep on Haste Haskell by Operational Monad

sleepable.hs

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}

import Haste
import Haste.Foreign
import Control.Monad.Operational
import Control.Monad.IO.Class
import Control.Applicative

data SleepableIOF a where
  Sleep :: Int -> SleepableIOF ()
  LiftIO :: IO x -> SleepableIOF x

newtype SleepableIO a = SleepableIO { unSleepableIO :: Program SleepableIOF a } deriving (Monad, Applicative, Functor)

instance MonadIO SleepableIO where
  liftIO = SleepableIO . singleton . LiftIO

sleep :: Int -> SleepableIO ()
sleep = SleepableIO . singleton . Sleep

runSleepableIO :: SleepableIO () -> IO ()
runSleepableIO (SleepableIO (Program (Pure ()))) = return ()
runSleepableIO (SleepableIO (Program (Free (CoYoneda k (Sleep n))))) = setTimeout n (runSleepableIO (SleepableIO $ Program $ k ()))
runSleepableIO (SleepableIO (Program (Free (CoYoneda k (LiftIO act))))) = act >>= (runSleepableIO . SleepableIO . Program . k)

main :: IO ()
main = runSleepableIO $ do
  t <- liftIO $ ffi $ toJSString "Date.now"
  sleep 1000
  text <- liftIO $ do
    alert "hay"
    return "Yo"
  t' <- liftIO $ ffi $ toJSString "Date.now"
  sleep $ t' - t
  alert $ (show $ t' - t) ++ ": " ++ text