Quick & Dirty & Simple promises with Haskell (similar to JavaScript)

code.hs

-- #! /usr/bin/env nix-shell
-- #! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (p: [p.interpolatedstring-perl6 p.regex-tdfa p.dump p.hspec p.shelly])"

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# OPTIONS_GHC -fdefer-type-errors #-}

import Data.IORef
import Data.Maybe

import Test.Hspec
import Control.Concurrent







data Promise a = Promise (IORef (Maybe a)) (IORef [a -> IO ()])
mkPromise f = do
  result <- newIORef Nothing
  listeners <- newIORef []
  let
    fail = error
    pass a = do
      writeIORef result (Just a)
      handlers <- readIORef listeners
      sequence_ $ map ($ a) (reverse handlers)
  f pass fail
  return $ Promise result listeners

when p@(Promise a l) f = do
  readIORef a >>= \case
    Just a -> f a
    Nothing -> do
      modifyIORef l (f :)

isResolved (Promise a _) = do
  val <- readIORef a
  return $ isJust val







main = do
  spec

spec = hspec $ do
  it "isResolved false is handled" $ do
    p <- mkPromise $ \pass fail -> return ()
    isResolved p >>= (`shouldBe` False)

  it "isResolved true is handled" $ do
    p <- mkPromise $ \pass fail -> do
      pass 1

    isResolved p >>= (`shouldBe` True)

  it "should handle values being passed on" $ do
    p <- mkPromise $ \pass fail -> do
      pass 1

    asd <- newIORef 0
    when p (writeIORef asd)
    readIORef asd >>= (`shouldBe` 1)

  it "should only resolve once the pass fn is called" $ do
    passRef <- newIORef Nothing
    p <- mkPromise $ \pass fail -> do
      writeIORef passRef (Just pass)

    asd <- newIORef 0
    when p (writeIORef asd)
    readIORef asd >>= (`shouldBe` 0)
    (Just f) <- readIORef passRef
    f 1
    readIORef asd >>= (`shouldBe` 1)

  it "should handle threads" $ do
    passRef <- newIORef Nothing
    p <- mkPromise $ \pass fail -> do
      forkIO $ do
        threadDelay 1000
        pass 1

    isResolved p >>= (`shouldBe` False)
    threadDelay 1001
    isResolved p >>= (`shouldBe` True)