Surface Syntax.hs

{-# LANGUAGE RecordWildCards #-}

module Promise where

import Control.Monad
import Data.IORef
import Data.Maybe

data Status
    = Pending
    | Accepted
    | Rejected

data Promise result err = Promise
    { pValue           :: IORef (Maybe (Either err result))
    , pAcceptCallbacks :: IORef [result -> IO ()]
    , pRejectCallbacks :: IORef [err -> IO ()]
    }

data Resolver result err = Resolver (Promise result err)

data PromiseResult result err
    = Success result
    | Failure err
    | Chain (Promise result err)

getStatus(promise) = do {
    value <- promise.~>pValue;
    case value of
        Nothing -> do {
            return(Pending);
        }
        Just(Left(err)) -> do {
            return(Rejected);
        }
        Just(Right(result)) -> do {
            return(Accepted);
        }
}

scheduleCallbacks(promise) = do {
    value <- promise.~>pValue;
    case value of
        Just(Left(err)) -> do {
            processCallbacks(promise~>pRejectCallbacks, err);
        }
        Just(Right(result)) -> do {
            processCallbacks(promise~>pAcceptCallbacks, result);
        }
        def -> do {
            return ();
        }
}

processCallbacks(cbRef, arg) = do {
    cbs <- readIORef(cbRef);
    cbRef .= [];
    forM_ cbs $ \cb -> do {
        cb(arg);
    }
}

accept(resolver, result) = do {
    let Resolver promise = resolver
    ; 
    v <- promise.~>pValue;
    when (not(isJust(v))) $ do {
        promise~>pValue .= Just(Right(result));
        promise~>pRejectCallbacks .= [];
        scheduleCallbacks(promise);
    }
}

reject(resolver, err) = do {
    let Resolver promise = resolver
    ;
    v <- promise.~>pValue;
    when (not(isJust(v))) $ do {
        promise~>pValue .= Just(Left(err));
        promise~>pAcceptCallbacks .= [];
        scheduleCallbacks(promise);
    }
}

resolve(resolver, promise) = do {
    let adaptAccept(r) = do {
            accept(resolver, r);
            return (Success(r));
        }
    ;
    let adaptReject(r) = do {
            reject(resolver, r);
            return (Failure(r));
        }
    ;

    then_(promise, adaptAccept, adaptReject);
    return ();
}

newPromise(init) = do {
    pValue           <- newIORef(Nothing);
    pAcceptCallbacks <- newIORef([]);
    pRejectCallbacks <- newIORef([]);
    let promise = Promise{..}
    ;
    init(Resolver(promise));
    return promise;
}

acceptedPromise(result) = do {
    let resolveProc(resolver) = accept(resolver, result)
    ;
    newPromise(resolveProc);
}

rejectedPromise(err) = do {
    let rejectProc(resolver) = reject(resolver, err)
    ;
    newPromise(rejectProc);
}

wrap(resolver, cb, arg) = do {
    value <- cb(arg);
    case value of
        Success s -> do {
            accept(resolver, s);
        }
        Failure e -> do {
            reject(resolver, e);
        }
        Chain pr -> do {
            resolve(resolver, pr);
        }
}

then_(promise, acceptCb, rejectCb) = do {
    newPromise $ \resolver -> do {
        let wrappedAccept(arg) = wrap(resolver, acceptCb, arg)
        ;
        let wrappedReject(arg) = wrap(resolver, rejectCb, arg)
        ;

        prepend(promise~>pAcceptCallbacks, wrappedAccept);
        prepend(promise~>pRejectCallbacks, wrappedReject);

        value <- promise.~>pValue;
        when(isJust(value)) $ do {
            scheduleCallbacks(promise);
        }
    }
}

then2(promise, acceptCb) = do {
    let resolveProc(resolver) = do {
        let wrappedAccept(arg) = wrap(resolver, acceptCb, arg)
        ;
        let wrappedReject(err) = reject(resolver, err)
        ;

        prepend(promise~>pAcceptCallbacks, wrappedAccept);
        prepend(promise~>pRejectCallbacks, wrappedReject);

        value <- promise.~>pValue;
        when(isJust(value)) $ do {
            scheduleCallbacks(promise);
        }
    }
    ;
    newPromise(resolveProc);
}

catch(promise, rejectCb) = do {
    let resolveProc(resolver) = do {
        let wrappedAccept(arg) = accept(resolver, arg)
        ;
        let wrappedReject(err) = wrap(resolver, rejectCb, err)
        ;

        prepend(promise~>pAcceptCallbacks, wrappedAccept);
        prepend(promise~>pRejectCallbacks, wrappedReject);

        value <- promise.~>pValue;
        when(isJust(value)) $ do {
            scheduleCallbacks(promise);
        }
    }
    ;
    newPromise(resolveProc);
}

(~>) = flip ($)
a.~>b = readIORef (b a)
(.=) = writeIORef

prepend(ior, e) = modifyIORef ior (e:)