|
| 1 | +-- From ./hackage-roundtrip-work/ghcjs-promise-0.1.0.3/src/Data/JSVal/Promise.hs |
| 2 | +{-# LANGUAGE JavaScriptFFI |
| 3 | + , OverloadedStrings |
| 4 | + #-} |
| 5 | + |
| 6 | +{-| |
| 7 | +
|
| 8 | +Module : Data.JSVal.Promise |
| 9 | +Copyright : (c) Alejandro Durán Pallarés, 2016 |
| 10 | +License : BSD3 |
| 11 | +Maintainer : vwwv@correo.ugr.es |
| 12 | +Stability : experimental |
| 13 | +
|
| 14 | +
|
| 15 | +Data.JSVal.Promise defines `Promise`, a direct bind to javascript promise objects. |
| 16 | +
|
| 17 | +- You can import/export them from javascript code using its `FromJSVal` and `ToJSVal` instances. |
| 18 | +
|
| 19 | +- You can extract its value, blocking till computation has finished, using `await`. (you can safely call |
| 20 | + it several time from different threads, the associated computation will run once, and then memorized) |
| 21 | +
|
| 22 | +- You can create new promise (to possible use js side) containing arbitrary haskell code using `promise`. |
| 23 | +
|
| 24 | +For some usage example, checkout this [blog entry](http://the.spaghetticodeball.xyz/haskell/javascript/2016/10/10/new-library-ghcjs-promise.html). |
| 25 | +
|
| 26 | +-} |
| 27 | + |
| 28 | + |
| 29 | +module Data.JSVal.Promise( Promise() |
| 30 | + , await |
| 31 | + , promise |
| 32 | + ) where |
| 33 | + |
| 34 | +import GHCJS.Marshal |
| 35 | +import GHCJS.Types |
| 36 | +import GHCJS.Foreign |
| 37 | +import Control.Exception |
| 38 | +import Control.Concurrent |
| 39 | + |
| 40 | + |
| 41 | +newtype Promise = Promise {fromPromise :: JSVal} |
| 42 | + |
| 43 | +instance FromJSVal Promise where |
| 44 | + fromJSVal x = do is_promise <- js_check_if_promise x |
| 45 | + if is_promise |
| 46 | + then return . Just $ Promise x |
| 47 | + else return Nothing |
| 48 | + |
| 49 | +instance ToJSVal Promise where |
| 50 | + toJSVal = return . fromPromise |
| 51 | + |
| 52 | +-- | If the promise is return through "then", it will return `Right`; |
| 53 | +-- if it return through "catch", then it will return `Left` |
| 54 | +await :: Promise -> IO (Either JSVal JSVal) |
| 55 | +await (Promise jsval) = do result <- js_await jsval |
| 56 | + x <- js_attribute "result" result |
| 57 | + ok <- isTruthy <$> js_attribute "ok" result |
| 58 | + if ok |
| 59 | + then return (Right x) |
| 60 | + else return (Left x) |
| 61 | + |
| 62 | +-- | A `Right` value will be sent as a normal value through "then", a left |
| 63 | +-- value will be sent through "catch" (by javascript convention, representing |
| 64 | +-- an exception). |
| 65 | +-- |
| 66 | +-- The block will start executing immediately, no mater if there's something waiting |
| 67 | +-- for it or not. |
| 68 | +-- |
| 69 | +-- If the execution block launches an exception, then the promise will be receive |
| 70 | +-- as "reject", the javascript value "new Error('Haskell side error')" |
| 71 | +promise :: IO (Either JSVal JSVal) -> IO Promise |
| 72 | +promise action = do ref <- js_book_promise |
| 73 | + promise <- js_set_promise ref |
| 74 | + myid <- myThreadId |
| 75 | + forkIO $ do val_ <- try action |
| 76 | + case val_ of |
| 77 | + |
| 78 | + Right (Right x) -> js_do_resolve ref x |
| 79 | + |
| 80 | + Right (Left x) -> js_do_reject ref x |
| 81 | + |
| 82 | + Left exc -> do throwTo myid (exc::SomeException) |
| 83 | + js_do_reject ref =<< create_error |
| 84 | + return $ Promise promise |
| 85 | +----------------------------------------------------------------------- |
| 86 | +----------------------------------------------------------------------- |
| 87 | + |
| 88 | + |
| 89 | +-- This works because the [algorithm](http://www.ecma-international.org/ecma-262/6.0/#sec-promise.resolve) |
| 90 | +-- explicitly demands that Promise.resolve must return the exact object passed in if and only if |
| 91 | +-- it is a promise by the definition of the spec. |
| 92 | +-- (from stackoverflow http://stackoverflow.com/questions/27746304/how-do-i-tell-if-an-object-is-a-promise) |
| 93 | +foreign import javascript safe |
| 94 | + "Promise.resolve($1) == $1" |
| 95 | + js_check_if_promise :: JSVal -> IO Bool |
| 96 | + |
| 97 | +foreign import javascript safe |
| 98 | + "$2[$1]" |
| 99 | + js_attribute :: JSString -> JSVal -> IO JSVal |
| 100 | + |
| 101 | +foreign import javascript safe |
| 102 | + "new Error('Haskell side error')" |
| 103 | + create_error :: IO JSVal |
| 104 | + |
| 105 | + |
| 106 | +foreign import javascript safe |
| 107 | + "__js_book_promise()" |
| 108 | + js_book_promise :: IO JSVal |
| 109 | + |
| 110 | +foreign import javascript safe |
| 111 | + "__js_set_promise($1)" |
| 112 | + js_set_promise :: JSVal -> IO JSVal |
| 113 | + |
| 114 | +foreign import javascript safe |
| 115 | + "__js_do_reject($1,$2);" |
| 116 | + js_do_reject :: JSVal -> JSVal -> IO () |
| 117 | + |
| 118 | +foreign import javascript safe |
| 119 | + "__js_do_resolve($1, $2);" |
| 120 | + js_do_resolve :: JSVal -> JSVal -> IO () |
| 121 | + |
| 122 | +foreign import javascript interruptible |
| 123 | + "__js_await($1,$c);" |
| 124 | + js_await :: JSVal -> IO JSVal |
| 125 | + |
0 commit comments