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