[sc-39347] Adds onPreventDefault

This adds a new event handler to prevent the default event (i.e.
navigating to the HREF of an anchor tag) from occurring.

This way we can have our cake and eat it to with links - supporting
links that both navigate using the single-page-app routing but also
support middle clicking or right click + copying the address.

src/DOM/Erumu/HTML/Events.purs

@@ -1,5 +1,6 @@
 module DOM.Erumu.HTML.Events
   ( onclick
+  , preventDefaultOnclick
   , terminalOnclick
   , clickawayfn
   , oninput
@@ -10,14 +11,17 @@ module DOM.Erumu.HTML.Events
   ) where
 
 
-import DOM.Erumu.Types (onEvent, onPropagatingEvent, Prop)
+import DOM.Erumu.Types (onEvent, onPreventDefaultEvent, onPropagatingEvent, Prop)
 
 onclick :: forall msg. msg -> Prop msg
 onclick = onPropagatingEvent "onclick"
 
 terminalOnclick :: forall msg. msg -> Prop msg
 terminalOnclick = onEvent "onclick"
 
+preventDefaultOnclick :: forall msg. msg -> Prop msg
+preventDefaultOnclick = onPreventDefaultEvent "onclick"
+
 oninput :: forall msg. msg -> Prop msg
 oninput = onEvent "oninput"
 

src/DOM/Erumu/Types.purs

@@ -21,7 +21,9 @@ module DOM.Erumu.Types
 
   , HTML, element, text, texts, noElement, toVTree
 
-  , Prop, attribute, onEvent, onPropagatingEvent, onEventDecode, onEventMaybeDecode, hookProp
+  , Prop, attribute , hookProp
+  , onEvent, onPreventDefaultEvent, onPropagatingEvent
+  , onEventDecode, onEventMaybeDecode
 
   , Command, DispatchFn
   , dispatchCmd
@@ -46,7 +48,7 @@ import Effect (Effect)
 import DOM.Erumu.Decode (Decode)
 import DOM.Erumu.Decode as Decode
 import Web.Event.Event (Event)
-import DOM.Virtual (VTree, Attribute, EventHandler, node, stringValue, nonPropagatingEventHandler, propagatingEventHandler)
+import DOM.Virtual (VTree, Attribute, EventHandler, node, stringValue, nonPropagatingEventHandler, preventDefaultEventHandler, propagatingEventHandler)
 import DOM.Virtual as Virtual
 
 --not sure about this. I actually think VTree shouldn't have a type parameter. I certainly don't want to add one for `HTML`. Maybe it should just be concrete.
@@ -332,6 +334,12 @@ onPropagatingEvent name dat =
               propagatingEventHandler
               (\_ -> pure [dat])
 
+onPreventDefaultEvent :: forall msg. String -> msg -> Prop msg
+onPreventDefaultEvent name dat =
+  handlerProp name
+              preventDefaultEventHandler
+              (\_ -> pure [dat])
+
 -- This event decode property is used to declare a handler that will *always* process the event into
 -- a Schmods Msg to dispatch, and stops propagation to potential parent handlers.
 onEventDecode :: forall msg. String -> (Decode msg) -> Prop msg

src/DOM/Virtual.js

@@ -85,6 +85,15 @@ export function propagatingEventHandler(eff) {
   }
 }
 
+export function preventDefaultEventHandler(eff) {
+  return function(event) {
+    eff(event)();
+      if(typeof event.preventDefault == "function") {
+        event.preventDefault();
+      }
+  }
+}
+
 export function createElement(tree) {
   return function() {
     return CE.default(tree);

src/DOM/Virtual.purs

@@ -7,7 +7,8 @@ module DOM.Virtual
   , Hook, HookFunctions, newHook, hookValue
 
   , EventHandler
-  , unsafeValue, stringValue, propagatingEventHandler, nonPropagatingEventHandler
+  , unsafeValue, stringValue
+  , preventDefaultEventHandler, propagatingEventHandler, nonPropagatingEventHandler
   ) where
 
 import Prelude
@@ -44,6 +45,7 @@ type EventHandler = (Event -> Effect Unit) -> Value
 
 foreign import nonPropagatingEventHandler :: EventHandler
 foreign import propagatingEventHandler :: EventHandler
+foreign import preventDefaultEventHandler :: EventHandler
 
 foreign import data HookFn :: Type
 foreign import hookFn :: (Node -> Effect Unit) -> HookFn