github.com/pf-qiu/concourse/v6@v6.7.3-0.20201207032516-1f455d73275f/web/elm/src/StrictEvents.elm (about) 1 module StrictEvents exposing 2 ( DeltaMode(..) 3 , ScrollState 4 , WheelEvent 5 , onLeftClick 6 , onLeftClickNoPreventDefault 7 , onLeftClickOrShiftLeftClick 8 , onLeftClickStopPropagation 9 , onLeftMouseDown 10 , onLeftMouseDownCapturing 11 , onScroll 12 , onWheel 13 ) 14 15 import Html 16 import Html.Events 17 import Json.Decode 18 19 20 type alias WheelEvent = 21 { deltaX : Float 22 , deltaY : Float 23 , deltaMode : DeltaMode 24 } 25 26 27 type alias ScrollState = 28 { scrollHeight : Float 29 , scrollTop : Float 30 , clientHeight : Float 31 } 32 33 34 type DeltaMode 35 = DeltaModePixel 36 | DeltaModeLine 37 | DeltaModePage 38 39 40 onLeftClick : msg -> Html.Attribute msg 41 onLeftClick msg = 42 onLeftClickCapturing True False (Json.Decode.succeed ()) (always msg) 43 44 45 onLeftClickStopPropagation : msg -> Html.Attribute msg 46 onLeftClickStopPropagation msg = 47 onLeftClickCapturing True True (Json.Decode.succeed ()) (always msg) 48 49 50 onLeftClickNoPreventDefault : msg -> Html.Attribute msg 51 onLeftClickNoPreventDefault msg = 52 onLeftClickCapturing False False (Json.Decode.succeed ()) (always msg) 53 54 55 onLeftClickCapturing : Bool -> Bool -> Json.Decode.Decoder x -> (x -> msg) -> Html.Attribute msg 56 onLeftClickCapturing preventDefault stopPropagation captured msg = 57 Html.Events.custom "click" 58 (assertNoModifier 59 |> Json.Decode.andThen 60 (\_ -> 61 assertLeftButton 62 |> Json.Decode.andThen 63 (\_ -> 64 Json.Decode.map 65 (\x -> 66 { message = msg x 67 , stopPropagation = stopPropagation 68 , preventDefault = preventDefault 69 } 70 ) 71 captured 72 ) 73 ) 74 ) 75 76 77 onLeftClickOrShiftLeftClick : msg -> msg -> Html.Attribute msg 78 onLeftClickOrShiftLeftClick msg shiftMsg = 79 Html.Events.custom "click" 80 (assertLeftButton 81 |> Json.Decode.andThen 82 (\_ -> 83 assertNo "ctrlKey" 84 |> Json.Decode.andThen 85 (\_ -> 86 assertNo "altKey" 87 |> Json.Decode.andThen 88 (\_ -> 89 assertNo "metaKey" 90 |> Json.Decode.andThen 91 (\_ -> 92 Json.Decode.map 93 (\x -> 94 { message = x 95 , stopPropagation = False 96 , preventDefault = True 97 } 98 ) 99 (determineClickMsg 100 msg 101 shiftMsg 102 ) 103 ) 104 ) 105 ) 106 ) 107 ) 108 109 110 onLeftMouseDown : msg -> Html.Attribute msg 111 onLeftMouseDown msg = 112 onLeftMouseDownCapturing (Json.Decode.succeed ()) (always msg) 113 114 115 onLeftMouseDownCapturing : Json.Decode.Decoder x -> (x -> msg) -> Html.Attribute msg 116 onLeftMouseDownCapturing captured msg = 117 Html.Events.custom "mousedown" 118 (assertNoModifier 119 |> Json.Decode.andThen 120 (\_ -> 121 assertLeftButton 122 |> Json.Decode.andThen 123 (\_ -> 124 Json.Decode.map 125 (\x -> 126 { message = msg x 127 , stopPropagation = False 128 , preventDefault = True 129 } 130 ) 131 captured 132 ) 133 ) 134 ) 135 136 137 onWheel : (WheelEvent -> msg) -> Html.Attribute msg 138 onWheel cons = 139 Html.Events.custom "wheel" 140 (Json.Decode.map 141 (\x -> 142 { message = cons x 143 , stopPropagation = False 144 , preventDefault = True 145 } 146 ) 147 decodeWheelEvent 148 ) 149 150 151 onScroll : (ScrollState -> msg) -> Html.Attribute msg 152 onScroll cons = 153 Html.Events.on "scroll" <| 154 Json.Decode.map cons decodeScrollEvent 155 156 157 determineClickMsg : msg -> msg -> Json.Decode.Decoder msg 158 determineClickMsg clickMsg shiftClickMsg = 159 customDecoder (Json.Decode.field "shiftKey" Json.Decode.bool) <| 160 \shiftKey -> 161 if shiftKey then 162 Ok shiftClickMsg 163 164 else 165 Ok clickMsg 166 167 168 assertNoModifier : Json.Decode.Decoder () 169 assertNoModifier = 170 assertNo "ctrlKey" 171 |> Json.Decode.andThen 172 (\_ -> 173 assertNo "altKey" 174 |> Json.Decode.andThen 175 (\_ -> 176 assertNo "metaKey" 177 |> Json.Decode.andThen 178 (\_ -> 179 assertNo "shiftKey" 180 ) 181 ) 182 ) 183 184 185 assertNo : String -> Json.Decode.Decoder () 186 assertNo prop = 187 customDecoder (Json.Decode.field prop Json.Decode.bool) <| 188 \val -> 189 if not val then 190 Ok () 191 192 else 193 Err (prop ++ " used - skipping") 194 195 196 assertLeftButton : Json.Decode.Decoder () 197 assertLeftButton = 198 customDecoder (Json.Decode.field "button" Json.Decode.int) <| 199 \button -> 200 if button == 0 then 201 Ok () 202 203 else 204 Err "not left button" 205 206 207 decodeWheelEvent : Json.Decode.Decoder WheelEvent 208 decodeWheelEvent = 209 Json.Decode.map3 WheelEvent 210 (Json.Decode.field "deltaX" Json.Decode.float) 211 (Json.Decode.field "deltaY" Json.Decode.float) 212 (Json.Decode.field "deltaMode" decodeDeltaMode) 213 214 215 decodeDeltaMode : Json.Decode.Decoder DeltaMode 216 decodeDeltaMode = 217 Json.Decode.int 218 |> Json.Decode.andThen 219 (\mode -> 220 case mode of 221 0 -> 222 Json.Decode.succeed DeltaModePixel 223 224 1 -> 225 Json.Decode.succeed DeltaModeLine 226 227 2 -> 228 Json.Decode.succeed DeltaModePage 229 230 _ -> 231 Json.Decode.fail <| "invalid deltaMode " ++ String.fromInt mode 232 ) 233 234 235 decodeScrollEvent : Json.Decode.Decoder ScrollState 236 decodeScrollEvent = 237 Json.Decode.map3 ScrollState 238 (Json.Decode.at [ "target", "scrollHeight" ] Json.Decode.float) 239 (Json.Decode.at [ "target", "scrollTop" ] Json.Decode.float) 240 (Json.Decode.at [ "target", "clientHeight" ] Json.Decode.float) 241 242 243 customDecoder : Json.Decode.Decoder b -> (b -> Result String a) -> Json.Decode.Decoder a 244 customDecoder decoder toResult = 245 Json.Decode.andThen 246 (\a -> 247 case toResult a of 248 Ok b -> 249 Json.Decode.succeed b 250 251 Err err -> 252 Json.Decode.fail err 253 ) 254 decoder