Skip to content

Commit f0b892e

Browse files
chekoopaMikhail Chekan
andauthored
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]>
1 parent 2378d1a commit f0b892e

File tree

8 files changed

+59
-18
lines changed

8 files changed

+59
-18
lines changed

src/Flame/HTML/Attribute.purs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,4 +3,4 @@ module Flame.HTML.Attribute(module Exported) where
33

44
import Flame.HTML.Attribute.Internal (class ToClassList, ToBooleanAttribute, ToIntAttribute, ToNumberAttribute, ToStringAttribute,
55
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
6-
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
6+
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

Lines changed: 13 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
11
-- | Definition of HTML events that can be fired from views
2-
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
2+
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
33

44
import Prelude
55

6+
import Data.Maybe (Maybe(..))
67
import Data.Tuple (Tuple(..))
78
import Effect (Effect)
89
import Effect.Uncurried (EffectFn1)
@@ -16,6 +17,8 @@ type ToEvent message = message -> NodeData message
1617

1718
type ToRawEvent message = (Event -> message) -> NodeData message
1819

20+
type ToMaybeEvent message = (Event -> Maybe message) -> NodeData message
21+
1922
type ToSpecialEvent message t = (t -> message) -> NodeData message
2023

2124
--this way we dont need to worry about every possible element type
@@ -45,12 +48,12 @@ createEvent :: forall message. EventName -> message -> NodeData message
4548
createEvent = Event
4649

4750
-- | Raises the given `message` for the given event, but also supplies the event itself
48-
createRawEvent :: forall message. String -> (Event -> Effect message) -> NodeData message
51+
createRawEvent :: forall message. String -> (Event -> Effect (Maybe message)) -> NodeData message
4952
createRawEvent = RawEvent
5053

5154
-- | Helper for `message`s that expect an event
5255
createEventMessage :: forall message. EventName -> (Event -> message) -> NodeData message
53-
createEventMessage eventName constructor = createRawEvent eventName (pure <<< constructor)
56+
createEventMessage eventName constructor = createRawEvent eventName (pure <<< Just <<< constructor)
5457

5558
onScroll :: forall message. ToEvent message
5659
onScroll = createEvent "scroll"
@@ -73,27 +76,27 @@ onChange' = createEventMessage "change"
7376
-- | This event fires when the value of an input, select, textarea, contenteditable or designMode on elements changes
7477
onInput :: forall message. ToSpecialEvent message String
7578
onInput constructor = createRawEvent "input" handler
76-
where handler event = constructor <$> nodeValue event
79+
where handler event = Just <<< constructor <$> nodeValue event
7780

7881
onInput' :: forall message. ToRawEvent message
7982
onInput' = createEventMessage "input"
8083

8184
-- | Helper for `input` event of checkboxes and radios
8285
onCheck :: forall message. ToSpecialEvent message Boolean
8386
onCheck constructor = createRawEvent "input" handler
84-
where handler event = constructor <$> checkedValue event
87+
where handler event = Just <<< constructor <$> checkedValue event
8588

8689
onSubmit :: forall message. ToEvent message
8790
onSubmit message = createRawEvent "submit" handler
8891
where handler event = do
8992
preventDefault event
90-
pure message
93+
pure $ Just message
9194

9295
onSubmit' :: forall message. ToRawEvent message
9396
onSubmit' constructor = createRawEvent "submit" handler
9497
where handler event = do
9598
preventDefault event
96-
pure $ constructor event
99+
pure <<< Just $ constructor event
97100

98101
onFocus :: forall message. ToEvent message
99102
onFocus = createEvent "focus"
@@ -143,11 +146,11 @@ onKeyup constructor = createRawEvent "keyup" (keyInput constructor)
143146
onKeyup' :: forall message. ToRawEvent message
144147
onKeyup' = createEventMessage "keyup"
145148

146-
keyInput :: forall message . (Tuple Key String -> message) -> Event -> Effect message
149+
keyInput :: forall message . (Tuple Key String -> message) -> Event -> Effect (Maybe message)
147150
keyInput constructor event = do
148151
down <- key event
149152
value <- nodeValue event
150-
pure <<< constructor $ Tuple down value
153+
pure <<< Just <<< constructor $ Tuple down value
151154

152155
onContextmenu :: forall message. ToEvent message
153156
onContextmenu = createEvent "contextmenu"
@@ -205,7 +208,7 @@ onMouseup' = createEventMessage "mouseup"
205208

206209
onSelect :: forall message. ToSpecialEvent message String
207210
onSelect constructor = createRawEvent "select" handler
208-
where handler event = constructor <$> selection event
211+
where handler event = Just <<< constructor <$> selection event
209212

210213
onSelect' :: forall message. ToRawEvent message
211214
onSelect' = createEventMessage "select"

src/Flame/Renderer/Renderer.purs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -14,13 +14,14 @@ module Flame.Renderer(
1414
import Data.Foldable as DF
1515
import Data.Function.Uncurried (Fn1, Fn2, Fn3, runFn3)
1616
import Data.Function.Uncurried as DFU
17+
import Data.Maybe (Maybe(..))
1718
import Effect (Effect)
1819
import Effect.Uncurried (EffectFn2)
1920
import Effect.Uncurried as EU
2021
import Flame.Types (DOMElement, Html(..), NodeData(..), VNode(..), VNodeData, VNodeEvents)
2122
import Foreign.Object (Object)
2223
import Foreign.Object as FO
23-
import Prelude (Unit, bind, const, discard, map, pure, ($))
24+
import Prelude (Unit, bind, const, discard, map, pure, unit, ($))
2425
import Web.Event.Internal.Types (Event)
2526

2627
foreign import emptyVNode :: VNode
@@ -104,8 +105,10 @@ toVNode updater (Node tag nodeData children) = h tag vNodeData $ map (toVNode up
104105
}
105106

106107
handleRawEvent handler event = do
107-
message <- handler event
108-
updater message
108+
result <- handler event
109+
case result of
110+
Just message -> updater message
111+
Nothing -> pure unit
109112

110113
unions record@{ properties, attributes, events, hooks } =
111114
case _ of

src/Flame/Types.purs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ import Prelude
55

66
import Data.Array as DA
77
import Data.Foldable as DF
8+
import Data.Maybe (Maybe)
89
import Data.Tuple (Tuple(..))
910
import Effect (Effect)
1011
import Foreign (Foreign)
@@ -85,7 +86,7 @@ data NodeData message =
8586
Attribute String String |
8687
Property String String |
8788
Event String message |
88-
RawEvent String (Event -> Effect message) |
89+
RawEvent String (Event -> Effect (Maybe message)) |
8990
Hook String Foreign
9091

9192
derive instance nodeDataFunctor :: Functor NodeData

test/Basic/EffectList.js

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
exports.key_ = function(event) {
2+
if (event.type === "keyup" || event.type === "keydown" || event.type === "keypress")
3+
return event.key;
4+
5+
return "";
6+
}

test/Basic/EffectList.purs

Lines changed: 20 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,20 +10,25 @@ import Effect (Effect)
1010
import Effect.Aff (Aff)
1111
import Effect.Class (liftEffect)
1212
import Effect.Random as ER
13+
import Effect.Uncurried (EffectFn1)
14+
import Effect.Uncurried as FU
1315
import Flame (QuerySelector(..), Html, (:>))
1416
import Flame.Application.EffectList as FAE
1517
import Flame.HTML.Attribute as HA
1618
import Flame.HTML.Element as HE
19+
import Web.Event.Event (Event)
20+
import Web.Event.Event as WEE
1721

1822
type Model = String
1923

20-
data Message = Current String | Cut
24+
data Message = Current String | Cut | Submit
2125

2226
update :: Model -> Message -> Tuple Model (Array (Aff (Maybe Message)))
2327
update model = case _ of
2428
Cut -> model :> [
2529
Just <<< Current <$> cut model
2630
]
31+
Submit -> "thanks" :> []
2732
Current text -> text :> []
2833
where cut text = do
2934
amount <- liftEffect <<< ER.randomInt 1 $ DSC.length text
@@ -33,9 +38,17 @@ view :: Model -> Html Message
3338
view model = HE.main_ [
3439
HE.span [HA.id "text-output"] model,
3540
--we add extra events for each input to test if the correct message is used
36-
HE.input [HA.id "text-input", HA.type' "text", HA.onInput Current, HA.onFocus Cut],
41+
HE.input [HA.id "text-input", HA.type' "text", HA.onInput Current, HA.onFocus Cut, onEnterPressed Submit],
3742
HE.input [HA.id "cut-button", HA.type' "button", HA.onClick Cut, HA.onFocus (Current "")]
3843
]
44+
where onEnterPressed message = HA.createRawEvent "keypress" $ \event -> do
45+
pressed <- key event
46+
case pressed of
47+
"Enter" -> do
48+
WEE.preventDefault event
49+
pure $ Just message
50+
_ -> pure Nothing
51+
3952

4053
mount :: Effect Unit
4154
mount = FAE.mount_ (QuerySelector "#mount-point") {
@@ -44,3 +57,8 @@ mount = FAE.mount_ (QuerySelector "#mount-point") {
4457
view
4558
}
4659

60+
--helper functions for onEnterPressed
61+
foreign import key_ :: EffectFn1 Event String
62+
63+
key :: Event -> Effect String
64+
key = FU.runEffectFn1 key_

test/Main.js

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -20,10 +20,14 @@ exports.keydownEvent = function () {
2020
return new window.KeyboardEvent('keydown', {key: 'q'});
2121
}
2222

23+
exports.enterPressedEvent = function () {
24+
return new window.KeyboardEvent('keypress', {key: 'Enter'});
25+
}
26+
2327
exports.errorEvent = function () {
2428
return new window.Event('error');
2529
}
2630

2731
exports.offlineEvent = function () {
2832
return new window.Event('offline');
29-
}
33+
}

test/Main.purs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ foreign import unsafeCreateEnviroment :: Effect Unit
5454
foreign import clickEvent :: Effect Event
5555
foreign import inputEvent :: Effect Event
5656
foreign import keydownEvent :: Effect Event
57+
foreign import enterPressedEvent :: Effect Event
5758
foreign import errorEvent :: Effect Event
5859
foreign import offlineEvent :: Effect Event
5960

@@ -283,6 +284,11 @@ main =
283284
--always remove at least one character
284285
TUA.assert "cut text" $ DSC.length cut < 4
285286

287+
dispatchEvent inputEvent "#text-input"
288+
dispatchEvent enterPressedEvent "#text-input"
289+
submitted <- textContent "#text-output"
290+
TUA.equal "thanks" submitted
291+
286292
test "effectful" do
287293
liftEffect do
288294
unsafeCreateEnviroment

0 commit comments

Comments
 (0)