
   0 | module Web.MVC.View
   1 | 
   2 | import Control.Monad.Either.Extra
   3 | import Data.Either
   4 | import Data.Maybe
   5 | import Data.String
   6 | import JS
   7 | import Text.CSS
   8 | import Text.HTML
   9 | import Web.Dom
  10 | import Web.Html
  11 | import Web.MVC.Canvas
  12 | import Web.MVC.Cmd
  13 | import Web.MVC.Event
  14 | import Web.MVC.Util
  15 | 
  16 | %default total
  17 | 
  18 | %foreign "browser:lambda:(e,f,w) => {const o = new ResizeObserver((es) => f(e.getBoundingClientRect())(w));o.observe(e)}"
  19 | prim__observeResize : Element -> (DOMRect -> PrimIO ()) -> PrimIO ()
  20 | 
  21 | --------------------------------------------------------------------------------
  22 | --          Registering Events
  23 | --------------------------------------------------------------------------------
  24 | 
  25 | ||| Low level method for registering `DOMEvents` at
  26 | ||| HTML elements.
  27 | |||
  28 | ||| Use this, for instance, to register `DOMEvents` at
  29 | ||| a HTMLElement of a static document.
  30 | export
  31 | registerDOMEvent :
  32 |      (e -> JSIO ())
  33 |   -> (preventDefault, stopPropagation : Bool)
  34 |   -> EventTarget
  35 |   -> DOMEvent e
  36 |   -> JSIO ()
  37 | registerDOMEvent h prev stop el de = case de of
  38 |   Input f      => inst "input" changeInfo f
  39 |   Change f     => inst "change" changeInfo f
  40 |   Click f      => inst "click" mouseInfo f
  41 |   DblClick f   => inst "dblclick" mouseInfo f
  42 |   KeyDown f    => inst "keydown" keyInfo f
  43 |   KeyUp f      => inst "keyup" keyInfo f
  44 |   Blur v       => inst "blur" {t = Event} (const $ pure v) Just
  45 |   Focus v      => inst "focus" {t = Event} (const $ pure v) Just
  46 |   MouseDown f  => inst "mousedown" mouseInfo f
  47 |   MouseUp f    => inst "mouseup" mouseInfo f
  48 |   MouseEnter f => inst "mouseenter" mouseInfo f
  49 |   MouseLeave f => inst "mouseleave" mouseInfo f
  50 |   MouseOver f  => inst "mouseover" mouseInfo f
  51 |   MouseOut f   => inst "mouseout" mouseInfo f
  52 |   MouseMove f  => inst "mousemove" mouseInfo f
  53 |   HashChange v => inst "hashchange" {t = Event} (const $ pure v) Just
  54 |   Scroll f     => inst "scroll" scrollInfo f
  55 |   Wheel f      => inst "wheel" wheelInfo f
  56 |   Resize f     => onresize f
  57 | 
  58 |   where
  59 |     inst :
  60 |          {0 t,b : _}
  61 |       -> {auto c : SafeCast t}
  62 |       -> String
  63 |       -> (t -> JSIO b)
  64 |       -> (b -> Maybe e)
  65 |       -> JSIO ()
  66 |     inst {t} s conv f = do
  67 |       c <- callback {cb = EventListener} $ \e => do
  68 |         canc <- cancelable e
  69 |         bubl <- bubbles e
  70 |         when (canc && prev) (preventDefault e)
  71 |         when (bubl && stop) (stopPropagation e)
  72 |         va <- tryCast_ t "Web.MVC.View.inst" e
  73 |         conv va >>= maybe (pure ()) h . f
  74 | 
  75 |       addEventListener el s (Just c)
  76 | 
  77 |     onresize : (Rect -> Maybe e) -> JSIO ()
  78 |     onresize f = do
  79 |       va <- tryCast_ Element "Web.MVC.View.onresize" el
  80 |       primIO $ prim__observeResize va $ \r => toPrim $ runJS $ do
  81 |         rect <- toRect r
  82 |         maybe (pure ()) h (f rect)
  83 | 
  84 | export
  85 | setAttribute : (e -> JSIO ()) -> Element -> Attribute t e -> JSIO ()
  86 | setAttribute h el (Id (Id value))   = setAttribute el "id" value
  87 | setAttribute h el (Str name value)  = setAttribute el name value
  88 | setAttribute h el (Bool name value) = case value of
  89 |   True  => setAttribute el name ""
  90 |   False => removeAttribute el name
  91 | setAttribute h el (Event_ prev stop ev) = registerDOMEvent h prev stop(up el) ev
  92 | setAttribute h el Empty      = pure ()
  93 | 
  94 | 
  95 | --------------------------------------------------------------------------------
  96 | --          Node Preparation
  97 | --------------------------------------------------------------------------------
  98 | 
  99 | addNodes :
 100 |      {auto 0 _ : JSType t}
 101 |   -> {auto 0 _ : Elem ParentNode (Types t)}
 102 |   -> (h        : e -> JSIO ())
 103 |   -> (doc      : Document)
 104 |   -> (parent   : t)
 105 |   -> (nodes    : List (Node e))
 106 |   -> JSIO ()
 107 | 
 108 | addNode :
 109 |      {auto 0 _ : JSType t}
 110 |   -> {auto 0 _ : Elem ParentNode (Types t)}
 111 |   -> (h        : e -> JSIO ())
 112 |   -> (doc      : Document)
 113 |   -> (parent   : t)
 114 |   -> (node     : Node e)
 115 |   -> JSIO ()
 116 | addNode h doc p (El {tag} _ xs ys) = do
 117 |   n <- createElement doc tag
 118 |   append p [inject $ n :> Node]
 119 |   addNodes h doc n ys
 120 |   traverseList_ (setAttribute h n) xs
 121 | 
 122 | addNode h doc p (Raw str) = do
 123 |   el <- createElement doc "template"
 124 |   Just temp <- pure (castTo HTMLTemplateElement el) | Nothing => pure ()
 125 |   innerHTML temp .= str
 126 |   c         <- content temp
 127 |   append p [inject $ c :> Node]
 128 | 
 129 | addNode h doc p (Text str) = append p [inject str]
 130 | 
 131 | addNode h doc p Empty      = pure ()
 132 | 
 133 | addNodes h doc p = assert_total $ traverseList_ (addNode h doc p)
 134 | 
 135 | setupNodes :
 136 |      (Element -> DocumentFragment -> JSIO ())
 137 |   -> Ref t
 138 |   -> List (Node e)
 139 |   -> Cmd e
 140 | setupNodes adj r ns = C $ \h => do
 141 |   doc  <- document
 142 |   elem <- castElementByRef {t = Element} r
 143 |   df   <- createDocumentFragment doc
 144 |   addNodes h doc df ns
 145 |   adj elem df
 146 | 
 147 | %inline
 148 | setupNode :
 149 |      (Element -> DocumentFragment -> JSIO ())
 150 |   -> Ref t
 151 |   -> Node e
 152 |   -> Cmd e
 153 | setupNode adj r n = setupNodes adj r [n]
 154 | 
 155 | ||| Sets up the reactive behavior of the given `Node`s and
 156 | ||| inserts them as the children of the given target.
 157 | export %inline
 158 | children : Ref t -> List (Node e) -> Cmd e
 159 | children = setupNodes replaceChildren
 160 | 
 161 | ||| Sets up the reactive behavior of the given `Node` and
 162 | ||| inserts it as the only child of the given target.
 163 | export %inline
 164 | child : Ref t -> Node e -> Cmd e
 165 | child = setupNode replaceChildren
 166 | 
 167 | ||| Replaces the given node's children with a text node
 168 | ||| displaying the given string.
 169 | export %inline
 170 | text : Ref t -> String -> Cmd e
 171 | text r = child r . Text
 172 | 
 173 | ||| Replaces the given node's children with a text node
 174 | ||| showing the given value.
 175 | export %inline
 176 | show : Show b => Ref t -> b -> Cmd e
 177 | show r = text r . show
 178 | 
 179 | ||| Replaces the given node's children with the raw
 180 | ||| HTML passed as a string argument.
 181 | export %inline
 182 | raw : Ref t -> String -> Cmd e
 183 | raw r = child r . Raw
 184 | 
 185 | ||| Replaces the given `<style>` node's CSS rules.
 186 | export
 187 | style : Ref Tag.Style -> List (Rule 1) -> Cmd e
 188 | style r rules =
 189 |   let str := fastUnlines $ map interpolate rules
 190 |    in raw r str
 191 | 
 192 | ||| Sets up the reactive behavior of the given `Node`s and
 193 | ||| inserts them after the given child node.
 194 | export %inline
 195 | afterMany : Ref t -> List (Node e) -> Cmd e
 196 | afterMany = setupNodes afterDF
 197 | 
 198 | ||| Sets up the reactive behavior of the given `Node` and
 199 | ||| inserts it after the given child node.
 200 | export %inline
 201 | after : Ref t -> Node e -> Cmd e
 202 | after = setupNode afterDF
 203 | 
 204 | ||| Sets up the reactive behavior of the given `Node`s and
 205 | ||| inserts them before the given child node.
 206 | export %inline
 207 | beforeMany : Ref t -> List (Node e) -> Cmd e
 208 | beforeMany = setupNodes beforeDF
 209 | 
 210 | ||| Sets up the reactive behavior of the given `Node` and
 211 | ||| inserts it before the given child node.
 212 | export %inline
 213 | before : Ref t -> Node e -> Cmd e
 214 | before = setupNode beforeDF
 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 %inline
 219 | appendMany : Ref t -> List (Node e) -> Cmd e
 220 | appendMany = setupNodes appendDF
 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 %inline
 225 | append : Ref t -> Node e -> Cmd e
 226 | append = setupNode appendDF
 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 %inline
 231 | prependMany : Ref t -> List (Node e) -> Cmd e
 232 | prependMany = setupNodes prependDF
 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 %inline
 237 | prepend : Ref t -> Node e -> Cmd e
 238 | prepend = setupNode prependDF
 239 | 
 240 | ||| Sets up the reactive behavior of the given `Node`s and
 241 | ||| replaces the given element.
 242 | export %inline
 243 | replaceMany : Ref t -> List (Node e) -> Cmd e
 244 | replaceMany = setupNodes replaceDF
 245 | 
 246 | ||| Sets up the reactive behavior of the given `Node` and
 247 | ||| replaces the given element.
 248 | export %inline
 249 | replace : Ref t -> Node e -> Cmd e
 250 | replace = setupNode replaceDF
 251 | 
 252 | ||| Sets a custom validity message at the given node.
 253 | export %inline
 254 | validityMsg : Ref t -> ValidityTag t => String -> Cmd e
 255 | validityMsg r s = cmd_ $ setValidityMessage r s
 256 | 
 257 | ||| Sets or unsets a custom validity message at the given node.
 258 | export
 259 | validate : Ref t -> ValidityTag t => Either String b -> Cmd e
 260 | validate r (Left s)  = validityMsg r s
 261 | validate r (Right s) = validityMsg r ""
 262 | 
 263 | ||| Sets an attribute at the given node.
 264 | export
 265 | attr : Ref t -> Attribute t e -> Cmd e
 266 | attr r a = C $ \h => castElementByRef r >>= \el => setAttribute h el a
 267 | 
 268 | ||| Sets the `checked` property of the given element
 269 | export
 270 | checked : Ref Tag.Input -> Bool -> Cmd e
 271 | checked r b = C $ \h => castElementByRef r >>= (HTMLInputElement.checked =. b)
 272 | 
 273 | ||| Sets the `disabled` attribute of the given element
 274 | export %inline
 275 | disabled : Ref t -> Bool -> Cmd e
 276 | disabled r = attr r . disabled
 277 | 
 278 | ||| Sets the `disabled` attribute of the given element
 279 | ||| if the given values is a `Left`.
 280 | |||
 281 | ||| This is useful for disabling components such as buttons
 282 | ||| in the UI in case of invalid user input.
 283 | export %inline
 284 | disabledE : {0 a,b : _} -> Ref t -> Either a b -> Cmd e
 285 | disabledE r = disabled r . isLeft
 286 | 
 287 | ||| Sets the `disabled` attribute of the given element
 288 | ||| if the given values is a `Nothing`.
 289 | |||
 290 | ||| This is useful for disabling components such as buttons
 291 | ||| in the UI in case of invalid user input.
 292 | export %inline
 293 | disabledM : {0 a : _} -> Ref t -> Maybe a -> Cmd e
 294 | disabledM r = disabled r . isNothing
 295 | 
 296 | ||| Removes the given element from the DOM.
 297 | export
 298 | remove : Ref t -> Cmd e
 299 | remove r = cmd_ (castElementByRef {t = Element} r >>= remove)
 300 | 
 301 | ||| Sets the `value` attribute of the given element.
 302 | export %inline
 303 | value : Ref t -> ValueTag t => String -> Cmd e
 304 | value r s = cmd_ (setValue r s)
 305 | 
 306 | ||| Renders a scene at a canvas element
 307 | export %inline
 308 | renderWithMetrics : Ref Tag.Canvas -> (TextMeasure => CanvasDims -> Scene) -> Cmd e
 309 | renderWithMetrics r s = cmd_ (renderWithMetrics r s)
 310 | 
 311 | ||| Renders a scene at a canvas element
 312 | export %inline
 313 | renderWithDims : Ref Tag.Canvas -> (CanvasDims -> Scene) -> Cmd e
 314 | renderWithDims r s = cmd_ (render r s)
 315 | 
 316 | ||| Renders a scene at a canvas element
 317 | export %inline
 318 | render : Ref Tag.Canvas -> Scene -> Cmd e
 319 | render r = renderWithDims r . const
 320 | 
 321 | ||| Adjusts the dimensions of a `HTMLCanvasElement`
 322 | export
 323 | setCanvasDims : Ref Tag.Canvas -> CanvasDims -> Cmd e
 324 | setCanvasDims r d =
 325 |   cmd_ $ do
 326 |     c <- castElementByRef {t = HTMLCanvasElement} r
 327 |     set (height c) (cast d.cheight)
 328 |     set (width c) (cast d.cwidth)
 329 | 
 330 | 
 331 | ||| Focus the given HTMLElemet
 332 | export %inline
 333 | focus : Ref t -> Cmd e
 334 | focus r = cmd_ (castElementByRef {t = HTMLElement} r >>= HTMLOrSVGElement.focus)
 335 | 
 336 | ||| Blur (lose focus on) the given HTMLElemet
 337 | export %inline
 338 | blur : Ref t -> Cmd e
 339 | blur r = cmd_ (castElementByRef {t = HTMLElement} r >>= HTMLOrSVGElement.blur)
 340 | 
 341 | ||| Provides a `TextMeasure` utility from the given `Canvas` to run the given
 342 | ||| command.
 343 | export
 344 | withMetricsFor : Ref Tag.Canvas -> (TextMeasure => Cmd e) -> Cmd e
 345 | withMetricsFor ref c =
 346 |   C $ \h => do
 347 |     canvas <- castElementByRef {t = HTMLCanvasElement} ref
 348 |     ctxt   <- context2D canvas
 349 |     run (withMetrics ctxt c) h
 350 |