Add efficient event parsing.

src/Miso/Event.hs

@@ -1,6 +1,9 @@
 -----------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Miso.Event
@@ -40,7 +43,6 @@ module Miso.Event
 -----------------------------------------------------------------------------
 import           Control.Monad (when)
 import qualified Data.Map.Strict as M
-import           Data.Aeson.Types (parseEither)
 import           Language.Javascript.JSaddle
 -----------------------------------------------------------------------------
 import           Miso.Event.Decoder
@@ -100,7 +102,7 @@ onWithOptions
   -> Decoder r
   -> (r -> DOMRef -> action)
   -> Attribute action
-onWithOptions phase options eventName Decoder{..} toAction =
+onWithOptions phase options eventName decoder toAction =
   On $ \sink (VTree n) logLevel events -> do
     when (logLevel == DebugAll || logLevel == DebugEvents) $
       case M.lookup eventName events of
@@ -120,12 +122,9 @@ onWithOptions phase options eventName Decoder{..} toAction =
         BUBBLE -> getProp "bubbles" (Object eventsVal)
     eventHandlerObject@(Object eo) <- create
     jsOptions <- toJSVal options
-    decodeAtVal <- toJSVal decodeAt
     cb <- FFI.syncCallback2 $ \e domRef -> do
-        Just v <- fromJSVal =<< FFI.eventJSON decodeAtVal e
-        case parseEither decoder v of
-          Left msg -> FFI.consoleError ("[EVENT DECODE ERROR]: " <> ms msg)
-          Right event -> sink (toAction event domRef)
+        executeDecoder decoder eventName e $ \r -> 
+          sink (toAction r domRef)
     FFI.set "runEvent" cb eventHandlerObject
     FFI.set "options" jsOptions eventHandlerObject
     FFI.set eventName eo (Object eventObj)

src/Miso/Event/Decoder.hs

@@ -1,7 +1,10 @@
 -----------------------------------------------------------------------------
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Miso.Event.Decoder
@@ -15,6 +18,10 @@ module Miso.Event.Decoder
   ( -- ** Types
     Decoder (..)
   , DecodeTarget (..)
+  , Parser (..)
+  , DecodeFailure (..)
+    -- ** Parser
+  , parseEither
     -- ** Combinators
   , at
     -- ** Decoders
@@ -24,18 +31,27 @@ module Miso.Event.Decoder
   , checkedDecoder
   , valueDecoder
   , pointerDecoder
+    -- ** Utils
+  , withObject
+  , (.:)
+  , (.:?)
+  , (.!=)
+    -- ** Internal
+  , executeDecoder
   ) where
 -----------------------------------------------------------------------------
-import Control.Applicative
-import Data.Aeson.Types
-#ifdef GHCJS_OLD
-import GHCJS.Marshal (ToJSVal(toJSVal))
-#else
-import Language.Javascript.JSaddle (ToJSVal(toJSVal))
-#endif
+import           Data.Maybe
+import           Control.Monad
+import           Control.Monad.IO.Class (MonadIO(..))
+import           Control.Monad.Except
+import           Control.Applicative
+import           Language.Javascript.JSaddle
 -----------------------------------------------------------------------------
-import Miso.Event.Types
-import Miso.String
+import qualified Miso.String as MS
+import           Miso.Event.Types
+import           Miso.String
+import           Miso.FFI (Event (..))
+import qualified Miso.FFI.Internal as FFI
 -----------------------------------------------------------------------------
 -- | Data type representing path (consisting of field names) within event object
 -- where a decoder should be applied.
@@ -47,21 +63,80 @@ data DecodeTarget
 -----------------------------------------------------------------------------
 -- | `ToJSVal` instance for t'DecodeTarget'.
 instance ToJSVal DecodeTarget where
-  toJSVal (DecodeTarget xs) = toJSVal xs
-  toJSVal (DecodeTargets xs) = toJSVal xs
+  toJSVal = \case
+    DecodeTarget xs -> toJSVal xs
+    DecodeTargets xs -> toJSVal xs
 -----------------------------------------------------------------------------
 -- | t'Decoder' data type for parsing events
 data Decoder a
   = Decoder
