
   0 | module Web.Async.View
   1 | 
   2 | import Data.Linear.Traverse1
   3 | import Data.Either
   4 | import Data.Maybe
   5 | import Data.String
   6 | import IO.Async.Logging
   7 | import JS
   8 | import Syntax.T1
   9 | import Text.CSS
  10 | import Text.HTML
  11 | import Text.HTML.DomID
  12 | import Web.Async.Event
  13 | import Web.Async.Util
  14 | import Web.Internal.Types
  15 | 
  16 | %hide Data.Linear.(.)
  17 | %default total
  18 | 
  19 | --------------------------------------------------------------------------------
  20 | -- FFI
  21 | --------------------------------------------------------------------------------
  22 | 
  23 | %foreign "browser:lambda:(e,f,w) => {const o = new ResizeObserver((es) => f(e.getBoundingClientRect())(w));o.observe(e)}"
  24 | prim__observeResize : Element -> (DOMRect -> PrimIO ()) -> PrimIO ()
  25 | 
  26 | %foreign "browser:lambda:(e,f,w) => {const o = new MutationObserver(() => {if (!e.isConnected) {o.disconnect(); f(w);}}); o.observe(document.body, {childList : true, subtree : true});}"
  27 | prim__observeRemove : Element -> PrimIO () -> PrimIO ()
  28 | 
  29 | export
  30 | %foreign "browser:lambda:x=>x.bubbles?1:0"
  31 | bubbles : Event -> Bool
  32 | 
  33 | export
  34 | %foreign "browser:lambda:x=>x.cancelable?1:0"
  35 | cancelable : Event -> Bool
  36 | 
  37 | %foreign "browser:lambda:(x,s,f,w)=>x.addEventListener(s,\e => f(e)(w))"
  38 | prim__addlistener : EventTarget -> String -> (Event -> PrimIO ()) -> PrimIO ()
  39 | 
  40 | %foreign "browser:lambda:(x,w)=>x.preventDefault()"
  41 | prim__preventDefault : Event -> PrimIO ()
  42 | 
  43 | %foreign "browser:lambda:(x,w)=>x.stopPropagation()"
  44 | prim__stopPropagation : Event -> PrimIO ()
  45 | 
  46 | --------------------------------------------------------------------------------
  47 | -- IO1
  48 | --------------------------------------------------------------------------------
  49 | 
  50 | export %inline
  51 | addEventListener : EventTarget -> String -> (Event -> IO1 ()) -> IO1 ()
  52 | addEventListener et ev cb = ffi $ prim__addlistener et ev (primRun . cb)
  53 | 
  54 | export %inline
  55 | preventDefault : Event -> IO1 ()
  56 | preventDefault ev = ffi $ prim__preventDefault ev
  57 | 
  58 | export %inline
  59 | stopPropagation : Event -> IO1 ()
  60 | stopPropagation ev = ffi $ prim__stopPropagation ev
  61 | 
  62 | --------------------------------------------------------------------------------
  63 | -- Event Handler
  64 | --------------------------------------------------------------------------------
  65 | 
  66 | ||| Low level method for registering `DOMEvents` at
  67 | ||| HTML elements.
  68 | |||
  69 | ||| Use this, for instance, to register `DOMEvents` at
  70 | ||| a HTMLElement of a static document.
  71 | export
  72 | registerDOMEvent :
  73 |      {auto h : Sink e}
  74 |   -> (preventDefault, stopPropagation : Bool)
  75 |   -> EventTarget
  76 |   -> DOMEvent e
  77 |   -> IO1 ()
  78 | registerDOMEvent prev stop el de =
  79 |   case de of
  80 |     Input f      => inst "input" changeInfo f
  81 |     Change f     => inst "change" changeInfo f
  82 |     Click f      => inst "click" mouseInfo f
  83 |     DblClick f   => inst "dblclick" mouseInfo f
  84 |     KeyDown f    => inst "keydown" keyInfo f
  85 |     KeyUp f      => inst "keyup" keyInfo f
  86 |     Blur v       => inst "blur" {t = Event} (const $ pure v) Just
  87 |     Focus v      => inst "focus" {t = Event} (const $ pure v) Just
  88 |     Close v      => inst "close" {t = Event} (const $ pure v) Just
  89 |     MouseDown f  => inst "mousedown" mouseInfo f
  90 |     MouseUp f    => inst "mouseup" mouseInfo f
  91 |     MouseEnter f => inst "mouseenter" mouseInfo f
  92 |     MouseLeave f => inst "mouseleave" mouseInfo f
  93 |     MouseOver f  => inst "mouseover" mouseInfo f
  94 |     MouseOut f   => inst "mouseout" mouseInfo f
  95 |     MouseMove f  => inst "mousemove" mouseInfo f
  96 |     HashChange v => inst "hashchange" {t = Event} (const $ pure v) Just
  97 |     Scroll f     => inst "scroll" scrollInfo f
  98 |     Wheel f      => inst "wheel" wheelInfo f
  99 |     Resize f     => onresize f
 100 |     Remove v     => onremove v
 101 | 
 102 |   where
 103 |     inst :
 104 |          {0 t,b : _}
 105 |       -> {auto c : SafeCast t}
 106 |       -> String
 107 |       -> (t -> IO1 b)
 108 |       -> (b -> Maybe e)
 109 |       -> IO1 ()
 110 |     inst {t} s conv f =
 111 |      let cb : Event -> IO1 ()
 112 |          cb e = T1.do
 113 |            when1 (cancelable e && prev) (preventDefault e)
 114 |            when1 (bubbles e && stop) (stopPropagation e)
 115 |            let Just vt := castTo t e | Nothing => pure ()
 116 |            vb <- conv vt
 117 |            maybe (pure ()) h.sink1 (f vb)
 118 | 
 119 |       in addEventListener el s cb
 120 | 
 121 |     onresize : (Rect -> Maybe e) -> IO1 ()
 122 |     onresize f =
 123 |      let Just va := castTo Element el | Nothing => pure ()
 124 |       in ffi $ prim__observeResize va $ \r => primRun $
 125 |            toRect r >>= maybe (pure ()) h.sink1 . f
 126 | 
 127 |     onremove : e -> IO1 ()
 128 |     onremove v =
 129 |      let Just va := castTo Element el | Nothing => pure ()
 130 |       in ffi (prim__observeRemove va (primRun (h.sink1 v)))
 131 | 
 132 | export
 133 | setAttribute : Element -> Attribute t -> IO1 ()
 134 | setAttribute el (Id (Id v))       = ffi $ prim__setAttribute el "id" v
 135 | setAttribute el (Str name v)      = ffi $ prim__setAttribute el name v
 136 | setAttribute el (Bool name True)  = ffi $ prim__setAttribute el name ""
 137 | setAttribute el (Bool name False) = ffi $ prim__removeAttribute el name
 138 | setAttribute el (Event_ p s ev)   = registerDOMEvent p s (up el) ev
 139 | setAttribute el Empty             = pure ()
 140 | 
 141 | --------------------------------------------------------------------------------
 142 | -- Node Preparation
 143 | --------------------------------------------------------------------------------
 144 | 
 145 | addNodes : ParentNode -> HTMLNodes -> IO1 ()
 146 | 
 147 | addNode : ParentNode -> HTMLNode -> IO1 ()
 148 | addNode p (El {tag} _ xs ys) t =
 149 |  let n # t := ffi (prim__createElement tag) t
 150 |      _ # t := ffi (prim__append p (up n)) t
 151 |      _ # t := addNodes (up n) ys t
 152 |   in traverse1_ (setAttribute n) xs t
 153 | addNode p (EEl {tag} _ xs) t =
 154 |  let n # t := ffi (prim__createElement tag) t
 155 |      _ # t := ffi (prim__append p (up n)) t
 156 |   in traverse1_ (setAttribute n) xs t
 157 | 
 158 | addNode p (Raw s) t =
 159 |  let el # t := ffi (prim__createElement "template") t
 160 |      Just temp := castTo HTMLTemplateElement el | Nothing => () # t
 161 |      _  # t := ffi (prim__setInnerHTML (up temp) s) t
 162 |      c  # t := ffi (prim__content temp) t
 163 |   in ffi (prim__append p (up c)) t
 164 | 
 165 | addNode p (Text s) t = ffi (prim__appendTxt p s) t
 166 | 
 167 | addNode p Empty      t = () # t
 168 | 
 169 | addNodes p = assert_total $ traverse1_ (addNode p)
 170 | 
 171 | parameters {auto has : Has JSErr es}
 172 | 
 173 |   %inline
 174 |   setupNodes : (Element -> Node -> JS es ()) -> Ref t -> HTMLNodes -> JS es ()
 175 |   setupNodes adj r ns = do
 176 |     elem <- castElementByRef {t = Element} r
 177 |     df   <- primIO prim__createDocumentFragment
 178 |     lift1 $ addNodes (up df) ns
 179 |     adj elem (up df)
 180 | 
 181 |   %inline
 182 |   setupNode :
 183 |        (Element -> Node -> JS es ())
 184 |     -> Ref t
 185 |     -> HTMLNode
 186 |     -> JS es ()
 187 |   setupNode adj r n = setupNodes adj r [n]
 188 | 
 189 |   ||| Sets up the reactive behavior of the given `Node`s and
 190 |   ||| inserts them as the children of the given target.
 191 |   export
 192 |   children : Ref t -> HTMLNodes -> JS es ()
 193 |   children = setupNodes (\el => replaceChildren (up el))
 194 | 
 195 |   ||| Sets up the reactive behavior of the given `Node` and
 196 |   ||| inserts it as the only child of the given target.
 197 |   export
 198 |   child : Ref t -> HTMLNode -> JS es ()
 199 |   child = setupNode (\el => replaceChildren (up el))
 200 | 
 201 |   ||| Replaces the given node's children with a text node
 202 |   ||| displaying the given string.
 203 |   export %inline
 204 |   text : Ref t -> String -> JS es ()
 205 |   text r = child r . Text
 206 | 
 207 |   ||| Replaces the given node's children with a text node
 208 |   ||| showing the given value.
 209 |   export %inline
 210 |   show : Show b => Ref t -> b -> JS es ()
 211 |   show r = text r . show
 212 | 
 213 |   ||| Replaces the given node's children with the raw
 214 |   ||| HTML passed as a string argument.
 215 |   export %inline
 216 |   raw : Ref t -> String -> JS es ()
 217 |   raw r = child r . Raw
 218 | 
 219 |   ||| Replaces the given `<style>` node's CSS rules.
 220 |   export
 221 |   style : Ref Tag.Style -> List (Rule 1) -> JS es ()
 222 |   style r = raw r . fastUnlines . map interpolate
 223 | 
 224 |   ||| Sets up the reactive behavior of the given `Node`s and
 225 |   ||| inserts them after the given child node.
 226 |   export
 227 |   afterMany : Ref t -> HTMLNodes -> JS es ()
 228 |   afterMany = setupNodes (\el => after (up el))
 229 | 
 230 |   ||| Sets up the reactive behavior of the given `Node` and
 231 |   ||| inserts it after the given child node.
 232 |   export
 233 |   after : Ref t -> HTMLNode -> JS es ()
 234 |   after = setupNode (\el => after (up el))
 235 | 
 236 |   ||| Sets up the reactive behavior of the given `Node`s and
 237 |   ||| inserts them before the given child node.
 238 |   export
 239 |   beforeMany : Ref t -> HTMLNodes -> JS es ()
 240 |   beforeMany = setupNodes (\el => before (up el))
 241 | 
 242 |   ||| Sets up the reactive behavior of the given `Node` and
 243 |   ||| inserts it before the given child node.
 244 |   export
 245 |   before : Ref t -> HTMLNode -> JS es ()
 246 |   before = setupNode (\el => before (up el))
 247 | 
 248 |   ||| Sets up the reactive behavior of the given `Node`s and
 249 |   ||| appends them to the given element's list of children
 250 |   export
 251 |   appendMany : Ref t -> HTMLNodes -> JS es ()
 252 |   appendMany = setupNodes (\el => append (up el))
 253 | 
 254 |   ||| Sets up the reactive behavior of the given `Node` and
 255 |   ||| appends it to the given element's list of children
 256 |   export
 257 |   append : Ref t -> HTMLNode -> JS es ()
 258 |   append = setupNode (\el => append (up el))
 259 | 
 260 |   ||| Sets up the reactive behavior of the given `Node`s and
 261 |   ||| prepends them to the given element's list of children
 262 |   export
 263 |   prependMany : Ref t -> HTMLNodes -> JS es ()
 264 |   prependMany = setupNodes (\el => prepend (up el))
 265 | 
 266 |   ||| Sets up the reactive behavior of the given `Node` and
 267 |   ||| prepends it to the given element's list of children
 268 |   export
 269 |   prepend : Ref t -> HTMLNode -> JS es ()
 270 |   prepend = setupNode (\el => prepend (up el))
 271 | 
 272 |   ||| Sets up the reactive behavior of the given `Node`s and
 273 |   ||| replaces the given element.
 274 |   export
 275 |   replaceMany : Ref t -> HTMLNodes -> JS es ()
 276 |   replaceMany = setupNodes (\el => replace (up el))
 277 | 
 278 |   ||| Sets up the reactive behavior of the given `Node` and
 279 |   ||| replaces the given element.
 280 |   export
 281 |   replace : Ref t -> HTMLNode -> JS es ()
 282 |   replace = setupNode (\el => replace (up el))
 283 | 
 284 |   ||| Removes the given element from the DOM.
 285 |   export
 286 |   remove : Ref t -> JS es ()
 287 |   remove r =
 288 |     castElementByRef {t = Element} r >>= \el => primIO (prim__remove (up el))
 289 | 
 290 |   ||| Sets an attribute at the given node.
 291 |   export
 292 |   attr : Ref t -> Attribute t -> JS es ()
 293 |   attr r a = castElementByRef r >>= \el => lift1 $ setAttribute el a
 294 | 
 295 | 
 296 |   ||| Sets the `checked` property of the given element
 297 |   export
 298 |   checked : Ref Tag.Input -> Bool -> JS es ()
 299 |   checked r b =
 300 |     castElementByRef r >>= \el => primIO (prim__setChecked el $ toFFI b)
 301 | 
 302 |   ||| Sets the `disabled` attribute of the given element
 303 |   export %inline
 304 |   disabled : Ref t -> Bool -> JS es ()
 305 |   disabled r = attr r . disabled
 306 | 
 307 |   ||| Sets the `disabled` attribute of the given element
 308 |   ||| if the given values is a `Left`.
 309 |   |||
 310 |   ||| This is useful for disabling components such as buttons
 311 |   ||| in the UI in case of invalid user input.
 312 |   export %inline
 313 |   disabledE : {0 a,b : _} -> Ref t -> Either a b -> JS es ()
 314 |   disabledE r = disabled r . isLeft
 315 | 
 316 |   ||| Sets the `disabled` attribute of the given element
 317 |   ||| if the given values is a `Nothing`.
 318 |   |||
 319 |   ||| This is useful for disabling components such as buttons
 320 |   ||| in the UI in case of invalid user input.
 321 |   export %inline
 322 |   disabledM : {0 a : _} -> Ref t -> Maybe a -> JS es ()
 323 |   disabledM r = disabled r . isNothing
 324 | 
 325 |   ||| Focus the given HTMLElemet
 326 |   export %inline
 327 |   focus : Ref t -> JS es ()
 328 |   focus r = castElementByRef {t = HTMLElement} r >>= focus
 329 | 
 330 |   ||| Blur (lose focus on) the given HTMLElemet
 331 |   export %inline
 332 |   blur : Ref t -> JS es ()
 333 |   blur r = castElementByRef {t = HTMLElement} r >>= blur
 334 | 
 335 |   ||| Show the given dialog element.
 336 |   export %inline
 337 |   dialogShow : Ref t -> JS es ()
 338 |   dialogShow r = castElementByRef {t = HTMLDialogElement} r >>= dialogShow
 339 | 
 340 |   ||| Show the given dialog element in "modal" mode.
 341 |   export %inline
 342 |   showModal : Ref t -> JS es ()
 343 |   showModal r = castElementByRef {t = HTMLDialogElement} r >>= showModal
 344 | 
 345 |   ||| Close the given dialog element.
 346 |   export %inline
 347 |   dialogClose : Ref t -> JS es ()
 348 |   dialogClose r = castElementByRef {t = HTMLDialogElement} r >>= dialogClose
 349 | 
 350 | --------------------------------------------------------------------------------
 351 | -- Utils with error handling
 352 | --------------------------------------------------------------------------------
 353 | 
 354 | parameters {auto lg  : Loggable JS JSErr}
 355 | 
 356 |   export %inline
 357 |   elemChildren : DomID -> HTMLNodes -> JS [] ()
 358 |   elemChildren i = logErrs . children {es = [JSErr]} (elemRef i)
 359 | 
 360 |   export %inline
 361 |   elemChild : DomID -> HTMLNode -> JS [] ()
 362 |   elemChild i = logErrs . child {es = [JSErr]} (elemRef i)
 363 | 
 364 |   export %inline
 365 |   elemAppend : DomID -> HTMLNode -> JS [] ()
 366 |   elemAppend i = logErrs . append {es = [JSErr]} (elemRef i)
 367 | 
 368 |   export %inline
 369 |   elemAppendMany : DomID -> HTMLNodes -> JS [] ()
 370 |   elemAppendMany i = logErrs . appendMany {es = [JSErr]} (elemRef i)
 371 | 
 372 |   export %inline
 373 |   elemPrepend : DomID -> HTMLNode -> JS [] ()
 374 |   elemPrepend i = logErrs . prepend {es = [JSErr]} (elemRef i)
 375 | 
 376 |   export %inline
 377 |   elemPrependMany : DomID -> HTMLNodes -> JS [] ()
 378 |   elemPrependMany i = logErrs . prependMany {es = [JSErr]} (elemRef i)
 379 | 
 380 |   export %inline
 381 |   clearElem : DomID -> JS [] ()
 382 |   clearElem i = elemChildren i []
 383 | 
 384 |   export %inline
 385 |   removeElem : DomID -> JS [] ()
 386 |   removeElem = logErrs . remove {es = [JSErr]} . elemRef
 387 | 
 388 |   export %inline
 389 |   replaceElem : DomID -> HTMLNode -> JS [] ()
 390 |   replaceElem i = logErrs . replace {es = [JSErr]} (elemRef i)
 391 | 
 392 |   export %inline
 393 |   btnAttr : DomID -> Attribute Tag.Button -> JS [] ()
 394 |   btnAttr v a = logErrs $ attr {es = [JSErr]} (btnRef v) a
 395 |