Change raw events to use maybe-based handlers (#28)

* change raw events to use maybe-based handlers

* Add a test case for maybeful events

Co-authored-by: Mikhail Chekan <[email protected]>

Author: chekoopa

src/Flame/HTML/Attribute.purs

@@ -3,4 +3,4 @@ module Flame.HTML.Attribute(module Exported) where
 
 import Flame.HTML.Attribute.Internal (class ToClassList, ToBooleanAttribute, ToIntAttribute, ToNumberAttribute, ToStringAttribute,
 accentHeight, accept, acceptCharset, accessKey, accumulate, action, additive, align, alignmentBaseline, alt, ascent, autocomplete, autofocus, autoplay, azimuth, baseFrequency, baseProfile, baselineShift, begin, bias, calcMode, charset, checked, class', clipPathAttr, clipPathUnits, clipRule, color, colorInterpolation, colorInterpolationFilters, colorProfileAttr, colorRendering, cols, colspan, content, contentEditable, contentScriptType, contentStyleType, contextmenu, controls, coords, createAttribute, createAttributeName, createAttributeType, createProperty, cursorAttr, cx, cy, d, datetime, default, diffuseConstant, dir, direction, disabled, display, divisor, dominantBaseline, download, downloadAs, draggable, dropzone, dur, dx, dy, edgeMode, elevation, enctype, end, externalResourcesRequired, fill, fillOpacity, fillRule, filterAttr, filterUnits, floodColor, floodOpacity, fontFamily, fontSize, fontSizeAdjust, fontStretch, fontStyle, fontVariant, fontWeight, for, fr, from, fx, fy, gradientTransform, gradientUnits, headers, height, hidden, href, hreflang, id, imageRendering, in', in2, isMap, itemprop, k1, k2, k3, k4, kernelMatrix, kernelUnitLength, kerning, keySplines, keyTimes, kind, lang, lengthAdjust, letterSpacing, lightingColor, limitingConeAngle, list, local, loop, manifest, markerEnd, markerHeight, markerMid, markerStart, markerUnits, markerWidth, maskAttr, maskContentUnits, maskUnits, max, maxlength, media, method, min, minlength, mode, multiple, name, noValidate, numOctaves, opacity, operator, order, overflow, overlinePosition, overlineThickness, paintOrder, pathLength, pattern, patternContentUnits, patternTransform, patternUnits, ping, placeholder, pointerEvents, points, pointsAtX, pointsAtY, pointsAtZ, poster, preload, preserveAlpha, preserveAspectRatio, primitiveUnits, pubdate, r, radius, readOnly, refX, refY, rel, repeatCount, repeatDur, required, requiredFeatures, restart, result, reversed, rows, rowspan, rx, ry, sandbox, scale, scope, seed, selected, shape, shapeRendering, size, specularConstant, specularExponent, spellcheck, src, srcdoc, srclang, start, stdDeviation, step, stitchTiles, stopColor, stopOpacity, strikethroughPosition, strikethroughThickness, stroke, strokeDasharray, strokeDashoffset, strokeLinecap, strokeLinejoin, strokeMiterlimit, strokeOpacity, strokeWidth, style, styleAttr, surfaceScale, tabindex, target, targetX, targetY, textAnchor, textDecoration, textLength, textRendering, title, to, transform, type', underlinePosition, underlineThickness, useMap, value, values, vectorEffect, version, viewBox, visibility, width, wordSpacing, wrap, writingMode, x, x1, x2, xChannelSelector, y, y1, y2, yChannelSelector, innerHTML) as Exported
-import Flame.HTML.Event (EventName, ToEvent, ToRawEvent, ToSpecialEvent, createEvent, createEventMessage, createRawEvent, onBlur, onBlur', onCheck, onClick, onClick', onChange, onChange', onContextmenu, onContextmenu', onDblclick, onDblclick', onDrag, onDrag', onDragend, onDragend', onDragenter, onDragenter', onDragleave, onDragleave', onDragover, onDragover', onDragstart, onDragstart', onDrop, onDrop', onError, onError', onFocus, onFocus', onFocusin, onFocusin', onFocusout, onFocusout', onInput, onInput', onKeydown, onKeydown', onKeypress, onKeypress', onKeyup, onKeyup', onMousedown, onMousedown', onMouseenter, onMouseenter', onMouseleave, onMouseleave', onMousemove, onMousemove', onMouseout, onMouseout', onMouseover, onMouseover', onMouseup, onMouseup', onReset, onReset', onScroll, onScroll', onSelect, onSelect', onSubmit, onSubmit', onWheel, onWheel') as Exported
+import Flame.HTML.Event (EventName, ToEvent, ToRawEvent, ToMaybeEvent, ToSpecialEvent, createEvent, createEventMessage, createRawEvent, onBlur, onBlur', onCheck, onClick, onClick', onChange, onChange', onContextmenu, onContextmenu', onDblclick, onDblclick', onDrag, onDrag', onDragend, onDragend', onDragenter, onDragenter', onDragleave, onDragleave', onDragover, onDragover', onDragstart, onDragstart', onDrop, onDrop', onError, onError', onFocus, onFocus', onFocusin, onFocusin', onFocusout, onFocusout', onInput, onInput', onKeydown, onKeydown', onKeypress, onKeypress', onKeyup, onKeyup', onMousedown, onMousedown', onMouseenter, onMouseenter', onMouseleave, onMouseleave', onMousemove, onMousemove', onMouseout, onMouseout', onMouseover, onMouseover', onMouseup, onMouseup', onReset, onReset', onScroll, onScroll', onSelect, onSelect', onSubmit, onSubmit', onWheel, onWheel') as Exported

src/Flame/HTML/Attribute/Event.purs

@@ -1,8 +1,9 @@
 -- | Definition of HTML events that can be fired from views
-module Flame.HTML.Event (EventName, ToEvent, ToRawEvent, ToSpecialEvent, createEvent, createEventMessage, createRawEvent, onBlur, onBlur', onCheck, onClick, onClick', onChange, onChange', onContextmenu, onContextmenu', onDblclick, onDblclick', onDrag, onDrag', onDragend, onDragend', onDragenter, onDragenter', onDragleave, onDragleave', onDragover, onDragover', onDragstart, onDragstart', onDrop, onDrop', onError, onError', onFocus, onFocus', onFocusin, onFocusin', onFocusout, onFocusout', onInput, onInput', onKeydown, onKeydown', onKeypress, onKeypress', onKeyup, onKeyup', onMousedown, onMousedown', onMouseenter, onMouseenter', onMouseleave, onMouseleave', onMousemove, onMousemove', onMouseout, onMouseout', onMouseover, onMouseover', onMouseup, onMouseup', onReset, onReset', onScroll, onScroll', onSelect, onSelect', onSubmit, onSubmit', onWheel, onWheel') where
+module Flame.HTML.Event (EventName, ToEvent, ToRawEvent, ToMaybeEvent, ToSpecialEvent, createEvent, createEventMessage, createRawEvent, onBlur, onBlur', onCheck, onClick, onClick', onChange, onChange', onContextmenu, onContextmenu', onDblclick, onDblclick', onDrag, onDrag', onDragend, onDragend', onDragenter, onDragenter', onDragleave, onDragleave', onDragover, onDragover', onDragstart, onDragstart', onDrop, onDrop', onError, onError', onFocus, onFocus', onFocusin, onFocusin', onFocusout, onFocusout', onInput, onInput', onKeydown, onKeydown', onKeypress, onKeypress', onKeyup, onKeyup', onMousedown, onMousedown', onMouseenter, onMouseenter', onMouseleave, onMouseleave', onMousemove, onMousemove', onMouseout, onMouseout', onMouseover, onMouseover', onMouseup, onMouseup', onReset, onReset', onScroll, onScroll', onSelect, onSelect', onSubmit, onSubmit', onWheel, onWheel') where
 
 import Prelude
 
+import Data.Maybe (Maybe(..))
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Uncurried (EffectFn1)
@@ -16,6 +17,8 @@ type ToEvent message = message -> NodeData message
 
 type ToRawEvent message = (Event -> message) -> NodeData message
 
+type ToMaybeEvent message = (Event -> Maybe message) -> NodeData message
+
 type ToSpecialEvent message t = (t -> message) -> NodeData message
 
 --this way we dont need to worry about every possible element type
@@ -45,12 +48,12 @@ createEvent :: forall message. EventName -> message -> NodeData message
 createEvent = Event
 
 -- | Raises the given `message` for the given event, but also supplies the event itself
-createRawEvent :: forall message. String -> (Event -> Effect message) -> NodeData message
+createRawEvent :: forall message. String -> (Event -> Effect (Maybe message)) -> NodeData message
 createRawEvent = RawEvent
 
 -- | Helper for `message`s that expect an event
 createEventMessage :: forall message. EventName -> (Event -> message) -> NodeData message
-createEventMessage eventName constructor = createRawEvent eventName (pure <<< constructor)
+createEventMessage eventName constructor = createRawEvent eventName (pure <<< Just <<< constructor)
 
 onScroll :: forall message. ToEvent message
 onScroll = createEvent "scroll"
@@ -73,27 +76,27 @@ onChange' = createEventMessage "change"
 -- | This event fires when the value of an input, select, textarea, contenteditable or designMode on elements changes
 onInput :: forall message. ToSpecialEvent message String
 onInput constructor = createRawEvent "input" handler
-        where   handler event = constructor <$> nodeValue event
+        where   handler event = Just <<< constructor <$> nodeValue event
 
 onInput' :: forall message. ToRawEvent message
 onInput' = createEventMessage "input"
 
 -- | Helper for `input` event of checkboxes and radios
 onCheck :: forall message. ToSpecialEvent message Boolean
 onCheck constructor = createRawEvent "input" handler
-        where   handler event = constructor <$> checkedValue event
+        where   handler event = Just <<< constructor <$> checkedValue event
 
 onSubmit :: forall message. ToEvent message
 onSubmit message = createRawEvent "submit" handler
         where   handler event = do
                         preventDefault event
-                        pure message
+                        pure $ Just message
 
 onSubmit' :: forall message. ToRawEvent message
 onSubmit' constructor = createRawEvent "submit" handler
         where   handler event = do
                         preventDefault event
-                        pure $ constructor event
+                        pure <<< Just $ constructor event
 
 onFocus :: forall message. ToEvent message
 onFocus = createEvent "focus"
@@ -143,11 +146,11 @@ onKeyup constructor = createRawEvent "keyup" (keyInput constructor)
 onKeyup' :: forall message. ToRawEvent message
 onKeyup' = createEventMessage "keyup"
 
-keyInput :: forall message . (Tuple Key String -> message) -> Event -> Effect message
+keyInput :: forall message . (Tuple Key String -> message) -> Event -> Effect (Maybe message)
 keyInput constructor event = do
         down <- key event
         value <- nodeValue event
-        pure <<< constructor $ Tuple down value
+        pure <<< Just <<< constructor $ Tuple down value
 
 onContextmenu :: forall message. ToEvent message
 onContextmenu = createEvent "contextmenu"
@@ -205,7 +208,7 @@ onMouseup' = createEventMessage "mouseup"
 
 onSelect :: forall message. ToSpecialEvent message String
 onSelect constructor = createRawEvent "select" handler
-        where   handler event = constructor <$> selection event
+        where   handler event = Just <<< constructor <$> selection event
 
 onSelect' :: forall message. ToRawEvent message
 onSelect' = createEventMessage "select"

src/Flame/Renderer/Renderer.purs

@@ -14,13 +14,14 @@ module Flame.Renderer(
 import Data.Foldable as DF
 import Data.Function.Uncurried (Fn1, Fn2, Fn3, runFn3)
 import Data.Function.Uncurried as DFU
+import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Uncurried (EffectFn2)
 import Effect.Uncurried as EU
 import Flame.Types (DOMElement, Html(..), NodeData(..), VNode(..), VNodeData, VNodeEvents)
 import Foreign.Object (Object)
 import Foreign.Object as FO
-import Prelude (Unit, bind, const, discard, map, pure, ($))
+import Prelude (Unit, bind, const, discard, map, pure, unit, ($))
 import Web.Event.Internal.Types (Event)
 
 foreign import emptyVNode :: VNode
@@ -104,8 +105,10 @@ toVNode updater (Node tag nodeData children) = h tag vNodeData $ map (toVNode up
                 }
 
                 handleRawEvent handler event = do
-                        message <- handler event
-                        updater message
+                        result <- handler event
+                        case result of
+                                Just message -> updater message
+                                Nothing -> pure unit
 
                 unions record@{ properties, attributes, events, hooks } =
                         case _ of

src/Flame/Types.purs

@@ -5,6 +5,7 @@ import Prelude
 
 import Data.Array as DA
 import Data.Foldable as DF
+import Data.Maybe (Maybe)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Foreign (Foreign)
@@ -85,7 +86,7 @@ data NodeData message =
         Attribute String String |
         Property String String |
         Event String message |
-        RawEvent String (Event -> Effect message) |
+        RawEvent String (Event -> Effect (Maybe message)) |
         Hook String Foreign
 
 derive instance nodeDataFunctor :: Functor NodeData

test/Basic/EffectList.js

@@ -0,0 +1,6 @@
+exports.key_ = function(event) {
+    if (event.type === "keyup" || event.type === "keydown" || event.type === "keypress")
+        return event.key;
+
+    return "";
+}

test/Basic/EffectList.purs

@@ -10,20 +10,25 @@ import Effect (Effect)
 import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
 import Effect.Random as ER
+import Effect.Uncurried (EffectFn1)
+import Effect.Uncurried as FU
 import Flame (QuerySelector(..), Html, (:>))
 import Flame.Application.EffectList as FAE
 import Flame.HTML.Attribute as HA
 import Flame.HTML.Element as HE
+import Web.Event.Event (Event)
+import Web.Event.Event as WEE
 
 type Model = String
 
-data Message = Current String | Cut
+data Message = Current String | Cut | Submit
 
 update :: Model -> Message -> Tuple Model (Array (Aff (Maybe Message)))
 update model = case _ of
         Cut -> model :> [
                 Just <<< Current <$> cut model
         ]
+        Submit -> "thanks" :> []
         Current text -> text :> []
         where   cut text = do
                         amount <- liftEffect <<< ER.randomInt 1 $ DSC.length text
@@ -33,9 +38,17 @@ view :: Model -> Html Message
 view model = HE.main_ [
         HE.span [HA.id "text-output"] model,
         --we add extra events for each input to test if the correct message is used
-        HE.input [HA.id "text-input", HA.type' "text", HA.onInput Current, HA.onFocus Cut],
+        HE.input [HA.id "text-input", HA.type' "text", HA.onInput Current, HA.onFocus Cut, onEnterPressed Submit],
         HE.input [HA.id "cut-button", HA.type' "button", HA.onClick Cut, HA.onFocus (Current "")]
 ]
+          where onEnterPressed message = HA.createRawEvent "keypress" $ \event -> do
+                        pressed <- key event
+                        case pressed of
+                                "Enter" -> do
+                                        WEE.preventDefault event
+                                        pure $ Just message
+                                _ -> pure Nothing
+
 
 mount :: Effect Unit
 mount = FAE.mount_ (QuerySelector "#mount-point") {
@@ -44,3 +57,8 @@ mount = FAE.mount_ (QuerySelector "#mount-point") {
                 view
         }
 
+--helper functions for onEnterPressed
+foreign import key_ :: EffectFn1 Event String
+
+key :: Event -> Effect String
+key = FU.runEffectFn1 key_

test/Main.js

@@ -20,10 +20,14 @@ exports.keydownEvent = function () {
 	return new window.KeyboardEvent('keydown', {key: 'q'});
 }
 
+exports.enterPressedEvent = function () {
+	return new window.KeyboardEvent('keypress', {key: 'Enter'});
+}
+
 exports.errorEvent = function () {
 	return new window.Event('error');
 }
 
 exports.offlineEvent = function () {
 	return new window.Event('offline');
-}
+}

test/Main.purs

@@ -54,6 +54,7 @@ foreign import unsafeCreateEnviroment :: Effect Unit
 foreign import clickEvent :: Effect Event
 foreign import inputEvent :: Effect Event
 foreign import keydownEvent :: Effect Event
+foreign import enterPressedEvent :: Effect Event
 foreign import errorEvent :: Effect Event
 foreign import offlineEvent :: Effect Event
 
@@ -283,6 +284,11 @@ main =
                                 --always remove at least one character
                                 TUA.assert "cut text" $ DSC.length cut < 4
 
+                                dispatchEvent inputEvent "#text-input"
+                                dispatchEvent enterPressedEvent "#text-input"
+                                submitted <- textContent "#text-output"
+                                TUA.equal "thanks" submitted
+
                         test "effectful" do
                                 liftEffect do
                                         unsafeCreateEnviroment