-  { decoder :: Value -> Parser a
+  { decoder :: Event -> Parser a
     -- ^ FromJSON-based Event decoder
   , decodeAt :: DecodeTarget
     -- ^ Location in DOM of where to decode
   }
 -----------------------------------------------------------------------------
+newtype Parser a = Parser { runParser :: ExceptT [DecodeFailure] JSM a }
+  deriving ( Functor, Applicative, Monad
+           , MonadError [DecodeFailure], Alternative, MonadIO
+#ifndef GHCJS_BOTH
+           , MonadJSM
+#endif
+           )
+-----------------------------------------------------------------------------
+parseEither :: Event -> Decoder a -> JSM (Either [DecodeFailure] a)
+parseEither event Decoder {..} | Parser m <- decoder event = runExceptT m
+-----------------------------------------------------------------------------
+data DecodeFailure
+  = PropertyNotFound MisoString
+  | DecodeFailure MisoString
+-----------------------------------------------------------------------------
 -- | Smart constructor for building a t'Decoder'.
-at :: [MisoString] -> (Value -> Parser a) -> Decoder a
-at decodeAt decoder = Decoder {decodeAt = DecodeTarget decodeAt, ..}
+at :: [MisoString] -> (Event -> Parser a) -> Decoder a
+at decodeAt decoder = Decoder { decodeAt = DecodeTarget decodeAt, .. }
+-----------------------------------------------------------------------------
+-- | Combinator for parsing an t'Event'
+--
+-- Keeps interface at parity with `aeson`.
+--
+withObject :: MisoString -> (Event -> Parser a) -> Event -> Parser a
+withObject _ f x = f x
+-----------------------------------------------------------------------------
+-- | Parser combinator for decoding values out of JSM in t'Parser'
+(.:) :: FromJSVal a => Event -> MisoString -> Parser a
+(.:) (Event event) key = do
+  result <- liftJSM $ do
+    result <- unsafeGetProp key (Object event)
+    maybeNullOrUndefined result
+  case result of
+    Nothing -> do
+      throwError [PropertyNotFound key]
+    Just jsvalue ->
+      liftJSM (fromJSVal jsvalue) >>= \case
+        Nothing ->
+          throwError [DecodeFailure key]
+        Just x ->
+          pure x
+-----------------------------------------------------------------------------
+-- | Parser combinator for decoding values out of JSM in t'Parser', optionally.
+(.:?) :: FromJSVal a => Event -> MisoString -> Parser (Maybe a)
+(.:?) (Event event) key = do
+  result <- liftJSM $ do
+    result <- unsafeGetProp key (Object event)
+    maybeNullOrUndefined result
+  case result of
+    Nothing -> do
+      pure Nothing
+    Just jsvalue ->
+      liftJSM (fromJSVal jsvalue) >>= \case
+        Nothing ->
+          throwError [DecodeFailure key]
+        Just x ->
+          pure (Just x)
+-----------------------------------------------------------------------------
+-- | Parser combinator for decoding values out of JSM in t'Parser', optionally.
+(.!=) :: FromJSVal a => Parser (Maybe a) -> a -> Parser a
+(.!=) parser def = fromMaybe def <$> parser
 -----------------------------------------------------------------------------
 -- | Empty t'Decoder' for use with events like "click" that do not
 -- return any meaningful values
@@ -75,7 +150,7 @@ keycodeDecoder :: Decoder KeyCode
 keycodeDecoder = Decoder {..}
   where
     decodeAt = DecodeTarget mempty
-    decoder = withObject "event" $ \o ->
+    decoder = withObject "keycodeDecoder" $ \o ->
        KeyCode <$> (o .: "keyCode" <|> o .: "which" <|> o .: "charCode")
 -----------------------------------------------------------------------------
 -- | Retrieves either "keyCode", "which" or "charCode" field in t'Decoder',
@@ -86,7 +161,7 @@ keyInfoDecoder = Decoder {..}
     decodeAt =
       DecodeTarget mempty
     decoder =
-      withObject "event" $ \o ->
+      withObject "keyInfoDecoder" $ \o ->
         KeyInfo
           <$> (o .: "keyCode" <|> o .: "which" <|> o .: "charCode")
           <*> o .: "shiftKey"
@@ -99,14 +174,14 @@ valueDecoder :: Decoder MisoString
 valueDecoder = Decoder {..}
   where
     decodeAt = DecodeTarget ["target"]
-    decoder = withObject "target" $ \o -> o .: "value"
+    decoder = withObject "valueDecoder" $ \o -> o .: "value"
 -----------------------------------------------------------------------------
 -- | Retrieves "checked" field in t'Decoder'
 checkedDecoder :: Decoder Checked
 checkedDecoder = Decoder {..}
   where
     decodeAt = DecodeTarget ["target"]
-    decoder = withObject "target" $ \o ->
+    decoder = withObject "checkedDecoder" $ \o ->
       Checked <$> (o .: "checked")
 -----------------------------------------------------------------------------
 -- | Pointer t'Decoder' for use with events like "onpointerover"
@@ -128,3 +203,40 @@ pointerDecoder = Decoder {..}
         <*> o .: "pressure"
         <*> o .: "button"
 -----------------------------------------------------------------------------
+-- | Helper function used internall to execute a t'Decoder'
+executeDecoder
+  :: Decoder a
+  -> MisoString
+  -> JSVal
+  -> (a -> JSM ())
+  -> JSM ()
+executeDecoder decode@Decoder {..} eventName e callback = do
+  decodeAtVal <- toJSVal decodeAt
+  syntheticEvent <- fromJSVal =<< FFI.eventJSON decodeAtVal e
+  case (syntheticEvent :: Maybe FFI.Event) of
+    Nothing ->
+      FFI.consoleError $ mconcat
+       [ "Internal error: Could not create synthetic event. Please "
+       , "check your 'Decoder' and the `decodeAtVal` field."
+       ]
+    Just (event :: FFI.Event) ->
+      parseEither event decode >>= \case
+        Left errors ->
+          forM_ errors $ \case
+            PropertyNotFound key -> do
+              FFI.consoleError $ MS.intercalate " "
+                [ "Property"
+                , "\"" <> key <> "\" "
+                , "not found on event: "
+                , eventName
+                ]
+            DecodeFailure key -> do
+              FFI.consoleError $ MS.intercalate " "
+                [ "Property"
+                , "\"" <> key <> "\" "
+                , "failed to decode on event: "
+                , eventName
+                ]
+        Right r ->
+          callback r
+-----------------------------------------------------------------------------

src/Miso/Event/Types.hs

@@ -1,6 +1,7 @@
 -----------------------------------------------------------------------------
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -----------------------------------------------------------------------------
@@ -42,7 +43,7 @@ module Miso.Event.Types
 -----------------------------------------------------------------------------
 import           Data.Aeson (FromJSON(..), withText)
 import qualified Data.Map.Strict as M
-import           Language.Javascript.JSaddle (ToJSVal(..), create, setProp)
+import           Language.Javascript.JSaddle (FromJSVal(..), ToJSVal(..), create, setProp)
 import           Miso.String (MisoString, ms)
 -----------------------------------------------------------------------------
 -- | Type useful for both KeyCode and additional key press information.
@@ -58,6 +59,9 @@ data KeyInfo
 newtype KeyCode = KeyCode Int
   deriving (Show, Eq, Ord, FromJSON, Num)
 -----------------------------------------------------------------------------
+instance FromJSVal KeyCode where
+  fromJSVal x = fmap KeyCode <$> fromJSVal x
+-----------------------------------------------------------------------------
 -- | Type used for Checkbox events.
 newtype Checked = Checked Bool
   deriving (Show, Eq, Ord, FromJSON)
@@ -100,6 +104,19 @@ instance FromJSON PointerType where
     "pen"   -> pure PenPointerType
     x       -> pure (UnknownPointerType (ms x))
 -----------------------------------------------------------------------------
+instance FromJSVal PointerType where
+  fromJSVal jsval = do
+    fromJSVal @MisoString jsval >>= \case
+      Just "mount" ->
+        pure (Just MousePointerType)
+      Just "touch" ->
+        pure (Just TouchPointerType)
+      Just "pen" ->
+        pure (Just PenPointerType)
+      Just x ->
+        pure (Just (UnknownPointerType (ms x)))
+      Nothing -> pure Nothing
+-----------------------------------------------------------------------------
 -- | t'Options' for handling event propagation.
 data Options
   = Options

src/Miso/FFI/Internal.hs

@@ -990,7 +990,7 @@ instance FromJSVal (Map MisoString MisoString) where
 -----------------------------------------------------------------------------
 -- | [Event](https://developer.mozilla.org/en-US/docs/Web/API/Event/Event)
 newtype Event = Event JSVal
-  deriving (ToJSVal)
+  deriving (ToJSVal, MakeArgs, MakeObject)
 -----------------------------------------------------------------------------
 instance FromJSVal Event where
   fromJSVal = pure . Just . Event

src/Miso/Subscription/Window.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -21,8 +22,6 @@ module Miso.Subscription.Window
   ) where
 -----------------------------------------------------------------------------
 import           Control.Monad
-import           Language.Javascript.JSaddle
-import           Data.Aeson.Types (parseEither)
 -----------------------------------------------------------------------------
 import           Miso.Event
 import           Miso.Effect
@@ -49,22 +48,17 @@ windowSubWithOptions
   -> Decoder result
   -> (result -> action)
   -> Sub action
-windowSubWithOptions Options{..} eventName Decoder {..} toAction sink =
+windowSubWithOptions Options{..} eventName decoder toAction sink =
   createSub acquire release sink
     where
       release =
         FFI.windowRemoveEventListener eventName
       acquire =
         FFI.windowAddEventListener eventName $ \e -> do
-          decodeAtVal <- toJSVal decodeAt
-          v <- fromJSValUnchecked =<< FFI.eventJSON decodeAtVal e
-          case parseEither decoder v of
-            Left s ->
-              FFI.consoleError ("windowSubWithOptions: Parse error on " <> eventName <> ": " <> ms s)
-            Right r -> do
-              when _stopPropagation (FFI.eventStopPropagation e)
-              when _preventDefault (FFI.eventPreventDefault e)
-              sink (toAction r)
+          executeDecoder decoder eventName e $ \r -> do
+            when _stopPropagation (FFI.eventStopPropagation e)
+            when _preventDefault (FFI.eventPreventDefault e)
+            sink (toAction r)
 -----------------------------------------------------------------------------
 -- | @window.addEventListener ("pointermove", (event) => handle(event))@
 -- A 'Sub' to handle t'PointerEvent's on window.