Improve printing of pure exceptions #145

The API may be called in ways where pure values
contain exceptions, e.g.

	element div # set UI.text (error “oops”)

This call will be translated into a message for
the JavaScript side. Sending this message will
fail, because it contains a _|_ value.
We now try to force this exception in the
translation phase, because this will result in a
better error message.

samples/TestExceptions.hs

@@ -6,9 +6,17 @@
 import qualified Graphics.UI.Threepenny       as UI
 import           Graphics.UI.Threepenny.Core
 
-main = startGUI defaultConfig $ \w -> do
+main = startGUI defaultConfig { jsWindowReloadOnDisconnect = False } $ \w -> do
     getBody w #+ [UI.h1 # set UI.text "before error"]
-    -- liftIO $ ioError (userError "ouch")
-    runFunction $ ffi "throw('ouch')"
+
+    let err = 1
+    case err of
+            -- FIXME: This function should produce a useful error message
+        1 -> runFunction $ ffi "alert(%1)" (error ("ouch " ++ show err) :: String)
+        2 -> UI.div # set UI.text (error ("ouch " ++ show err) :: String) >> return ()
+        3 -> error $ "ouch " ++ show err
+        4 -> liftIO . ioError . userError $ "ouch " ++ show err
+        5 -> runFunction $ ffi "throw('ouch')"
+
     getBody w #+ [UI.h1 # set UI.text "after error"]
     return ()

src/Foreign/JavaScript/EventLoop.hs

@@ -10,6 +10,7 @@ import           Control.Applicative
 import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM   as STM
+import           Control.DeepSeq                  (deepseq)
 import           Control.Exception        as E
 import           Control.Monad
 import qualified Data.Aeson               as JSON
@@ -67,16 +68,16 @@ eventLoop init comm = void $ do
                 Left  _ -> throwIO $ ErrorCall "Foreign.JavaScript: Browser <-> Server communication broken."
 
     -- FFI calls are made by writing to the `calls` queue.
-    let run msg = do
+    let run  msg = msg `deepseq` do     -- see [ServerMsg strictness]
             atomicallyIfOpen $ writeTQueue calls (Nothing , msg)
-        call msg = do
+        call msg = msg `deepseq` do     -- see [ServerMsg strictness]
             ref <- newEmptyTMVarIO
             atomicallyIfOpen $ writeTQueue calls (Just ref, msg)
             er  <- atomicallyIfOpen $ takeTMVar ref
             case er of
                 Left  e -> E.throwIO $ JavaScriptException e
                 Right x -> return x
-        debug    s = do
+        debug s  = s `deepseq` do       -- see [ServerMsg strictness]
             atomicallyIfOpen $ writeServer comm $ Debug s
 
     -- We also send a separate event when the client disconnects.

src/Foreign/JavaScript/Types.hs

@@ -145,12 +145,21 @@ an exception will be thrown when we try to send one of those to the browser.
 
 However, we have to make sure that the exception is thrown
 in the thread that constructed the message, not in the thread that
-handles the actual communication with the client. That's why we use
-the function `Control.DeepSeq.force` to make sure that any exception
+handles the actual communication with the client.
+
+That's why we have to use the function
+`Control.DeepSeq.deepseq` to make sure that any exception
 is thrown before handing the message over to another thread.
 
+Since exceptions in pure code do not have a precise ordering relative
+to exceptions in IO code, evaluating the pure value
+also helps with ensuring that the exception is raised before
+any subsequent IO exception; this makes it easier to pinpoint
+the root cause for library users.
+
 -}
 
+
 data JavaScriptException = JavaScriptException String deriving Typeable
 
 instance E.Exception JavaScriptException