packages feed

haskell-halogen-core (empty) → 0.9.0

raw patch · 84 files changed

+9080/−0 lines, 84 filesdep +asyncdep +basedep +bytestring

Dependencies added: async, base, bytestring, clay, containers, data-default, deepseq, free, hashable, haskell-halogen-core, hspec, kan-extensions, mtl, protolude, random, row-types, safe-exceptions, stm, text, time, transformers, unliftio, unordered-containers, uuid-types

Files

+ CHANGELOG.md view
@@ -0,0 +1,58 @@+# Revision history for haskell-halogen++## 0.9.0 - 2025-05-30++- Update `clay`+- Insert `base` and `clay` version bounds+- Release version++## 0.8.0 - 2025-02-04++- Add `Halogen.Portal` for teleporting children across DOM elements (i.e. to body)+- Revert adding input to `Slot` type+- Add Java Swing - inspired CSS layout managers ++## 0.7.0 -- 2025-01-18++Remove dependency on `clock` which doesn't build on darwin++## 0.6.1 -- 2025-01-16++Fix `foreignToBool`++## 0.6.0 -- 2025-01-16++- Add `Halogen.Svg` modules+- Use `RequiredTypeArguments` for slot proxies++## 0.5.1 -- 2025-01-15++Fix `for` HTML property.++## 0.5.0 -- 2025-01-15++Allow monadic `initialState` function.++## 0.4.0 -- 2025-01-10++Fix unnecessary DOM replaces in foreign code++## 0.3.2 -- 2025-01-10++Add `-fexpose-all-unfoldings` to JS build and export `label` and `p` mistakenly hidden from `Halogen.HTML`++## 0.3.1 -- 2025-01-09++Use `isTrue#` for `reallyUnsafePtrEquality#`++## 0.3.0 -- 2025-01-08++Fix bugs related to style and class rendering, add IO specialisation, add `input` type to `H.Slot` to avoid `unsafeCoerce`.++## 0.2.0 -- 2024-12-28++More complete release, with events, properties and Clay integration++## 0.1.0 -- 2024-12-21++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,201 @@+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ NOTICE view
@@ -0,0 +1,50 @@+This project, `haskell-halogen-core`, is based on code from the PureScript Halogen library, licensed under Apache 2.0, and adapted to GHC Haskell.+See https://github.com/purescript-halogen/purescript-halogen/ for the original project.++It also includes code from the following peer libraries:++**Licensed under Apache 2.0:**+- https://github.com/purescript-halogen/purescript-halogen-vdom+- https://github.com/purescript-halogen/purescript-dom-indexed++**Licensed under MIT:**+- https://github.com/purescript-web/purescript-web-dom+- https://github.com/purescript-web/purescript-web-events+- https://github.com/purescript-web/purescript-web-uievents+- https://github.com/purescript-web/purescript-web-html+- https://github.com/JordanMartinez/purescript-halogen-svg-elems+- https://github.com/thomashoneyman/purescript-halogen-portal++The modules are named mostly in the same way as in the original projects.++---++### **License Notices**+#### **Apache 2.0 License**+© 2025 [Your Name or Organization]  +Licensed under the Apache License, Version 2.0 (the "License");  +you may not use this file except in compliance with the License.  +You may obtain a copy of the License at:++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software  +distributed under the License is distributed on an "AS IS" BASIS,  +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.  +See the License for the specific language governing permissions and  +limitations under the License.++#### **MIT-Licensed Code Attribution**+This project includes portions of MIT-licensed code. The full MIT license text for each MIT-licensed dependency is included in their respective repositories:++> "Permission is hereby granted, free of charge, to any person obtaining a copy  +> of this software and associated documentation files (the 'Software'), to deal  +> in the Software without restriction, including without limitation the rights  +> to use, copy, modify, merge, publish, distribute, sublicense, and/or sell  +> copies of the Software, and to permit persons to whom the Software is  +> furnished to do so, subject to the following conditions:  +>   +> The above copyright notice and this permission notice shall be included in  +> all copies or substantial portions of the Software."++For full details, see the original repositories listed above.
+ app/Main.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QualifiedDo #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Main where++import Clay qualified as C+import DOM.HTML.Indexed qualified as I+import Data.Functor.Coyoneda+import Data.NT+import Data.Row+import Halogen as H+import Halogen.Component.Debounced+import Halogen.HTML as HH+import Halogen.HTML.Events as HE+import Halogen.HTML.Layout as L+import Halogen.HTML.Layout.BoxLayout+import Halogen.HTML.Layout.GridBagLayout+import Halogen.HTML.Properties as HP+import Halogen.Subscription qualified as HS+import Halogen.VDom.DOM.Monad+import Protolude hiding (log)+import UnliftIO (MonadUnliftIO)++#if defined(javascript_HOST_ARCH)+import Halogen.IO.Util as HA+import Halogen.VDom.Driver (runUI)+#endif++attachComponent :: IO (HalogenSocket Query Int IO)+logStr :: Text -> IO ()++#if defined(javascript_HOST_ARCH)+attachComponent =+  HA.awaitBody >>= runUI component ()+logStr = log+#else+attachComponent = panic "This module can only be run on JavaScript"+logStr = putStrLn+#endif++main :: IO ()+main = do+  HalogenSocket {messages} <- attachComponent++  void $ HS.subscribe messages $ \st ->+    logStr $ "State changed: " <> show st++{-+forever $ do+  threadDelay 5_000_000+  void $ query (IncrementQ ())+  threadDelay 5_000_000+  void $ query (DecrementQ ())+  -}++data Action = Increment Int | Decrement Int | Init++type Slots = ("debounced" .== H.Slot VoidF () ())++data Query a = IncrementQ a | DecrementQ a++component :: forall m. (MonadDOM m, MonadUnliftIO m) => H.Component Query () Int m+component =+  H.mkComponent $+    H.ComponentSpec+      { initialState+      , render+      , eval = H.mkEval $ H.defaultEval {handleAction, handleQuery, initialize = Just Init}+      }+  where+    initialState _ = pure 0++    render :: Int -> H.ComponentHTML Action Slots m+    render state =+      L.runLayoutM (defGridBagSettings {rows = 3, cols = 3}) $ L.do+        L.with (GridBagLayoutConstraints 1 1 2 2) $ L.runLayoutM Vertical $ L.do+          HH.button [HE.onClick $ const $ Decrement 1] [HH.text "-"]+          L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Decrement 2] [HH.text "--"]+          HH.div_ [HH.text $ show state]+          HH.button [HE.onClick $ const $ Increment 1] [HH.text "+"]+          L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Increment 2] [HH.text "++"]+          slot_ "debounced" () debComp ()+          HH.div_ [HH.text "Test sentinel element"]+          L.end++        L.with (GridBagLayoutConstraints 3 3 1 1) $+          HH.div [HP.style $ C.border (C.px 2) C.solid C.black] [HH.text "Banner!"]++        L.end++    handleQuery = \case+      IncrementQ cb -> do+        modify (+ 1)+        get >>= H.raise+        pure $ Just cb+      DecrementQ cb -> do+        modify (subtract 1)+        get >>= H.raise+        pure $ Just cb++    handleAction = \case+      Init ->+        lift $ log "Initialized"+      Increment n -> do+        modify (+ n)+        get >>= H.raise+      Decrement n -> do+        modify (subtract n)+        get >>= H.raise++---------------------------------------++newtype DebChanged = DebChanged Text++debComp :: (MonadDOM m, MonadUnliftIO m) => Component VoidF () () m+debComp = unsafeMkDebouncedComponent 0.5 $ ComponentSpec {initialState, render, eval}+  where+    initialState _ = pure ""++    render txt = runLayoutM Vertical $ L.do+      HH.div_ [HH.text "The text below is debounced"]+      HH.div_ [HH.text $ "Input content: " <> txt]+      HH.input+        [ HP.type_ I.InputText+        , HP.value txt+        , HP.style $ C.width C.auto+        , HE.onInputValueChange $ Just . DebChanged+        ]+      L.end++    eval = NT $ \case+      Initialize a -> pure a+      Finalize a -> pure a+      Receive _i a -> pure a+      Action (DebChanged str) a ->+        put str $> a+      Query (Coyoneda _req _fct) _f -> panic "Void2"
+ haskell-halogen-core.cabal view
@@ -0,0 +1,197 @@+cabal-version:      3.0+name:               haskell-halogen-core+version:            0.9.0+synopsis:           Haskell port of purescript-halogen library+homepage:           https://github.com/Swordlash/haskell-halogen+license:            Apache-2.0+license-file:       LICENSE+author:             Mateusz Goślinowski+maintainer:         mateusz.goslinowski@gmail.com+category:           Web+extra-source-files: CHANGELOG.md, NOTICE++flag trace-dom+  description: Enable tracing of DOM operations+  default: False+  manual: True++common commons+  build-depends:    +      base >= 4.20 && < 5, +      free, +      transformers, +      mtl, +      text, +      protolude, +      random, +      time, +      bytestring, +      stm, +      deepseq, +      unordered-containers, +      async,+      row-types, +      hashable, +      containers, +      kan-extensions, +      uuid-types, +      unliftio, +      safe-exceptions, +      clay >= 0.16.0, +      data-default+  +  default-language: GHC2021+  ghc-options: -Wall -Wextra -Wcompat -Wno-partial-type-signatures -Wterm-variable-capture++  default-extensions:+      RankNTypes+      GeneralizedNewtypeDeriving+      MultiParamTypeClasses+      FunctionalDependencies+      FlexibleContexts+      FlexibleInstances+      UndecidableInstances+      GADTs+      DeriveFunctor+      DerivingStrategies+      NoImplicitPrelude+      KindSignatures+      DataKinds+      OverloadedStrings+      TypeOperators+      LambdaCase+      TypeFamilies+      OverloadedRecordDot+      RecordWildCards+      NamedFieldPuns+      DuplicateRecordFields+      PartialTypeSignatures+      DefaultSignatures+      StandaloneKindSignatures+      NoFieldSelectors+      DerivingVia+      CPP+      StrictData+      RequiredTypeArguments+      ExplicitNamespaces++library+    import: commons++    exposed-modules:+      Clay.Extra.Grid++      Control.Monad.Fork+      Control.Monad.Parallel+      Control.Monad.State.Delayed.Class+      Control.Monad.State.Delayed.Delayer+      Control.Monad.State.Delayed.Trans+      Control.Monad.State.Prim+      Control.Monad.UUID+      Data.Foreign+      Data.MediaType+      Data.NT++      DOM.HTML.Indexed++      Halogen++      Halogen.VDom+      Halogen.Data.Slot++      Halogen.IO.Driver+      Halogen.IO.Driver.Eval+      Halogen.IO.Driver.State+      Halogen.IO.Util++      Halogen.HTML+      Halogen.HTML.Core+      Halogen.HTML.Elements+      Halogen.HTML.Events+      Halogen.HTML.Layout+      Halogen.HTML.Layout.BorderLayout+      Halogen.HTML.Layout.BoxLayout+      Halogen.HTML.Layout.GridLayout+      Halogen.HTML.Layout.GridBagLayout+      Halogen.HTML.Layout.NoLayout+      Halogen.HTML.Properties+      Halogen.HTML.Properties.ARIA++      Halogen.Query+      Halogen.Query.ChildQuery+      Halogen.Query.Event+      Halogen.Query.Input+      Halogen.Query.HalogenM+      Halogen.Query.HalogenQ++      Halogen.VDom.DOM+      Halogen.VDom.DOM.Monad+      Halogen.VDom.DOM.Prop+      Halogen.VDom.Driver+      Halogen.VDom.Machine+      Halogen.VDom.Utils+      Halogen.VDom.Thunk+      Halogen.VDom.Types++      Halogen.Component+      Halogen.Component.Debounced+      Halogen.Subscription++      Halogen.Portal++      Halogen.Svg.Attributes+      Halogen.Svg.Elements+      Halogen.Svg.Indexed++      Web.Clipboard+      Web.Clipboard.ClipboardEvent+      Web.Clipboard.ClipboardEvent.EventTypes++      Web.DOM.Internal.Types+      Web.DOM.Element+      Web.DOM.ParentNode+      Web.Event.Internal.Types+      Web.Event.Event+      Web.HTML.Common+      Web.HTML.Event.DragEvent+      Web.HTML.Event.DragEvent.EventTypes+      Web.HTML.Event.EventTypes+      Web.HTML.HTMLDocument+      Web.HTML.HTMLDocument.ReadyState+      Web.UIEvent.FocusEvent+      Web.UIEvent.FocusEvent.EventTypes+      Web.UIEvent.KeyboardEvent+      Web.UIEvent.KeyboardEvent.EventTypes+      Web.UIEvent.MouseEvent+      Web.UIEvent.MouseEvent.EventTypes+      Web.UIEvent.PointerEvent+      Web.UIEvent.TouchEvent+      Web.UIEvent.WheelEvent+      Web.UIEvent.WheelEvent.EventTypes+      +    other-modules:+      HPrelude+    +    hs-source-dirs:   src++    if arch(javascript)+      js-sources:+        jsbits/monad_dom.js++      ghc-options: -fexpose-all-unfoldings+      +--      if flag(trace-dom)+--        jspp-options: -DHALOGEN_TRACE_DOM++executable halogen-core-prototype+  import: commons+  main-is:          Main.hs+  build-depends:    haskell-halogen-core+  hs-source-dirs:   app++test-suite Halogen-core-test+    import: commons+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Test.hs+    build-depends:    protolude, haskell-halogen-core, hspec
+ jsbits/monad_dom.js view
@@ -0,0 +1,221 @@+//#OPTIONS: CPP++function getNodeType(node) {+  return node.nodeType === 1 ? node.tagName : node.nodeType;+}++function js_create_text_node(text, document) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Creating text node with text: " + text);+#endif+  return document.createTextNode(text);+}++function js_set_text_content(text, node) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Setting text content to: " + text + " on node type: " + getNodeType(node));+#endif+  node.textContent = text;+}++function js_create_element(namespace, elemName, document) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Creating element with name: " + elemName);+#endif+  if (namespace === null) {+    return document.createElement(elemName);+  } else {+    return document.createElementNS(namespace, elemName);+  }+}++function js_insert_before(newNode, referenceNode, parentNode) {+  if (newNode !== referenceNode.previousSibling) {+#ifdef HALOGEN_TRACE_DOM+    console.log("Inserting node type: " + getNodeType(newNode) + " before reference node type: " + getNodeType(referenceNode));+#endif+    parentNode.insertBefore(newNode, referenceNode);+  } else {+#ifdef HALOGEN_TRACE_DOM+    console.log("Node type: " + getNodeType(newNode) + " is already before reference node type: " + getNodeType(referenceNode));+#endif+  }+}++function js_append_child(newNode, parentNode) {+  if (parentNode.lastChild !== newNode) {+#ifdef HALOGEN_TRACE_DOM+    console.log("Appending child node type: " + getNodeType(newNode) + " to parent node type: " + getNodeType(parentNode));+#endif+    parentNode.appendChild(newNode);+  } else {+#ifdef HALOGEN_TRACE_DOM+    console.log("Child node type: " + getNodeType(newNode) + " is already the last child of parent node type: " + getNodeType(parentNode));+#endif+  }+}++function js_replace_child(newNode, oldNode, parentNode) {+  if (newNode !== oldNode) {+#ifdef HALOGEN_TRACE_DOM+    console.log("Replacing old node type: " + getNodeType(oldNode) + " with new node type: " + getNodeType(newNode));+#endif+    parentNode.replaceChild(newNode, oldNode);+  } else {+#ifdef HALOGEN_TRACE_DOM+    console.log("New node is the same as the old node, no replacement needed.");+#endif+  }+}++function js_insert_child_ix(index, newNode, parentNode) {+  var n = parentNode.childNodes.item(index) || null;+  if (n !== newNode) {+#ifdef HALOGEN_TRACE_DOM+    console.log("Inserting child node type: " + getNodeType(newNode) + " at index: " + index + " in parent node type: " + getNodeType(parentNode));+#endif+    parentNode.insertBefore(newNode, n);+  } else {+#ifdef HALOGEN_TRACE_DOM+    console.log("Node is already at index: " + index);+#endif+  }+}++function js_remove_child(childNode, parentNode) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Removing child node type: " + getNodeType(childNode) + " from parent node type: " + getNodeType(parentNode));+#endif+  parentNode.removeChild(childNode);+}++function js_parent_node(node) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting parent node of node type: " + getNodeType(node));+#endif+  return node.parentNode;+}++function js_next_sibling(node) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting next sibling of node type: " + getNodeType(node));+#endif+  return node.nextSibling;+}++function js_set_attribute(namespace, attrName, value, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Setting attribute: " + attrName + " with value: " + value + " on element type: " + getNodeType(element));+#endif+  if (namespace === null) {+    element.setAttribute(attrName, value);+  } else {+    element.setAttributeNS(namespace, attrName, value);+  }+}++function js_set_property(propName, propValue, element) {+  if (element[propName] !== propValue) {+#ifdef HALOGEN_TRACE_DOM+    console.log("Setting property: " + propName + " with value: " + propValue + " on element type: " + getNodeType(element));+#endif+    element[propName] = propValue;+  } else {+#ifdef HALOGEN_TRACE_DOM+    console.log("Property: " + propName + " is already set to: " + propValue);+#endif+  }+}++function js_unsafe_get_property(propName, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting property: " + propName + " from element type: " + getNodeType(element) + " value: " + element[propName]);+#endif+  return element[propName];+}++function js_remove_property(propName, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Removing property: " + propName + " from element type: " + getNodeType(element));+#endif+  delete element[propName];+}++function js_remove_attribute(namespace, attrName, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Removing attribute: " + attrName + " from element type: " + getNodeType(element));+#endif+  if (namespace === null) {+    element.removeAttribute(attrName);+  } else {+    element.removeAttributeNS(namespace, attrName);+  }+}++function js_has_attribute(namespace, attrName, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Checking if element type: " + getNodeType(element) + " has attribute: " + attrName);+#endif+  if (namespace === null) {+    return element.hasAttribute(attrName);+  } else {+    return element.hasAttributeNS(namespace, attrName);+  }+}++function js_add_event_listener(eventType, eventListener, eventTarget) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Adding event listener for " + eventType + " on target type: " + getNodeType(eventTarget));+#endif+  eventTarget.addEventListener(eventType, eventListener, false);+}++function js_remove_event_listener(eventType, eventListener, eventTarget) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Removing event listener for " + eventType + " from target type: " + getNodeType(eventTarget));+#endif+  eventTarget.removeEventListener(eventType, eventListener, false);+}++function js_get_window() {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting window");+#endif+  return window;+}++function js_get_document(window) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting document from window");+#endif+  return window.document;+}++function js_query_selector(selector, element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Querying selector: " + selector + " on element type: " + getNodeType(element));+#endif+  return element.querySelector(selector);+}++function js_ready_state(element) {+#ifdef HALOGEN_TRACE_DOM+  console.log("Getting ready state of element type: " + getNodeType(element));+#endif+  return element.readyState;+}++function js_crypto_random_uuid() {+#ifdef HALOGEN_TRACE_DOM+  console.log("Generating random UUID");+#endif+  return window.crypto.randomUUID();+}++function js_unsafe_ref_eq(a, b) {+  return (a === b);+}++function js_current_target(e) {+  return e.target;+}
+ src/Clay/Extra/Grid.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Clay.Extra.Grid+  ( module Clay.Grid++    -- $gridIntro+  , gridTemplateAreas+  , gridTemplateRows+  )+where++import Clay.Grid+import Clay.Property (noCommas)+import Clay.Size (Size)+import Clay.Stylesheet (Css, key)+import Data.Text (Text)+import Prelude++gridTemplateAreas :: [Text] -> Css+gridTemplateAreas = key "grid-template-areas" . noCommas++gridTemplateRows :: [Size a] -> Css+gridTemplateRows = key "grid-template-rows" . noCommas
+ src/Control/Monad/Fork.hs view
@@ -0,0 +1,22 @@+module Control.Monad.Fork where++import Control.Exception.Safe+import HPrelude++class (Monad m, Functor (Fork m)) => MonadFork m where+  type Fork m :: Type -> Type++  -- suspend :: m a -> m (f a)+  fork :: m a -> m (Fork m a)+  join :: Fork m a -> m a++class (MonadFork m, MonadThrow m) => MonadKill m where+  kill :: (Exception e) => e -> Fork m a -> m ()++instance MonadFork IO where+  type Fork IO = Async+  fork = async+  join = wait++instance MonadKill IO where+  kill = flip cancelWith
+ src/Control/Monad/Parallel.hs view
@@ -0,0 +1,19 @@+module Control.Monad.Parallel where++import HPrelude++class (Applicative (Parallel m), Monad m) => MonadParallel m where+  type Parallel m :: Type -> Type+  parallel :: m a -> Parallel m a+  sequential :: Parallel m a -> m a++instance MonadParallel IO where+  type Parallel IO = Concurrently IO+  parallel = Concurrently+  sequential = runConcurrently++parSequence :: (MonadParallel m, Traversable t) => t (m a) -> m (t a)+parSequence = sequential . traverse parallel++parSequence_ :: (MonadParallel m, Traversable t) => t (m a) -> m ()+parSequence_ = void . sequential . traverse parallel
+ src/Control/Monad/State/Delayed/Class.hs view
@@ -0,0 +1,6 @@+module Control.Monad.State.Delayed.Class where++import HPrelude++class (MonadState s m) => MonadDelayedState s m | m -> s where+  commit :: m ()
+ src/Control/Monad/State/Delayed/Delayer.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Control.Monad.State.Delayed.Delayer where++import Data.Time+import HPrelude++data TimeoutKilled = TimeoutKilled+  deriving stock (Show)+  deriving anyclass (Exception)++data Delayer s = Delayer NominalDiffTime (MVar (Maybe (DelayerState s)))++data DelayerState s = DelayerState+  { delayedState :: s+  , commitFiber :: Async ()+  }++mkEmptyDelayer :: (MonadIO m) => NominalDiffTime -> m (Delayer s)+mkEmptyDelayer delay = do+  s <- liftIO $ newMVar Nothing+  pure $ Delayer delay s++mkTimedOutDelayerState :: NominalDiffTime -> s -> (s -> IO ()) -> IO (DelayerState s)+mkTimedOutDelayerState delay s commit = do+  fiber <- liftIO $ async $ liftIO (threadDelay $ floor $ realToFrac delay * 10 ^ 6) *> commit s+  pure $ DelayerState s fiber
+ src/Control/Monad/State/Delayed/Trans.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DerivingVia #-}++module Control.Monad.State.Delayed.Trans where++import Control.Monad.State.Delayed.Class+import Control.Monad.State.Delayed.Delayer+import Control.Monad.Trans+import Data.Foreign (unsafeRefEq)+import HPrelude++type DelayedStateT :: Type -> (Type -> Type) -> Type -> Type+newtype DelayedStateT s m a = DelayedStateT (Delayer s -> m a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO) via ReaderT (Delayer s) m++runDelayedStateT :: (Monad m) => Delayer s -> DelayedStateT s m a -> m a+runDelayedStateT d (DelayedStateT f) = f d++instance MonadTrans (DelayedStateT s) where+  lift = DelayedStateT . const++instance (MonadUnliftIO m, MonadState s m) => MonadState s (DelayedStateT s m) where+  state f = DelayedStateT $ \(Delayer timeout var) -> do+    let handleStateChange newState = do+          newDelState <- withRunInIO+            $ \runInIO -> mkTimedOutDelayerState timeout newState+              $ \s -> modifyMVar var $ const $ runInIO (put s) $> (Nothing, ())+          pure (Just newDelState)++    modifyMVar var $ \ds'm -> case ds'm of+      -- no previous suspended state, check if f changes the state+      -- if it does, create a new suspended state+      Nothing -> do+        baseState <- get+        let (a, newState) = f baseState+        if unsafeRefEq baseState newState+          then pure (Nothing, a)+          else do+            nvar <- handleStateChange newState+            pure (nvar, a)++      -- there is a previous suspended state+      -- check if f changes the state, if it does, create a new suspended state and cancel the previous one+      Just (DelayerState delayedState fiber) -> do+        let (a, newState) = f delayedState++        if unsafeRefEq delayedState newState+          then pure (ds'm, a)+          else do+            liftIO $ cancelWith fiber TimeoutKilled+            nvar <- handleStateChange newState+            pure (nvar, a)++instance (MonadUnliftIO m, MonadState s m) => MonadDelayedState s (DelayedStateT s m) where+  commit = DelayedStateT $ \(Delayer _ var) -> withMVar var $ \case+    Nothing -> pass+    Just (DelayerState s fiber) -> do+      liftIO $ cancelWith fiber TimeoutKilled+      put s
+ src/Control/Monad/State/Prim.hs view
@@ -0,0 +1,42 @@+module Control.Monad.State.Prim where++import Control.Exception.Safe+import HPrelude hiding (StateT (..), evalStateT, execStateT)++type StateT :: Type -> (Type -> Type) -> Type -> Type+newtype StateT s m a = StateT (IORef s -> m a)+  deriving+    (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadIO, MonadUnliftIO, MonadError e, MonadFail)+    via ReaderT (IORef s) m++instance MonadTrans (StateT s) where+  lift = StateT . const++instance (MonadIO m) => MonadState s (StateT s m) where+  state f = StateT $ flip atomicModifyIORef' f'+    where+      f' x = let (!x', !v') = f x in (v', x')++instance (MonadReader r m) => MonadReader r (StateT s m) where+  ask = lift ask+  local f (StateT m) = StateT $ local f . m++runStateT :: (MonadIO m) => StateT s m a -> s -> m (a, s)+runStateT (StateT f) s = do+  var <- newIORef s+  val <- f var+  (val,) <$> readIORef var++evalStateT :: (MonadIO m) => StateT s m a -> s -> m a+evalStateT m s = fst <$> runStateT m s++execStateT :: (MonadIO m) => StateT s m a -> s -> m s+execStateT m s = snd <$> runStateT m s++-- | Inject "normal" state transformer into our StateT. Not atomic.+stateM :: (MonadIO m) => (s -> m (a, s)) -> StateT s m a+stateM f = do+  s <- get+  (a, s') <- lift $ f s+  put s'+  pure a
+ src/Control/Monad/UUID.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++module Control.Monad.UUID where++import Control.Monad.Trans+import Data.Type.Equality+import HPrelude++#if defined(javascript_HOST_ARCH)+import GHC.JS.Prim+import Data.UUID.Types (UUID, fromText)+#else+import System.Random+import Data.UUID.Types (UUID, fromWords64)+#endif++class (Monad m) => MonadUUID m where+  generateV4 :: m UUID+  default generateV4 :: (MonadTrans t, m ~ t n, MonadUUID n) => m UUID+  generateV4 = lift generateV4++#if defined(javascript_HOST_ARCH)++foreign import javascript unsafe "js_crypto_random_uuid" js_crypto_random_uuid :: IO JSVal++instance MonadUUID IO where+  generateV4 = fromMaybe (panic "Failed to generate UUID") . fromText . toS . fromJSString <$> js_crypto_random_uuid+#else+instance MonadUUID IO where+  generateV4 = fromWords64 <$> randomIO <*> randomIO+#endif
+ src/DOM/HTML/Indexed.hs view
@@ -0,0 +1,1052 @@+module DOM.HTML.Indexed where++import Data.MediaType+import Data.Row+import Data.Text qualified as T+import Data.Time+import HPrelude hiding (Any)+import Web.Clipboard.ClipboardEvent+import Web.Event.Event+import Web.HTML.Event.DragEvent+import Web.UIEvent.FocusEvent+import Web.UIEvent.KeyboardEvent+import Web.UIEvent.MouseEvent+import Web.UIEvent.PointerEvent+import Web.UIEvent.TouchEvent+import Web.UIEvent.WheelEvent++--------------------------------------++data DirValue+  = DirLTR+  | DirRTL+  | DirAuto+  deriving (Eq, Ord)++renderDirValue :: DirValue -> Text+renderDirValue = \case+  DirLTR -> "ltr"+  DirRTL -> "rtl"+  DirAuto -> "auto"++--------------------------------------++data PreloadValue+  = PreloadNone+  | PreloadAuto+  | PreloadMetadata+  deriving stock (Eq, Ord)++renderPreloadValue :: PreloadValue -> Text+renderPreloadValue = \case+  PreloadNone -> "none"+  PreloadAuto -> "auto"+  PreloadMetadata -> "metadata"++--------------------------------------++data ButtonType+  = ButtonButton+  | ButtonSubmit+  | ButtonReset++renderButtonType :: ButtonType -> Text+renderButtonType = \case+  ButtonButton -> "button"+  ButtonSubmit -> "submit"+  ButtonReset -> "reset"++--------------------------------------++data AutocompleteType+  = AutocompleteOff+  | AutocompleteOn+  | AutocompleteName+  | AutocompleteHonorificPrefix+  | AutocompleteGivenName+  | AutocompleteAdditionalName+  | AutocompleteFamilyName+  | AutocompleteHonorificSuffix+  | AutocompleteNickname+  | AutocompleteEmail+  | AutocompleteUsername+  | AutocompleteNewPassword+  | AutocompleteCurrentPassword+  | AutocompleteOneTimeCode+  | AutocompleteOrganizationTitle+  | AutocompleteOrganization+  | AutocompleteStreetAddress+  | AutocompleteAddressLine1+  | AutocompleteAddressLine2+  | AutocompleteAddressLine3+  | AutocompleteAddressLevel1+  | AutocompleteAddressLevel2+  | AutocompleteAddressLevel3+  | AutocompleteAddressLevel4+  | AutocompleteCountry+  | AutocompleteCountryName+  | AutocompletePostalCode+  | AutocompleteCreditCardName+  | AutocompleteCreditCardGivenName+  | AutocompleteCreditCardAdditionalName+  | AutocompleteCreditCardFamilyName+  | AutocompleteCreditCardNumber+  | AutocompleteCreditCardExpiration+  | AutocompleteCreditCardExpirationMonth+  | AutocompleteCreditCardExpirationYear+  | AutocompleteCreditCardSecurityCode+  | AutocompleteCreditCardType+  | AutocompleteTransactionCurrency+  | AutocompleteTransactionAmount+  | AutocompleteLanguage+  | AutocompleteBirthday+  | AutocompleteBirthdayDay+  | AutocompleteBirthdayMonth+  | AutocompleteBirthdayYear+  | AutocompleteSex+  | AutocompleteTelephone+  | AutocompleteTelephoneCountryCode+  | AutocompleteTelephoneNational+  | AutocompleteTelephoneAreaCode+  | AutocompleteTelephoneLocal+  | AutocompleteTelephoneLocalPrefix+  | AutocompleteTelephoneLocalSuffix+  | AutocompleteTelephoneExtension+  | AutocompleteIMPP+  | AutocompleteURL+  | AutocompletePhoto+  deriving stock (Eq, Ord)++renderAutocompleteType :: AutocompleteType -> Text+renderAutocompleteType = \case+  AutocompleteOff -> "off"+  AutocompleteOn -> "on"+  AutocompleteName -> "name"+  AutocompleteHonorificPrefix -> "honorific-prefix"+  AutocompleteGivenName -> "given-name"+  AutocompleteAdditionalName -> "additional-name"+  AutocompleteFamilyName -> "family-name"+  AutocompleteHonorificSuffix -> "honorific-suffix"+  AutocompleteNickname -> "nickname"+  AutocompleteEmail -> "email"+  AutocompleteUsername -> "username"+  AutocompleteNewPassword -> "new-password"+  AutocompleteCurrentPassword -> "current-password"+  AutocompleteOneTimeCode -> "one-time-code"+  AutocompleteOrganizationTitle -> "organization-title"+  AutocompleteOrganization -> "organization"+  AutocompleteStreetAddress -> "street-address"+  AutocompleteAddressLine1 -> "address-line1"+  AutocompleteAddressLine2 -> "address-line2"+  AutocompleteAddressLine3 -> "address-line3"+  AutocompleteAddressLevel1 -> "address-level1"+  AutocompleteAddressLevel2 -> "address-level2"+  AutocompleteAddressLevel3 -> "address-level3"+  AutocompleteAddressLevel4 -> "address-level4"+  AutocompleteCountry -> "country"+  AutocompleteCountryName -> "country-name"+  AutocompletePostalCode -> "postal-code"+  AutocompleteCreditCardName -> "cc-name"+  AutocompleteCreditCardGivenName -> "cc-given-name"+  AutocompleteCreditCardAdditionalName -> "cc-additional-name"+  AutocompleteCreditCardFamilyName -> "cc-family-name"+  AutocompleteCreditCardNumber -> "cc-number"+  AutocompleteCreditCardExpiration -> "cc-exp"+  AutocompleteCreditCardExpirationMonth -> "cc-exp-month"+  AutocompleteCreditCardExpirationYear -> "cc-exp-year"+  AutocompleteCreditCardSecurityCode -> "cc-csc"+  AutocompleteCreditCardType -> "cc-type"+  AutocompleteTransactionCurrency -> "transaction-currency"+  AutocompleteTransactionAmount -> "transaction-amount"+  AutocompleteLanguage -> "language"+  AutocompleteBirthday -> "bday"+  AutocompleteBirthdayDay -> "bday-day"+  AutocompleteBirthdayMonth -> "bday-month"+  AutocompleteBirthdayYear -> "bday-year"+  AutocompleteSex -> "sex"+  AutocompleteTelephone -> "tel"+  AutocompleteTelephoneCountryCode -> "tel-country-code"+  AutocompleteTelephoneNational -> "tel-national"+  AutocompleteTelephoneAreaCode -> "telarea-code"+  AutocompleteTelephoneLocal -> "tel-local"+  AutocompleteTelephoneLocalPrefix -> "tel-local-prefix"+  AutocompleteTelephoneLocalSuffix -> "tel-local-suffix"+  AutocompleteTelephoneExtension -> "tel-extension"+  AutocompleteIMPP -> "impp"+  AutocompleteURL -> "url"+  AutocompletePhoto -> "photo"++--------------------------------------++data CrossOriginValue+  = Anonymous+  | UseCredentials+  deriving stock (Eq, Ord)++renderCrossOriginValue :: CrossOriginValue -> Text+renderCrossOriginValue = \case+  Anonymous -> "anonymous"+  UseCredentials -> "use-credentials"++--------------------------------------++newtype InputAcceptType = InputAcceptType [InputAcceptTypeAtom]+  deriving newtype (Eq, Ord, Semigroup, Monoid)++mediaType :: MediaType -> InputAcceptType+mediaType mt = InputAcceptType [AcceptMediaType mt]++extension :: Text -> InputAcceptType+extension ext = InputAcceptType [AcceptFileExtension ext]++data InputAcceptTypeAtom+  = AcceptMediaType MediaType+  | AcceptFileExtension Text+  deriving stock (Eq, Ord)++renderInputAcceptType :: InputAcceptType -> Text+renderInputAcceptType (InputAcceptType atoms) =+  T.intercalate "," (map renderInputAcceptTypeAtom atoms)++renderInputAcceptTypeAtom :: InputAcceptTypeAtom -> Text+renderInputAcceptTypeAtom = \case+  AcceptMediaType (MediaType mt) -> mt+  AcceptFileExtension ext -> ext++--------------------------------------++data MenuType+  = MenuList+  | MenuContext+  | MenuToolbar+  deriving stock (Eq, Ord)++renderMenuType :: MenuType -> Text+renderMenuType = \case+  MenuList -> "list"+  MenuContext -> "context"+  MenuToolbar -> "toolbar"++--------------------------------------++data MenuitemType+  = MenuitemCommand+  | MenuitemCheckbox+  | MenuitemRadio+  deriving stock (Eq, Ord)++renderMenuitemType :: MenuitemType -> Text+renderMenuitemType = \case+  MenuitemCommand -> "command"+  MenuitemCheckbox -> "checkbox"+  MenuitemRadio -> "radio"++--------------------------------------++data FormMethod+  = POST+  | GET+  deriving stock (Eq, Ord)++renderFormMethod :: FormMethod -> Text+renderFormMethod = \case+  POST -> "post"+  GET -> "get"++--------------------------------------++data InputType+  = InputButton+  | InputCheckbox+  | InputColor+  | InputDate+  | InputDatetimeLocal+  | InputEmail+  | InputFile+  | InputHidden+  | InputImage+  | InputMonth+  | InputNumber+  | InputPassword+  | InputRadio+  | InputRange+  | InputReset+  | InputSearch+  | InputSubmit+  | InputTel+  | InputText+  | InputTime+  | InputUrl+  | InputWeek+  deriving stock (Eq, Ord)++renderInputType :: InputType -> Text+renderInputType = \case+  InputButton -> "button"+  InputCheckbox -> "checkbox"+  InputColor -> "color"+  InputDate -> "date"+  InputDatetimeLocal -> "datetime-local"+  InputEmail -> "email"+  InputFile -> "file"+  InputHidden -> "hidden"+  InputImage -> "image"+  InputMonth -> "month"+  InputNumber -> "number"+  InputPassword -> "password"+  InputRadio -> "radio"+  InputRange -> "range"+  InputReset -> "reset"+  InputSearch -> "search"+  InputSubmit -> "submit"+  InputTel -> "tel"+  InputText -> "text"+  InputTime -> "time"+  InputUrl -> "url"+  InputWeek -> "week"++--------------------------------------++data StepValue+  = Any+  | Step Double+  deriving stock (Eq, Ord)++renderStepValue :: StepValue -> Text+renderStepValue = \case+  Any -> "any"+  Step n -> show n++--------------------------------------++data CaseType+  = Uppercase+  | Lowercase+  deriving stock (Eq, Ord)++data NumeralType+  = NumeralDecimal+  | NumeralRoman CaseType+  deriving stock (Eq, Ord)++data OrderedListType+  = OrderedListNumeric NumeralType+  | OrderedListAlphabetic CaseType+  deriving stock (Eq, Ord)++renderOrderedListType :: OrderedListType -> Text+renderOrderedListType = \case+  OrderedListNumeric NumeralDecimal -> "1"+  OrderedListNumeric (NumeralRoman Lowercase) -> "i"+  OrderedListNumeric (NumeralRoman Uppercase) -> "I"+  OrderedListAlphabetic Lowercase -> "a"+  OrderedListAlphabetic Uppercase -> "A"++--------------------------------------++data WrapValue+  = Hard+  | Soft+  deriving stock (Eq, Ord)++renderWrapValue :: WrapValue -> Text+renderWrapValue = \case+  Hard -> "hard"+  Soft -> "soft"++--------------------------------------++data ScopeValue+  = ScopeRow+  | ScopeCol+  | ScopeRowGroup+  | ScopeColGroup+  | ScopeAuto+  deriving stock (Eq, Ord)++renderScopeValue :: ScopeValue -> Text+renderScopeValue = \case+  ScopeRow -> "row"+  ScopeCol -> "col"+  ScopeRowGroup -> "rowgroup"+  ScopeColGroup -> "colgroup"+  ScopeAuto -> "auto"++--------------------------------------++data KindValue+  = KindSubtitles+  | KindCaptions+  | KindDescriptions+  | KindChapters+  | KindMetadata+  deriving stock (Eq, Ord)++renderKindValue :: KindValue -> Text+renderKindValue = \case+  KindSubtitles -> "subtitles"+  KindCaptions -> "captions"+  KindDescriptions -> "descriptions"+  KindChapters -> "chapters"+  KindMetadata -> "metadata"++--------------------------------------++type CSSPixel = Int++type GlobalAttributes (r :: Row Type) =+  ( "id" .== Text+      .+ "title" .== Text+      .+ "class" .== Text+      .+ "style" .== Text+      .+ "spellcheck" .== Bool+      .+ "draggable" .== Bool+      .+ "lang" .== Text+      .+ "dir" .== DirValue+      .+ "hidden" .== Bool+      .+ "tabIndex" .== Int+      .+ "accessKey" .== Text+      .+ "contentEditable" .== Bool+      .+ r+  )++type GlobalEvents r =+  ( "onContextMenu" .== Event+      .+ "onInput" .== Event+      .+ "onBeforeInput" .== Event+      .+ r+  )++type MouseEvents r =+  ( "onDoubleClick" .== MouseEvent+      .+ "onClick" .== MouseEvent+      .+ "onAuxClick" .== MouseEvent+      .+ "onMouseDown" .== MouseEvent+      .+ "onMouseEnter" .== MouseEvent+      .+ "onMouseLeave" .== MouseEvent+      .+ "onMouseMove" .== MouseEvent+      .+ "onMouseOver" .== MouseEvent+      .+ "onMouseOut" .== MouseEvent+      .+ "onMouseUp" .== MouseEvent+      .+ r+  )++type DragEvents r =+  ( "onDrag" .== DragEvent+      .+ "onDragEnd" .== DragEvent+      .+ "onDragExit" .== DragEvent+      .+ "onDragEnter" .== DragEvent+      .+ "onDragLeave" .== DragEvent+      .+ "onDragOver" .== DragEvent+      .+ "onDragStart" .== DragEvent+      .+ "onDrop" .== DragEvent+      .+ r+  )++type TouchEvents r =+  ( "onTouchCancel" .== TouchEvent+      .+ "onTouchEnd" .== TouchEvent+      .+ "onTouchEnter" .== TouchEvent+      .+ "onTouchLeave" .== TouchEvent+      .+ "onTouchMove" .== TouchEvent+      .+ "onTouchStart" .== TouchEvent+      .+ r+  )++type PointerEvents r =+  ( "onPointerOver" .== PointerEvent+      .+ "onPointerEnter" .== PointerEvent+      .+ "onPointerDown" .== PointerEvent+      .+ "onPointerMove" .== PointerEvent+      .+ "onPointerUp" .== PointerEvent+      .+ "onPointerCancel" .== PointerEvent+      .+ "onPointerOut" .== PointerEvent+      .+ "onPointerLeave" .== PointerEvent+      .+ "onGotPointerCapture" .== PointerEvent+      .+ "onLostPointerCapture" .== PointerEvent+      .+ r+  )++type KeyEvents r =+  ( "onKeyDown" .== KeyboardEvent+      .+ "onKeyUp" .== KeyboardEvent+      .+ "onKeyPress" .== KeyboardEvent+      .+ r+  )++type TransitionEvents r =+  ( "onTransitionEnd" .== Event+      .+ r+  )++type FocusEvents r =+  ( "onBlur" .== FocusEvent+      .+ "onFocus" .== FocusEvent+      .+ "onFocusIn" .== FocusEvent+      .+ "onFocusOut" .== FocusEvent+      .+ r+  )++type ClipboardEvents r =+  ( "onCopy" .== ClipboardEvent+      .+ "onCut" .== ClipboardEvent+      .+ "onPaste" .== ClipboardEvent+      .+ r+  )++type InteractiveEvents r = ClipboardEvents (FocusEvents (TransitionEvents (KeyEvents (PointerEvents (TouchEvents (DragEvents (MouseEvents ("onWheel" .== WheelEvent .+ r))))))))++type GlobalProperties r = GlobalAttributes (GlobalEvents r)++type Interactive r = InteractiveEvents (GlobalProperties r)++type Noninteractive r = GlobalProperties r++type HTMLa =+  Interactive+    ( "download" .== Text+        .+ "href" .== Text+        .+ "hrefLang" .== Text+        .+ "rel" .== Text+        .+ "target" .== Text+        .+ "type" .== MediaType+    )++type HTMLabbr = Interactive Empty++type HTMLaddress = Interactive ("onScroll" .== Event)++type HTMLarea =+  Interactive+    ( "coords" .== Text+        .+ "download" .== Text+        .+ "href" .== Text+        .+ "hrefLang" .== Text+        .+ "media" .== Text+        .+ "rel" .== Text+        .+ "shape" .== Text+        .+ "target" .== Text+        .+ "type" .== MediaType+    )++type HTMLarticle = Interactive Empty++type HTMLaside = Interactive Empty++type HTMLaudio =+  Interactive+    ( "autoplay" .== Bool+        .+ "controls" .== Bool+        .+ "loop" .== Bool+        .+ "muted" .== Bool+        .+ "preload" .== PreloadValue+        .+ "src" .== Text+        .+ "onError" .== Event+    )++type HTMLb = Interactive Empty++type HTMLbase =+  Noninteractive+    ( "href" .== Text+        .+ "target" .== Text+    )++type HTMLbdi = Interactive Empty++type HTMLbdo = Noninteractive Empty++type HTMLblockquote =+  Interactive+    ( "cite" .== Text+        .+ "onScroll" .== Event+    )++type HTMLbody =+  Interactive+    ( "onBeforeUnload" .== Event+        .+ "onHashChange" .== Event+        .+ "onLoad" .== Event+        .+ "onPageShow" .== Event+        .+ "onPageHide" .== Event+        .+ "onResize" .== Event+        .+ "onScroll" .== Event+        .+ "onUnload" .== Event+    )++type HTMLbr = Noninteractive Empty++type HTMLbutton =+  Interactive+    ( "autofocus" .== Bool+        .+ "disabled" .== Bool+        .+ "form" .== Text+        .+ "formAction" .== Text+        .+ "formEncType" .== MediaType+        .+ "formMethod" .== FormMethod+        .+ "formNoValidate" .== Bool+        .+ "formTarget" .== Text+        .+ "name" .== Text+        .+ "type" .== ButtonType+        .+ "value" .== Text+    )++type HTMLcanvas =+  Interactive+    ( "width" .== CSSPixel+        .+ "height" .== CSSPixel+    )++type HTMLcaption = Interactive ("onScroll" .== Event)++type HTMLcite = Interactive Empty++type HTMLcode = Interactive Empty++type HTMLcol = Interactive Empty++type HTMLcolgroup = Interactive ("span" .== Int)++type HTMLcommand = Interactive Empty++type HTMLdatalist = Interactive Empty++type HTMLdd = Interactive ("onScroll" .== Event)++type HTMLdel =+  Interactive+    ( "cite" .== Text+        .+ "UTCTime" .== Text+    )++type HTMLdetails = Interactive ("open" .== Bool)++type HTMLdfn = Interactive Empty++type HTMLdialog = Interactive ("open" .== Bool)++type HTMLdiv = Interactive ("onScroll" .== Event)++type HTMLdl = Interactive ("onScroll" .== Event)++type HTMLdt = Interactive ("onScroll" .== Event)++type HTMLem = Interactive Empty++type HTMLembed =+  Interactive+    ( "height" .== CSSPixel+        .+ "src" .== Text+        .+ "type" .== MediaType+        .+ "width" .== CSSPixel+    )++type HTMLfieldset =+  Interactive+    ( "disabled" .== Bool+        .+ "form" .== Text+        .+ "name" .== Text+        .+ "onScroll" .== Event+    )++type HTMLfigcaption = Interactive Empty++type HTMLfigure = Interactive Empty++type HTMLfooter = Interactive Empty++type HTMLform =+  Interactive+    ( "acceptCharset" .== Text+        .+ "action" .== Text+        .+ "autocomplete" .== AutocompleteType+        .+ "enctype" .== MediaType+        .+ "method" .== FormMethod+        .+ "name" .== Text+        .+ "noValidate" .== Bool+        .+ "onReset" .== Event+        .+ "onScroll" .== Event+        .+ "onSubmit" .== Event+        .+ "target" .== Text+    )++type HTMLh1 = Interactive ("onScroll" .== Event)++type HTMLh2 = Interactive ("onScroll" .== Event)++type HTMLh3 = Interactive ("onScroll" .== Event)++type HTMLh4 = Interactive ("onScroll" .== Event)++type HTMLh5 = Interactive ("onScroll" .== Event)++type HTMLh6 = Interactive ("onScroll" .== Event)++type HTMLhead = Noninteractive Empty++type HTMLheader = Interactive Empty++type HTMLhr = Interactive Empty++type HTMLhtml =+  Interactive+    ( "manifest" .== Text+        .+ "onScroll" .== Event+        .+ "xmlns" .== Text+    )++type HTMLi = Interactive Empty++type HTMLiframe =+  Noninteractive+    ( "height" .== CSSPixel+        .+ "name" .== Text+        .+ "onLoad" .== Event+        .+ "sandbox" .== Text+        .+ "src" .== Text+        .+ "srcDoc" .== Text+        .+ "width" .== CSSPixel+    )++type HTMLimg =+  Interactive+    ( "alt" .== Text+        .+ "crossOrigin" .== CrossOriginValue+        .+ "height" .== CSSPixel+        .+ "isMap" .== Bool+        .+ "longDesc" .== Text+        .+ "onAbort" .== Event+        .+ "onError" .== Event+        .+ "onLoad" .== Event+        .+ "src" .== Text+        .+ "useMap" .== Text+        .+ "width" .== CSSPixel+    )++type HTMLinput =+  Interactive+    ( "accept" .== InputAcceptType+        .+ "autocomplete" .== AutocompleteType+        .+ "autofocus" .== Bool+        .+ "checked" .== Bool+        .+ "disabled" .== Bool+        .+ "form" .== Text+        .+ "formAction" .== Text+        .+ "formEncType" .== MediaType+        .+ "formMethod" .== FormMethod+        .+ "formNoValidate" .== Bool+        .+ "formTarget" .== Text+        .+ "height" .== CSSPixel+        .+ "list" .== Text+        .+ "max" .== Double+        .+ "min" .== Double+        .+ "maxLength" .== Int+        .+ "minLength" .== Int+        .+ "multiple" .== Bool+        .+ "name" .== Text+        .+ "onAbort" .== Event+        .+ "onChange" .== Event+        .+ "onError" .== Event+        .+ "onInvalid" .== Event+        .+ "onLoad" .== Event+        .+ "onSearch" .== Event+        .+ "onSelect" .== Event+        .+ "pattern" .== Text+        .+ "placeholder" .== Text+        .+ "readOnly" .== Bool+        .+ "required" .== Bool+        .+ "size" .== Int+        .+ "src" .== Text+        .+ "step" .== StepValue+        .+ "type" .== InputType+        .+ "value" .== Text+        .+ "width" .== CSSPixel+    )++type HTMLins =+  Interactive+    ( "cite" .== Text+        .+ "UTCTime" .== UTCTime+    )++type HTMLkbd = Interactive Empty++type HTMLlabel =+  Interactive+    ( "for" .== Text+        .+ "form" .== Text+    )++type HTMLlegend = Interactive Empty++type HTMLli =+  Interactive+    ( "value" .== Int+        .+ "onScroll" .== Event+    )++type HTMLlink =+  Noninteractive+    ( "crossOrigin" .== CrossOriginValue+        .+ "href" .== Text+        .+ "hreflang" .== Text+        .+ "media" .== Text+        .+ "onLoad" .== Event+        .+ "rel" .== Text+        .+ "sizes" .== Text+        .+ "type" .== MediaType+    )++type HTMLmain = Interactive Empty++type HTMLmap = Interactive ("name" .== Text)++type HTMLmark = Interactive Empty++type HTMLmenu =+  Interactive+    ( "label" .== Text+        .+ "onScroll" .== Event+        .+ "type" .== MenuType+    )++type HTMLmenuitem =+  Interactive+    ( "checked" .== Bool+        .+ "command" .== Text+        .+ "default" .== Bool+        .+ "disabled" .== Bool+        .+ "icon" .== Text+        .+ "label" .== Text+        .+ "radioGroup" .== Text+        .+ "type" .== MenuitemType+    )++type HTMLmeta =+  Noninteractive+    ( "charset" .== Text+        .+ "content" .== Text+        .+ "httpEquiv" .== Text+        .+ "name" .== Text+    )++type HTMLmeter =+  Interactive+    ( "form" .== Text+        .+ "high" .== Double+        .+ "low" .== Double+        .+ "max" .== Double+        .+ "min" .== Double+        .+ "optimum" .== Double+        .+ "value" .== Double+    )++type HTMLnav = Interactive Empty++type HTMLnoscript = Interactive Empty++type HTMLobject =+  Interactive+    ( "data" .== Text+        .+ "form" .== Text+        .+ "height" .== CSSPixel+        .+ "name" .== Text+        .+ "onError" .== Event+        .+ "onScroll" .== Event+        .+ "type" .== MediaType+        .+ "useMap" .== Text+        .+ "width" .== CSSPixel+    )++type HTMLol =+  Interactive+    ( "onScroll" .== Event+        .+ "reversed" .== Bool+        .+ "start" .== Int+        .+ "type" .== OrderedListType+    )++type HTMLoptgroup =+  Interactive+    ( "disabled" .== Bool+        .+ "label" .== Text+    )++type HTMLoption =+  Interactive+    ( "disabled" .== Bool+        .+ "label" .== Text+        .+ "selected" .== Bool+        .+ "value" .== Text+    )++type HTMLoutput =+  Interactive+    ( "for" .== Text+        .+ "form" .== Text+        .+ "name" .== Text+    )++type HTMLp = Interactive ("onScroll" .== Event)++type HTMLparam =+  Noninteractive+    ( "name" .== Text+        .+ "value" .== Text+    )++type HTMLpre = Interactive ("onScroll" .== Event)++type HTMLprogress =+  Interactive+    ( "max" .== Double+        .+ "value" .== Double+    )++type HTMLq = Interactive ("cite" .== Text)++type HTMLrp = Interactive Empty++type HTMLrt = Interactive Empty++type HTMLruby = Interactive Empty++type HTMLsamp = Interactive Empty++type HTMLscript =+  Noninteractive+    ( "async" .== Bool+        .+ "charset" .== Text+        .+ "defer" .== Bool+        .+ "onError" .== Event+        .+ "onLoad" .== Event+        .+ "src" .== Text+        .+ "type" .== MediaType+    )++type HTMLsection = Interactive Empty++type HTMLselect =+  Interactive+    ( "autofocus" .== Bool+        .+ "disabled" .== Bool+        .+ "form" .== Text+        .+ "multiple" .== Bool+        .+ "name" .== Text+        .+ "onChange" .== Event+        .+ "onScroll" .== Event+        .+ "required" .== Bool+        .+ "selectedIndex" .== Int+        .+ "size" .== Int+        .+ "value" .== Text+    )++type HTMLsmall = Interactive Empty++type HTMLsource =+  Interactive+    ( "media" .== Text+        .+ "src" .== Text+        .+ "type" .== MediaType+    )++type HTMLspan = Interactive Empty++type HTMLstrong = Interactive Empty++type HTMLstyle =+  Noninteractive+    ( "media" .== Text+        .+ "onError" .== Event+        .+ "onLoad" .== Event+        .+ "scoped" .== Bool+        .+ "type" .== MediaType+    )++type HTMLsub = Interactive Empty++type HTMLsummary = Interactive Empty++type HTMLsup = Interactive Empty++type HTMLtable = Interactive ("sortable" .== Bool)++type HTMLtbody = Interactive ("onScroll" .== Event)++type HTMLtd =+  Interactive+    ( "colSpan" .== Int+        .+ "headers" .== Text+        .+ "rowSpan" .== Int+    )++type HTMLtextarea =+  Interactive+    ( "autofocus" .== Bool+        .+ "cols" .== Int+        .+ "disabled" .== Bool+        .+ "form" .== Text+        .+ "maxLength" .== Int+        .+ "name" .== Text+        .+ "onChange" .== Event+        .+ "onScroll" .== Event+        .+ "onSelect" .== Event+        .+ "placeholder" .== Text+        .+ "readOnly" .== Bool+        .+ "required" .== Bool+        .+ "rows" .== Int+        .+ "value" .== Text+        .+ "wrap" .== WrapValue+    )++type HTMLtfoot = Interactive ("onScroll" .== Event)++type HTMLth =+  Interactive+    ( "abbr" .== Text+        .+ "colSpan" .== Int+        .+ "headers" .== Text+        .+ "rowSpan" .== Int+        .+ "scope" .== ScopeValue+        .+ "sorted" .== Bool+    )++type HTMLthead = Interactive Empty++type HTMLtime = Interactive ("UTCTime" .== UTCTime)++type HTMLtitle = Noninteractive Empty++type HTMLtr = Interactive Empty++type HTMLtrack =+  Interactive+    ( "default" .== Bool+        .+ "kind" .== KindValue+        .+ "label" .== Text+        .+ "src" .== Text+        .+ "srcLang" .== Text+    )++type HTMLu = Interactive Empty++type HTMLul = Interactive ("onScroll" .== Event)++type HTMLvar = Interactive Empty++type HTMLvideo =+  Interactive+    ( "autoplay" .== Bool+        .+ "controls" .== Bool+        .+ "height" .== CSSPixel+        .+ "loop" .== Bool+        .+ "muted" .== Bool+        .+ "poster" .== Text+        .+ "preload" .== PreloadValue+        .+ "src" .== Text+        .+ "width" .== CSSPixel+        .+ "type" .== MediaType+        .+ "onError" .== Event+    )++type HTMLwbr = Interactive Empty
+ src/Data/Foreign.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module Data.Foreign where++-- #if !defined(javascript_HOST_ARCH)+import GHC.Base (isTrue#, reallyUnsafePtrEquality, reallyUnsafePtrEquality#)+-- #endif++import HPrelude+import Unsafe.Coerce (unsafeCoerce)++#if defined(javascript_HOST_ARCH)+import GHC.Base (Int#)+import GHC.JS.Prim++type Foreign tag = JSVal++newtype Nullable tag = Nullable (Foreign tag)++foreign import javascript unsafe "(($1) => { return (!!$1 ? 1 : 0); })" foreignToBool' :: Foreign tag -> Int#++nullableToMaybe :: Nullable tag -> Maybe (Foreign tag)+nullableToMaybe (Nullable o) = if isNull o || isUndefined o then Nothing else Just o++toForeign :: a -> Foreign tag+toForeign = unsafeCoerce++unsafeFromForeign :: Foreign tag -> a+unsafeFromForeign = unsafeCoerce++readProp :: Text -> (Foreign tag -> Maybe a) -> Foreign tag' -> Maybe a+readProp key f o = nullableToMaybe (Nullable $ unsafeGetProp o (toS key)) >>= f++-- TODO this doesn't work for some reason+--foreign import javascript unsafe "js_unsafe_ref_eq" js_unsafe_ref_eq :: JSVal -> JSVal -> Bool++--unsafeRefEq' :: a -> b -> Bool+--unsafeRefEq' a b = js_unsafe_ref_eq (unsafeCoerce a) (unsafeCoerce b)++--unsafeRefEq :: a -> a -> Bool+--unsafeRefEq a b = unsafeRefEq' a b++foreignToString :: Foreign tag -> Text+foreignToString = toS . fromJSString++foreignToInt :: Foreign tag -> Int+foreignToInt = fromJSInt++foreignToBool :: Foreign tag -> Bool+foreignToBool x = isTrue# (foreignToBool' x)+#else++newtype Foreign tag = Foreign Any++type Nullable tag = Maybe (Foreign tag)++nullableToMaybe :: Nullable tag -> Maybe (Foreign tag)+nullableToMaybe = identity++toForeign :: a -> Foreign tag+toForeign = Foreign . unsafeCoerce++unsafeFromForeign :: Foreign tag -> a+unsafeFromForeign (Foreign o) = unsafeCoerce o++readProp :: Text -> (Foreign tag -> Maybe a) -> Foreign tag' -> Maybe a+readProp = panic "Unavailable in GHC" -- TODO++foreignToString :: Foreign tag -> Text+foreignToString = unsafeCoerce++foreignToInt :: Foreign tag -> Int+foreignToInt = unsafeCoerce++foreignToBool :: Foreign tag -> Bool+foreignToBool = unsafeFromForeign+#endif++unsafeRefEq :: a -> a -> Bool+unsafeRefEq p q = isTrue# (reallyUnsafePtrEquality p q)++unsafeRefEq' :: a -> b -> Bool+unsafeRefEq' p q = isTrue# (reallyUnsafePtrEquality# p q)
+ src/Data/MediaType.hs view
@@ -0,0 +1,62 @@+module Data.MediaType where++import HPrelude++newtype MediaType = MediaType Text+  deriving newtype (Eq, Ord, Show)++-- | The `application/x-www-form-urlencoded` media type.+applicationFormURLEncoded :: MediaType+applicationFormURLEncoded = MediaType "application/x-www-form-urlencoded"++-- | The `application/json` media type.+applicationJSON :: MediaType+applicationJSON = MediaType "application/json"++-- | The `application/javascript` media type.+applicationJavascript :: MediaType+applicationJavascript = MediaType "application/javascript"++-- | The `application/octet-stream` media type.+applicationOctetStream :: MediaType+applicationOctetStream = MediaType "application/octet-stream"++-- | The `application/xml` media type.+applicationXML :: MediaType+applicationXML = MediaType "application/xml"++-- | The `image/gif` media type.+imageGIF :: MediaType+imageGIF = MediaType "image/gif"++-- | The `image/jpeg` media type.+imageJPEG :: MediaType+imageJPEG = MediaType "image/jpeg"++-- | The `image/png` media type.+imagePNG :: MediaType+imagePNG = MediaType "image/png"++-- | The `multipart/form-data` media type.+multipartFormData :: MediaType+multipartFormData = MediaType "multipart/form-data"++-- | The `text/csv` media type.+textCSV :: MediaType+textCSV = MediaType "text/csv"++-- | The `text/html` media type.+textHTML :: MediaType+textHTML = MediaType "text/html"++-- | The `text/plain` media type.+textPlain :: MediaType+textPlain = MediaType "text/plain"++-- | The `text/xml` media type.+textXML :: MediaType+textXML = MediaType "text/xml"++-- | The `text/css` media type.+textCSS :: MediaType+textCSS = MediaType "text/css"
+ src/Data/NT.hs view
@@ -0,0 +1,8 @@+-- {-# LANGUAGE FieldSelectors #-}+module Data.NT where++-- Natural transformation+newtype m ~> n = NT {runNT :: forall a. m a -> n a}++runNT :: (m ~> n) -> m a -> n a+runNT (NT f) = f
+ src/HPrelude.hs view
@@ -0,0 +1,993 @@+-- | Protolude adapted to UnliftIO+module HPrelude+  ( -- * Base functions+    module Base+  , identity+  , pass++    -- * Function functions+  , module Function+  , applyN++    -- * List functions+  , module List+  , map+  , uncons+  , unsnoc++    -- * Data Structures+  , module DataStructures++    -- * Show functions+  , module Show+  , show+  , print++    -- * Bool functions+  , module Bool++    -- * Monad functions+  , module Monad+  , liftIO1+  , liftIO2++    -- * Functor functions+  , module Functor++    -- * Either functions+  , module Either++    -- * Applicative functions+  , module Applicative+  , guarded+  , guardedA++    -- * String conversion+  , module ConvertText++    -- * Debug functions+  , module Debug++    -- * Panic functions+  , module Panic++    -- * Exception functions+  , module Exception+  , throwIO+  , throwTo++    -- * Semiring functions+  , module Semiring++    -- * String functions+  , module String++    -- * Safe functions+  , module Safe++    -- * Eq functions+  , module Eq++    -- * Ord functions+  , module Ord++    -- * Traversable functions+  , module Traversable++    -- * Foldable functions+  , module Foldable++    -- * Semigroup functions+  , module Semigroup++    -- * Monoid functions+  , module Monoid++    -- * Bifunctor functions+  , module Bifunctor++    -- * Bifunctor functions+  , module Hashable++    -- * Deepseq functions+  , module DeepSeq++    -- * Tuple functions+  , module Tuple+  , module Typeable++    -- * Typelevel programming+  , module Typelevel++    -- * Monads+  , module Fail+  , module State+  , module Reader+  , module Except+  , module Trans+  , module ST+  , module STM++    -- * Integers+  , module Int+  , module Bits++    -- * Complex functions+  , module Complex++    -- * Char functions+  , module Char++    -- * Maybe functions+  , module Maybe++    -- * Generics functions+  , module Generics++    -- * ByteString functions+  , module ByteString+  , LByteString++    -- * Text functions+  , module Text+  , LText++    -- * Read functions+  , module Read+  , readMaybe+  , readEither++    -- * System functions+  , module System+  , die++    -- * Concurrency functions+  , module Concurrency++    -- * Foreign functions+  , module Foreign+  , atomicModifyIORef'_+  , UnliftIO (..)+  , askUnliftIO+  , mapUnliftIO+  , MonadUnliftIO (..)+  , module Coercible+  , loopM+  , MonadMask+  )+where++-- Protolude module exports.++-- Overriden by Show.putStr+-- Overriden by Show.putStrLn+-- Overriden by Protolude.print+-- Overriden by Protolude.show+-- Custom Show instances deprecated.+-- Custom Show instances deprecated.+-- Custom Show instances deprecated.+-- Custom Show instances deprecated.+-- Custom Show instances deprecated.++-- Used for 'show', not exported.++-- Maybe'ized version of partial functions++-- Applicatives+import Control.Applicative as Applicative+  ( Alternative (..)+  , Applicative (..)+  , Const (Const, getConst)+  , ZipList (ZipList, getZipList)+  , liftA+  , liftA2+  , liftA3+  , optional+  , (<**>)+  )+import Data.Coerce as Coercible (Coercible, coerce)+-- Base typeclasses+import Data.Eq as Eq+  ( Eq (..)+  )+import Data.Foldable as Foldable+  ( Foldable+  , all+  , and+  , any+  , asum+  , concat+  , concatMap+  , elem+  , find+  , fold+  , foldMap+  , foldl+  , foldl'+  , foldlM+  , foldr+  , foldr'+  , foldrM+  , forM_+  , for_+  , length+  , mapM_+  , maximum+  , maximumBy+  , minimum+  , minimumBy+  , msum+  , notElem+  , null+  , or+  , sequenceA_+  , sequence_+  , toList+  , traverse_+  )+import Data.Functor.Identity as Functor+  ( Identity (Identity, runIdentity)+  )+import Data.List.NonEmpty as List+  ( NonEmpty ((:|))+  , nonEmpty+  )+import Data.Ord as Ord+  ( Down (Down)+  , Ord (..)+  , Ordering (EQ, GT, LT)+  , comparing+  )+import Data.Semigroup as Semigroup+  ( Semigroup (sconcat, stimes)+  , WrappedMonoid+  , cycle1+  , diff+  , mtimesDefault+  , stimesIdempotent+  , stimesIdempotentMonoid+  , stimesMonoid+  )+import Data.String (String)+import Data.String as String (IsString)+import Data.Traversable as Traversable+import Protolude.Applicative as Applicative+import Protolude.Base as Base hiding+  ( print+  , putStr+  , putStrLn+  , show+  , showFloat+  , showList+  , showSigned+  , showSignedFloat+  , showsPrec+  )+import Protolude.Base qualified as PBase+import Protolude.Bool as Bool+import Protolude.Conv qualified as Conv+import Protolude.ConvertText as ConvertText+import Protolude.Debug as Debug+import Protolude.Either as Either+import Protolude.Exceptions as Exception+import Protolude.Functor as Functor+import Protolude.List as List+import Protolude.Monad as Monad+import Protolude.Panic as Panic+import Protolude.Safe as Safe+  ( atDef+  , atMay+  , foldl1May+  , foldl1May'+  , foldr1May+  , headDef+  , headMay+  , initDef+  , initMay+  , initSafe+  , lastDef+  , lastMay+  , maximumDef+  , maximumMay+  , minimumDef+  , minimumMay+  , tailDef+  , tailMay+  , tailSafe+  )+import Protolude.Semiring as Semiring+import Protolude.Show as Show+import UnliftIO as UnliftIO++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,16,0)+import Data.Semigroup as Semigroup (+    Option(..)+  , option+  )+#endif++-- Deepseq+import Control.DeepSeq as DeepSeq+  ( NFData (..)+  , deepseq+  , force+  , ($!!)+  )+-- Data structures++-- Hashing++-- Monad transformers++-- Base types++-- Genericss++-- ByteString++-- Text++-- IO++-- ST++-- Concurrency and Parallelism+import Control.Exception as Exception+  ( AllocationLimitExceeded (AllocationLimitExceeded)+  , ArithException+    ( Denormal+    , DivideByZero+    , LossOfPrecision+    , Overflow+    , RatioZeroDenominator+    , Underflow+    )+  , ArrayException (IndexOutOfBounds, UndefinedElement)+  , AssertionFailed (AssertionFailed)+  , AsyncException (HeapOverflow, StackOverflow, ThreadKilled, UserInterrupt)+  , BlockedIndefinitelyOnMVar (BlockedIndefinitelyOnMVar)+  , BlockedIndefinitelyOnSTM (BlockedIndefinitelyOnSTM)+  , CompactionFailed (CompactionFailed)+  , Deadlock (Deadlock)+  , ErrorCall (ErrorCall, ErrorCallWithLocation)+  , MaskingState (..)+  , NestedAtomically (NestedAtomically)+  , NoMethodError (NoMethodError)+  , NonTermination (NonTermination)+  , PatternMatchFail (PatternMatchFail)+  , RecConError (RecConError)+  , RecSelError (RecSelError)+  , RecUpdError (RecUpdError)+  , TypeError (TypeError)+  , allowInterrupt+  , getMaskingState+  , interruptible+  , ioError+  , mapException+  )+-- , Handler(Handler)++-- , addMVarFinalizer++-- Read instances hiding unsafe builtins (read)++import Control.Exception.Safe (MonadMask (..))+import Control.Monad.Except as Except+  ( Except+  , ExceptT (ExceptT)+  , MonadError+  , catchError+  , mapExcept+  , mapExceptT+  , runExcept+  , runExceptT+  , throwError+  , withExcept+  , withExceptT+  )+import Control.Monad.Fail as Fail+  ( MonadFail+  )+import Control.Monad.Reader as Reader+  ( MonadReader+  , Reader+  , ReaderT (ReaderT)+  , ask+  , asks+  , local+  , reader+  , runReader+  , runReaderT+  )+import Control.Monad.ST as ST+  ( ST+  , fixST+  , runST+  )+import Control.Monad.STM as STM+  ( STM+  , atomically+  , catchSTM+  , check+  , orElse+  , retry+  , throwSTM+  )+import Control.Monad.State as State+  ( MonadState+  , State+  , StateT (StateT)+  , evalState+  , evalStateT+  , execState+  , execStateT+  , get+  , gets+  , modify+  , put+  , runState+  , runStateT+  , state+  , withState+  )+import Control.Monad.Trans as Trans+  ( MonadIO+  , MonadTrans (..)+  , lift+  , liftIO+  )+import Control.Monad.Trans.Except as Except+  ( catchE+  , throwE+  )+import Data.Bifunctor as Bifunctor (Bifunctor (bimap, first, second))+import Data.Bits as Bits+  ( Bits+  , FiniteBits+  , bit+  , bitDefault+  , bitSize+  , bitSizeMaybe+  , clearBit+  , complement+  , complementBit+  , countLeadingZeros+  , countTrailingZeros+  , finiteBitSize+  , isSigned+  , popCount+  , popCountDefault+  , rotate+  , rotateL+  , rotateR+  , setBit+  , shift+  , shiftL+  , shiftR+  , testBit+  , testBitDefault+  , toIntegralSized+  , xor+  , zeroBits+  , (.&.)+  , (.|.)+  )+import Data.Bool as Bool+  ( Bool (False, True)+  , not+  , otherwise+  , (&&)+  , (||)+  )+import Data.ByteString as ByteString (ByteString)+import Data.ByteString.Lazy qualified+import Data.Char as Char+  ( Char+  , chr+  , digitToInt+  , intToDigit+  , isAlpha+  , isAlphaNum+  , isAscii+  , isControl+  , isDigit+  , isHexDigit+  , isLetter+  , isLower+  , isPrint+  , isSpace+  , isUpper+  , ord+  , toLower+  , toTitle+  , toUpper+  )+import Data.Complex as Complex+  ( Complex ((:+))+  , cis+  , conjugate+  , imagPart+  , magnitude+  , mkPolar+  , phase+  , polar+  , realPart+  )+import Data.Either as Either+  ( Either (Left, Right)+  , either+  , isLeft+  , isRight+  , lefts+  , partitionEithers+  , rights+  )+import Data.Function as Function+  ( const+  , fix+  , flip+  , on+  , ($)+  , (&)+  , (.)+  )+import Data.Hashable as Hashable+  ( Hashable+  , hash+  , hashUsing+  , hashWithSalt+  )+import Data.Int as Int+  ( Int+  , Int16+  , Int32+  , Int64+  , Int8+  )+import Data.IntMap as DataStructures (IntMap)+import Data.IntSet as DataStructures (IntSet)+import Data.List as List+  ( break+  , cycle+  , drop+  , dropWhile+  , filter+  , genericDrop+  , genericLength+  , genericReplicate+  , genericSplitAt+  , genericTake+  , group+  , inits+  , intercalate+  , intersperse+  , isInfixOf+  , isPrefixOf+  , isSuffixOf+  , iterate+  , permutations+  , repeat+  , replicate+  , reverse+  , scanl+  , scanl'+  , scanr+  , sort+  , sortBy+  , splitAt+  , subsequences+  , tails+  , take+  , takeWhile+  , transpose+  , unfoldr+  , unzip+  , zip+  , zipWith+  )+import Data.Map as DataStructures (Map)+import Data.Maybe as Maybe+  ( Maybe (Just, Nothing)+  , catMaybes+  , fromMaybe+  , isJust+  , isNothing+  , listToMaybe+  , mapMaybe+  , maybe+  , maybeToList+  )+import Data.Monoid as Monoid+import Data.Proxy as Typelevel+  ( Proxy (..)+  )+import Data.Sequence as DataStructures (Seq)+import Data.Set as DataStructures (Set)+import Data.Text as Text+  ( Text+  , lines+  , unlines+  , unwords+  , words+  )+import Data.Text.Encoding as Text+  ( decodeUtf8+  , decodeUtf8'+  , decodeUtf8With+  , encodeUtf8+  )+import Data.Text.Encoding.Error as Text+  ( OnDecodeError+  , OnError+  , UnicodeException+  , ignore+  , lenientDecode+  , replace+  , strictDecode+  )+import Data.Text.IO as Text+  ( appendFile+  , getContents+  , getLine+  , interact+  , readFile+  , writeFile+  )+import Data.Text.Lazy as Text+  ( fromStrict+  , toStrict+  )+import Data.Text.Lazy qualified+import Data.Tuple as Tuple+  ( curry+  , fst+  , snd+  , swap+  , uncurry+  )+import Data.Type.Coercion as Typelevel+  ( Coercion (..)+  , coerceWith+  , repr+  )+import Data.Type.Equality as Typelevel+  ( castWith+  , gcastWith+  , sym+  , trans+  , (:~:) (..)+  , type (==)+  )+import Data.Void as Typelevel+  ( Void+  , absurd+  , vacuous+  )+import Data.Word as Bits+  ( Word+  , Word16+  , Word32+  , Word64+  , Word8+  , byteSwap16+  , byteSwap32+  , byteSwap64+  )+import Foreign.Ptr as Foreign (IntPtr, WordPtr)+import Foreign.StablePtr as Foreign (StablePtr)+import Foreign.Storable as Foreign (Storable)+import GHC.Generics as Generics+  ( Associativity (..)+  , C1+  , Constructor (..)+  , D1+  , Datatype (..)+  , Fixity (..)+  , FixityI (..)+  , Generic (..)+  , Generic1+  , Generically (..)+  , K1 (..)+  , M1 (..)+  , Meta (..)+  , Rec0+  , Rep+  , S1+  , Selector (..)+  , U1 (..)+  , URec+  , V1+  , (:*:) (..)+  , (:+:) (..)+  , (:.:) (..)+  )+import System.Environment as System (getArgs)+import System.Exit as System+  ( ExitCode (..)+  , exitFailure+  , exitSuccess+  , exitWith+  )+import System.Exit qualified+import System.IO as System+  ( FilePath+  , Handle+  , IOMode (..)+  , openFile+  , stderr+  , stdin+  , stdout+  , withFile+  )+import Text.Read as Read+  ( Read+  , reads+  )+import Text.Read qualified as Read+import Type.Reflection as Typeable+  ( TypeRep+  , Typeable+  , typeOf+  , typeRep+  )+import UnliftIO.Async as Concurrency+  ( Async (..)+  , AsyncCancelled (..)+  , Concurrently (..)+  , async+  , asyncBound+  , asyncOn+  , asyncThreadId+  , cancel+  , cancelWith+  , concurrently+  , link+  , link2+  , poll+  , race+  , race_+  , wait+  , waitAny+  , waitAnyCancel+  , waitAnyCatch+  , waitAnyCatchCancel+  , waitBoth+  , waitCatch+  , waitEither+  , waitEitherCancel+  , waitEitherCatch+  , waitEitherCatchCancel+  , waitEither_+  , withAsync+  , withAsyncBound+  , withAsyncOn+  )+import UnliftIO.Chan as Concurrency+  ( Chan+  , dupChan+  , getChanContents+  , newChan+  , readChan+  , writeChan+  , writeList2Chan+  )+import UnliftIO.Concurrent as Concurrency+  ( ThreadId+  , forkFinally+  , forkIO+  , forkIOWithUnmask+  , forkOS+  , forkOn+  , forkOnWithUnmask+  , getNumCapabilities+  , isCurrentThreadBound+  , killThread+  , mkWeakThreadId+  , myThreadId+  , rtsSupportsBoundThreads+  , runInBoundThread+  , runInUnboundThread+  , setNumCapabilities+  , threadCapability+  , threadDelay+  , threadWaitRead+  , threadWaitWrite+  , yield+  )+import UnliftIO.Exception as Exception+  ( Exception+  , IOException+  , SomeAsyncException (SomeAsyncException)+  , SomeException (SomeException)+  , asyncExceptionFromException+  , asyncExceptionToException+  , bracket+  , bracketOnError+  , bracket_+  , catch+  , catchJust+  , catches+  , displayException+  , evaluate+  , finally+  , fromException+  , handle+  , handleJust+  , mask+  , mask_+  , onException+  , toException+  , try+  , tryJust+  , uninterruptibleMask+  , uninterruptibleMask_+  )+import UnliftIO.IORef as Concurrency+import UnliftIO.MVar as Concurrency+  ( MVar+  , isEmptyMVar+  , mkWeakMVar+  , modifyMVar+  , modifyMVarMasked+  , modifyMVarMasked_+  , modifyMVar_+  , newEmptyMVar+  , newMVar+  , putMVar+  , readMVar+  , swapMVar+  , takeMVar+  , tryPutMVar+  , tryReadMVar+  , tryTakeMVar+  , withMVar+  , withMVarMasked+  )+import UnliftIO.QSem as Concurrency+  ( QSem+  , newQSem+  , signalQSem+  , waitQSem+  )+import UnliftIO.QSemN as Concurrency+  ( QSemN+  , newQSemN+  , signalQSemN+  , waitQSemN+  )++-- Type synonymss for lazy texts+type LText = Data.Text.Lazy.Text++type LByteString = Data.ByteString.Lazy.ByteString++-- | The identity function, returns the give value unchanged.+identity :: a -> a+identity x = x++map :: (Functor.Functor f) => (a -> b) -> f a -> f b+map = Functor.fmap++uncons :: [a] -> Maybe (a, [a])+uncons [] = Nothing+uncons (x : xs) = Just (x, xs)++unsnoc :: [x] -> Maybe ([x], x)+unsnoc = Foldable.foldr go Nothing+  where+    go x mxs =+      Just+        ( case mxs of+            Nothing -> ([], x)+            Just (xs, e) -> (x : xs, e)+        )++-- | Apply a function n times to a given value+applyN :: Int -> (a -> a) -> a -> a+applyN n f = Foldable.foldr (.) identity (List.replicate n f)++-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+--+-- >>> readMaybe ("123" :: Text) :: Maybe Int+-- Just 123+--+-- >>> readMaybe ("hello" :: Text) :: Maybe Int+-- Nothing+readMaybe :: (Read b, Conv.StringConv a String) => a -> Maybe b+readMaybe = Read.readMaybe . Conv.toS++-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+-- A 'Left' value indicates a parse error.+--+-- >>> readEither "123" :: Either Text Int+-- Right 123+--+-- >>> readEither "hello" :: Either Text Int+-- Left "Prelude.read: no parse"+readEither :: (Read a, Conv.StringConv String e, Conv.StringConv e String) => e -> Either e a+readEither = first Conv.toS . Read.readEither . Conv.toS++-- | The print function outputs a value of any printable type to the standard+-- output device. Printable types are those that are instances of class Show;+-- print converts values to strings for output using the show operation and adds+-- a newline.+print :: (Trans.MonadIO m, PBase.Show a) => a -> m ()+print = liftIO . PBase.print++-- | Do nothing returning unit inside applicative.+pass :: (Applicative f) => f ()+pass = pure ()++guarded :: (Alternative f) => (a -> Bool) -> a -> f a+guarded p x = Bool.bool empty (pure x) (p x)++guardedA :: (Functor.Functor f, Alternative t) => (a -> f Bool) -> a -> f (t a)+guardedA p x = Bool.bool empty (pure x) `Functor.fmap` p x++-- | Lift an 'IO' operation with 1 argument into another monad+liftIO1 :: (MonadIO m) => (a -> IO b) -> a -> m b+liftIO1 = (.) liftIO++-- | Lift an 'IO' operation with 2 arguments into another monad+liftIO2 :: (MonadIO m) => (a -> b -> IO c) -> a -> b -> m c+liftIO2 = ((.) . (.)) liftIO++show :: (Show a, Conv.StringConv String b) => a -> b+show x = Conv.toS (PBase.show x)+{-# SPECIALIZE show :: (Show a) => a -> Text #-}+{-# SPECIALIZE show :: (Show a) => a -> LText #-}+{-# SPECIALIZE show :: (Show a) => a -> String #-}++#if MIN_VERSION_base(4,8,0)+-- | Terminate main process with failure+die :: Text -> IO a+die err = System.Exit.die (ConvertText.toS err)+#else+-- | Terminate main process with failure+die :: Text -> IO a+die err = hPutStrLn stderr err >> exitFailure+#endif++#if !MIN_VERSION_base(4,8,0)+-- This is a literal copy of the implementation in GHC.List in base-4.10.1.0.++-- | A strictly accumulating version of 'scanl'+{-# NOINLINE [1] scanl' #-}+scanl'           :: (b -> a -> b) -> b -> [a] -> [b]+scanl' = scanlGo'+  where+    scanlGo'           :: (b -> a -> b) -> b -> [a] -> [b]+    scanlGo' f !q ls    = q : (case ls of+                            []   -> []+                            x:xs -> scanlGo' f (f q x) xs)++{-# RULES+"scanl'"  [~1] forall f a bs . scanl' f a bs =+  build (\c n -> a `c` foldr (scanlFB' f c) (flipSeqScanl' n) bs a)+"scanlList'" [1] forall f a bs .+    foldr (scanlFB' f (:)) (flipSeqScanl' []) bs a = tail (scanl' f a bs)+ #-}++{-# INLINE [0] scanlFB' #-}+scanlFB' :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c+scanlFB' f c = \b g -> \x -> let !b' = f x b in b' `c` g b'++{-# INLINE [0] flipSeqScanl' #-}+flipSeqScanl' :: a -> b -> a+flipSeqScanl' a !_b = a+#endif++atomicModifyIORef'_ :: (MonadIO m) => IORef a -> (a -> a) -> m ()+atomicModifyIORef'_ ref f = atomicModifyIORef' ref ((,()) . f)++mapUnliftIO :: (forall a. m a -> n a) -> UnliftIO n -> UnliftIO m+mapUnliftIO nt (UnliftIO f) = UnliftIO $ f . nt++loopM :: (Monad m) => (a -> m (Either a b)) -> a -> m b+loopM act x = do+  res <- act x+  case res of+    Left x' -> loopM act x'+    Right v -> pure v
+ src/Halogen.hs view
@@ -0,0 +1,16 @@+module Halogen+  ( HalogenSocket (..)+  , module Halogen.Data.Slot+  , module Halogen.Component+  , module Halogen.HTML+  , module Halogen.HTML.Core+  , module Halogen.Query+  )+where++import Halogen.Component (Component (..), ComponentSlot, ComponentSlotBox, ComponentSpec' (..), EvalSpec (..), componentSlot, defaultEval, hoist, mkComponent, mkEval)+import Halogen.Data.Slot (Slot, VoidF)+import Halogen.HTML (ComponentHTML)+import Halogen.HTML.Core (AttrName (..), ClassName (..), ElemName (..), Namespace (..), PropName (..))+import Halogen.IO.Driver (HalogenSocket (..))+import Halogen.Query (ForkId, HalogenF (..), HalogenM (..), HalogenQ (..), RefLabel (..), Request, SubscriptionId, Tell, fork, getHTMLElementRef, getRef, join, kill, mkRequest, mkTell, query, queryAll, raise, request, requestAll, subscribe, subscribe', tell, tellAll, unsubscribe)
+ src/Halogen/Component.hs view
@@ -0,0 +1,182 @@+module Halogen.Component where++import Data.Functor.Coyoneda (Coyoneda (..))+import Data.NT+import Data.Row (HasType, Row)+import HPrelude hiding (get)+import Halogen.Data.Slot hiding (pop)+import Halogen.Data.Slot qualified as Slot+import Halogen.HTML.Core+import Halogen.Query.HalogenM (HalogenM)+import Halogen.Query.HalogenM qualified as HM+import Halogen.Query.HalogenQ+import Halogen.VDom.Thunk hiding (hoist)+import Halogen.VDom.Thunk qualified as Thunk++data ComponentSlotBox slots m msg = forall query input output. ComponentSlotBox+  { get :: forall slot. SlotStorage slots slot -> Maybe (slot query output)+  , pop :: forall slot. SlotStorage slots slot -> Maybe (slot query output, SlotStorage slots slot)+  , set :: forall slot. slot query output -> SlotStorage slots slot -> SlotStorage slots slot+  , component :: Component query input output m+  , input :: input+  , output :: output -> Maybe msg+  }++deriving instance Functor (ComponentSlotBox slots' m)++data ComponentSlot (slots :: Row Type) m msg+  = ComponentSlot (ComponentSlotBox slots m msg)+  | ThunkSlot (Thunk (HTML (ComponentSlot slots m msg)) msg)++instance Functor (ComponentSlot slots' m) where+  fmap f = \case+    ComponentSlot box -> ComponentSlot $ map f box+    ThunkSlot t -> ThunkSlot $ mapThunk (bimap (fmap f) f) t++data ComponentSpec' state query action slots input output m n = ComponentSpec+  { initialState :: input -> m state+  , render :: state -> HTML (ComponentSlot slots m action) action+  , eval :: HalogenQ query action input ~> n+  }++type ComponentSpec state query action slots input output m =+  ComponentSpec' state query action slots input output m (HalogenM state action slots output m)++data Component query input output m+  = forall model msg slots.+    Component (ComponentSpec model query msg slots input output m)++mkComponent :: forall state query action slots input output m. ComponentSpec state query action slots input output m -> Component query input output m+mkComponent = Component++-- | Constructs a ComponentSlot+-- |+-- | Takes:+-- | - the slot address label+-- | - the slot address index+-- | - the component for the slot+-- | - the input value to pass to the component+-- | - a function mapping outputs from the component to a query in the parent+componentSlot+  :: forall label+    ->forall query input output slots m action slot+   . (HasType label (Slot query output slot) slots)+  => (KnownSymbol label)+  => (Ord slot)+  => slot+  -> Component query input output m+  -> input+  -> (output -> Maybe action)+  -> ComponentSlotBox slots m action+componentSlot label p component input output =+  ComponentSlotBox+    { get = Slot.lookup label p+    , pop = Slot.pop label p+    , set = Slot.insert label p+    , component+    , input+    , output+    }++-- | Changes the Component's `m` type. A use case for this+-- | might be to interpret some `Free` monad as `IO` so the component can be+-- | used with `runUI`.+hoist+  :: forall query input output m m'+   . (Functor m')+  => (m ~> m')+  -> Component query input output m+  -> Component query input output m'+hoist nat (Component ComponentSpec {render, eval, initialState}) =+  Component+    $ ComponentSpec+      { initialState = runNT nat . initialState+      , render = first (hoistSlot nat) . render+      , eval = NT $ HM.hoist nat . runNT eval+      }++-- | The spec record that `mkEval` accepts to construct a component `eval`+-- | function.+-- |+-- | It's not a requirement to use `mkEval`, and sometimes it's preferrable+-- | to write a component `eval` function from scratch, but often `mkEval` is+-- | more convenient for common cases.+-- |+-- | See below for more details about `mkEval` and `defaultEval`.+data EvalSpec state query action slots input output m = EvalSpec+  { handleAction :: action -> HalogenM state action slots output m ()+  , handleQuery :: forall a. query a -> HalogenM state action slots output m (Maybe a)+  , receive :: input -> Maybe action+  , initialize :: Maybe action+  , finalize :: Maybe action+  }++-- | A default value for `mkEval` that will result in an `eval` that nothing at+-- | all - all incoming actions and queries will be ignored, and no receiver,+-- | initializer, or finalizer will be specified.+-- |+-- | Usually this will be used with record update syntax to override fields to+-- | specify things as needed. If a component only needs to handle actions,+-- | for instance, a usage might be something like this:+-- |+-- | ```purescript+-- | H.mkComponent+-- |   { initialState+-- |   , render+-- |   , eval: H.mkEval (H.defaultEval { handleAction = ?handleAction })+-- |   }+-- | ```+defaultEval :: forall state query action slots input output m. EvalSpec state query action slots input output m+defaultEval =+  EvalSpec+    { handleAction = const (pure ())+    , handleQuery = const (pure Nothing)+    , receive = const Nothing+    , initialize = Nothing+    , finalize = Nothing+    }++-- | Accepts an `EvalSpec` to produce an `eval` function for a component. For+-- | example:+-- |+-- | ```purescript+-- | -- use `defaultEval` and override fields selectively+-- | H.mkEval (H.defaultEval { handleAction = ?handleAction })+-- |+-- | -- or specify all the fields in the `EvalSpec`+-- | H.mkEval+-- |   { handleAction: ?handleAction+-- |   , handleQuery: ?handleQuery+-- |   , receive: ?receive+-- |   , initialize: ?initialize+-- |   , finalize: ?finalize+-- |   }+-- | ```+mkEval+  :: forall state query action slots input output m+   . EvalSpec state query action slots input output m+  -> HalogenQ query action input+    ~> HalogenM state action slots output m+mkEval args@EvalSpec {handleQuery} = NT $ \case+  Initialize a ->+    traverse_ args.handleAction args.initialize $> a+  Finalize a ->+    traverse_ args.handleAction args.finalize $> a+  Receive i a ->+    traverse_ args.handleAction (args.receive i) $> a+  Action action a ->+    args.handleAction action $> a+  Query (Coyoneda req fct) f ->+    map (maybe (f ()) req) . handleQuery $ fct++-- | Changes the ComponentSlot's `m` type.+hoistSlot+  :: forall slots m m' action+   . (Functor m')+  => (m ~> m')+  -> ComponentSlot slots m action+  -> ComponentSlot slots m' action+hoistSlot nat = \case+  ComponentSlot ComponentSlotBox {..} -> ComponentSlot $ ComponentSlotBox {component = hoist nat component, ..}+  ThunkSlot t ->+    ThunkSlot $ Thunk.hoist (first (hoistSlot nat)) t
+ src/Halogen/Component/Debounced.hs view
@@ -0,0 +1,32 @@+-- | Component capable of debouncing actions+module Halogen.Component.Debounced where++import Control.Monad.State.Delayed.Delayer+import Control.Monad.State.Delayed.Trans+import Data.NT+import Data.Time+import HPrelude+import Halogen.Component+import Halogen.Query.HalogenM+import System.IO.Unsafe (unsafePerformIO)++unsafeMkDebouncedComponent+  :: forall state query action slots input output m+   . NominalDiffTime+  -> ComponentSpec' state query action slots input output m (DelayedStateT state (HalogenM state action slots output m))+  -> Component query input output m+unsafeMkDebouncedComponent timeout cs = do+  mkDebouncedComponent' (unsafePerformIO $ mkEmptyDelayer timeout) cs++mkDebouncedComponent'+  :: forall state query action slots input output m+   . Delayer state+  -> ComponentSpec' state query action slots input output m (DelayedStateT state (HalogenM state action slots output m))+  -> Component query input output m+mkDebouncedComponent' delayer ComponentSpec {..} =+  mkComponent+    $ ComponentSpec+      { initialState = initialState+      , render = render+      , eval = NT $ runDelayedStateT delayer . runNT eval+      }
+ src/Halogen/Data/Slot.hs view
@@ -0,0 +1,100 @@+module Halogen.Data.Slot where++import Data.Map.Strict qualified as M+import Data.Row+import Data.Set qualified as S+import GHC.TypeLits (sameSymbol)+import HPrelude++data VoidF p++data Slot (query :: Type -> Type) (output :: Type) (slotType :: Type)++-- some element of the `slots` row type, ordered by label and slot Ord instance+data SlotElem (slots :: Row Type) (slot :: (Type -> Type) -> Type -> Type) where+  SlotElem+    :: (HasType sym' (Slot query output s) slots', KnownSymbol sym', Ord s)+    => Proxy sym'+    -> s+    -> ~(slot query output)+    -> SlotElem slots' slot++instance Eq (SlotElem slots' slot) where+  SlotElem p s _ == SlotElem p' s' _ =+    Just True == do+      Refl <- sameSymbol p p'+      pure $ s == s'++instance Ord (SlotElem slots' slot) where+  SlotElem p s _ `compare` SlotElem p' s' _ =+    case sameSymbol p p' of+      Just Refl -> s `compare` s'+      Nothing -> symbolVal p `compare` symbolVal p'++newtype SlotStorage slots slot = SlotStorage (Set (SlotElem slots slot))++lookup+  :: forall symb+    ->( HasType symb (Slot query output s) slots'+      , KnownSymbol symb+      , Ord s+      )+  => s+  -> SlotStorage slots' slot+  -> Maybe (slot query output)+lookup symb key (SlotStorage s) = do+  SlotElem sym' key' slot <- S.lookupGE (SlotElem (Proxy @symb) key (fix identity)) s+  Refl <- sameSymbol (Proxy @symb) sym'+  guard (key == key')+  pure slot++empty :: SlotStorage slots' slot+empty = SlotStorage S.empty++pop+  :: forall symb+    ->( HasType symb (Slot query output s) slots'+      , KnownSymbol symb+      , Ord s+      )+  => s+  -> SlotStorage slots' slot+  -> Maybe (slot query output, SlotStorage slots' slot)+pop symb key stor@(SlotStorage s) = do+  slot <- lookup symb key stor+  pure (slot, SlotStorage $ S.delete (SlotElem (Proxy @symb) key slot) s)++insert+  :: forall symb+    ->( HasType symb (Slot query output s) slots'+      , KnownSymbol symb+      , Ord s+      )+  => s+  -> slot query output+  -> SlotStorage slots' slot+  -> SlotStorage slots' slot+insert symb key slot = coerce (S.insert (SlotElem (Proxy @symb) key slot))++slots+  :: forall symb+    ->( HasType symb (Slot query output s) slots'+      , KnownSymbol symb+      , Ord s+      )+  => SlotStorage slots' slot+  -> Map s (slot query output)+slots symb (SlotStorage s) =+  M.fromAscList $ mapMaybe flt $ S.toAscList s+  where+    flt (SlotElem symb' key' slot) = do+      Refl <- sameSymbol (Proxy @symb) symb'+      pure (key', slot)++foreachSlot+  :: (Applicative m)+  => SlotStorage slots' slot+  -> (forall query output. slot query output -> m ())+  -> m ()+foreachSlot (SlotStorage s) act =+  for_ @_ @_ @_ @() s $ \(SlotElem _ _ v) -> act v -- TODO no idea why I need to type apply
+ src/Halogen/HTML.hs view
@@ -0,0 +1,147 @@+module Halogen.HTML+  ( ComponentHTML+  , PlainHTML+  , fromPlainHTML+  , mapHTMLAction+  , slot+  , slot_+  , memoized+  , lazy+  -- , lazy2+  -- , lazy3+  , module Halogen.HTML.Core+  , module Halogen.HTML.Elements+  , module Halogen.HTML.Properties+  )+where++{- attrNS, -}++import Data.Foreign+import Data.Row+import HPrelude+import Halogen.Component+import Halogen.Data.Slot (Slot)+import Halogen.HTML.Core (AttrName (..), ClassName (..), ElemName (..), HTML (..), IsProp (..), Namespace (..), PropName (..), handler, text)+import Halogen.HTML.Core qualified as Core+import Halogen.HTML.Elements+import Halogen.HTML.Properties (IProp, attr, prop)+import Halogen.VDom.Thunk++-- | A convenience synonym for the output type of a `render` function for a+-- | component that renders HTML.+-- |+-- | - `action` is the type of actions, events internal to the component that can+-- |   be evaluated with the `handleAction` function+-- | - `slots` is the set of child component types that can be used in the HTML+-- | - `m` is the monad used by the child component during evaluation+type ComponentHTML action slots m = HTML (ComponentSlot slots m action) action++mapHTMLAction :: forall a a' slots m. (a -> a') -> ComponentHTML a slots m -> ComponentHTML a' slots m+mapHTMLAction f = bimap (fmap f) f++-- | A type useful for a chunk of HTML with no slot-embedding or query-raising.+-- |+-- | Often a polymorphic usage of `HTML` is good enough for this, but sometimes+-- | it's useful to have a type like this (and accompanying coercion) when doing+-- | things like creating components that accept a chunk of HTML as part of+-- | their configuration.+type PlainHTML = HTML Void Void++-- | Relaxes the type of `PlainHTML` to make it compatible with all `HTML`.+fromPlainHTML :: forall w i. PlainHTML -> HTML w i+fromPlainHTML = bimap absurd absurd++-- | Defines a slot for a child component. Takes:+-- | - the slot address label+-- | - the slot address index+-- | - the component for the slot+-- | - the input value to pass to the component+-- | - a function mapping outputs from the component to a query in the parent+slot+  :: forall label+    ->forall query action input output slots m slot+   . (HasType label (Slot query output slot) slots, KnownSymbol label, Ord slot)+  => slot+  -> Component query input output m+  -> input+  -> (output -> action)+  -> ComponentHTML action slots m+slot label' p' component _input outputQuery =+  Core.widget (ComponentSlot (componentSlot label' p' component _input (Just . outputQuery)))++-- | Defines a slot for a child component, ignoring its output.+-- |+-- | This variant may be used when the component produces output, but it is not+-- | needed in the current context, or instead of passing `absurd` to `slot`+-- | when the output type is `Void`.+-- |+-- | Takes:+-- | - the slot address label+-- | - the slot address index+-- | - the component for the slot+-- | - the input value to pass to the component+slot_+  :: forall label+    ->forall query action input output slots m slot+   . (HasType label (Slot query output slot) slots, KnownSymbol label, Ord slot)+  => slot+  -> Component query input output m+  -> input+  -> ComponentHTML action slots m+slot_ label' p' component _input =+  Core.widget (ComponentSlot (componentSlot label' p' component _input (const Nothing)))++-- | Optimizes rendering of a subtree given an equality predicate. If an argument+-- | is deemed equivalent to the previous value, rendering and diffing will be+-- | skipped. You should not use this function fully saturated, but instead+-- | partially apply it for use within a Component's scope. For example, to skip+-- | rendering for equal states, just wrap your `render` function.+-- |+-- | ```purescript+-- | myComponent = component+-- |  { render: memoized eq render+-- |  , ...+-- |  }+-- | ```+memoized+  :: forall a action slots m+   . (a -> a -> Bool)+  -> (a -> ComponentHTML action slots m)+  -> a+  -> ComponentHTML action slots m+memoized eqFn f =+  -- Note: This implementation must not be eta-expanded, as it relies on+  -- partial application to work.+  Core.widget . ThunkSlot <$> Thunk (unsafeThunkId f) eqFn f++-- | Skips rendering for referentially equal arguments. You should not use this+-- | function fully saturated, but instead partially apply it for use within a+-- | Component's scope.+lazy+  :: forall a action slots m+   . (a -> ComponentHTML action slots m)+  -> a+  -> ComponentHTML action slots m+lazy = memoized unsafeRefEq++{-+-- | Like `lazy`, but for a rendering function which takes 2 arguments.+lazy2+  :: forall a b action slots m+   . (a -> b -> ComponentHTML action slots m)+  -> a+  -> b+  -> ComponentHTML action slots m+lazy2 f a b = Core.widget (ThunkSlot (Fn.runFn3 thunk2 f a b))++-- | Like `lazy`, but for a rendering function which takes 3 arguments.+lazy3+  :: forall a b c action slots m+   . (a -> b -> c -> ComponentHTML action slots m)+  -> a+  -> b+  -> c+  -> ComponentHTML action slots m+lazy3 f a b c = Core.widget (ThunkSlot (Fn.runFn4 thunk3 f a b c))+-}
+ src/Halogen/HTML/Core.hs view
@@ -0,0 +1,120 @@+module Halogen.HTML.Core (module Halogen.HTML.Core, module Web.HTML.Common, Namespace (..), ElemName (..)) where++import DOM.HTML.Indexed+import Data.MediaType+import HPrelude+import Halogen.Query.Input+import Halogen.VDom.DOM.Prop+import Halogen.VDom.Types as VDom+import Web.DOM.Element+import Web.Event.Event+import Web.HTML.Common++newtype HTML w i = HTML {unHTML :: VDom [Prop (Input i)] w}++unHTML :: HTML w i -> VDom [Prop (Input i)] w+unHTML = coerce++instance Bifunctor HTML where+  bimap f g (HTML vdom) = HTML $ bimap (fmap (fmap (fmap g))) f vdom++instance Functor (HTML w) where+  fmap = second++renderWidget :: (i -> j) -> (w -> HTML x j) -> HTML w i -> HTML x j+renderWidget f g (HTML vdom) =+  HTML (VDom.renderWidget (map (map (map f))) ((.unHTML) . g) vdom)++widget :: p -> HTML p q+widget = HTML . VDom.Widget++-- | Constructs a text node `HTML` value.+text :: Text -> HTML w i+text = HTML . VDom.Text++-- | A smart constructor for HTML elements.+element :: forall w i. Maybe VDom.Namespace -> VDom.ElemName -> [Prop i] -> [HTML w i] -> HTML w i+element ns en props htmls = HTML $ VDom.Elem ns en (map (fmap Action) props) (fmap (.unHTML) htmls)++-- | A smart constructor for HTML elements with keyed children.+keyed :: forall w i. Maybe VDom.Namespace -> VDom.ElemName -> [Prop i] -> [(Text, HTML w i)] -> HTML w i+keyed ns name props children = HTML $ VDom.Keyed ns name (map (fmap Action) props) (map (second unHTML) children)++-- | Create a HTML property.+prop :: forall value i. (IsProp value) => PropName value -> value -> Prop i+prop name = Property name . toPropValue++-- | Create a HTML attribute.+attr :: Maybe VDom.Namespace -> AttrName -> Text -> Prop i+attr = Attribute++-- | Create an event handler.+handler :: EventType -> (Event -> Maybe i) -> Prop i+handler = Handler++ref :: forall i. (Maybe Element -> Maybe i) -> Prop i+ref f =+  Ref+    $ f+    . \case+      Created x -> Just x+      Removed _ -> Nothing++class IsProp a where+  toPropValue :: a -> PropValue a++instance {-# OVERLAPPABLE #-} (Integral a) => IsProp a where toPropValue = IntProp++instance {-# OVERLAPPING #-} IsProp Text where toPropValue = TxtProp++instance {-# OVERLAPPING #-} IsProp Double where toPropValue = NumProp++instance {-# OVERLAPPING #-} IsProp Bool where toPropValue = BoolProp++instance IsProp MediaType where+  toPropValue = ViaTxtProp coerce++instance IsProp ButtonType where+  toPropValue = ViaTxtProp renderButtonType++instance IsProp CrossOriginValue where+  toPropValue = ViaTxtProp renderCrossOriginValue++instance IsProp DirValue where+  toPropValue = ViaTxtProp renderDirValue++instance IsProp FormMethod where+  toPropValue = ViaTxtProp renderFormMethod++instance IsProp InputType where+  toPropValue = ViaTxtProp renderInputType++instance IsProp KindValue where+  toPropValue = ViaTxtProp renderKindValue++instance IsProp MenuitemType where+  toPropValue = ViaTxtProp renderMenuitemType++instance IsProp MenuType where+  toPropValue = ViaTxtProp renderMenuType++instance IsProp AutocompleteType where+  toPropValue = ViaTxtProp renderAutocompleteType++instance IsProp OrderedListType where+  toPropValue = ViaTxtProp renderOrderedListType++instance IsProp PreloadValue where+  toPropValue = ViaTxtProp renderPreloadValue++instance IsProp ScopeValue where+  toPropValue = ViaTxtProp renderScopeValue++instance IsProp StepValue where+  toPropValue = ViaTxtProp renderStepValue++instance IsProp WrapValue where+  toPropValue = ViaTxtProp renderWrapValue++instance IsProp InputAcceptType where+  toPropValue = ViaTxtProp renderInputAcceptType
+ src/Halogen/HTML/Elements.hs view
@@ -0,0 +1,652 @@+module Halogen.HTML.Elements where++import DOM.HTML.Indexed qualified as I+import Data.Coerce+import HPrelude hiding (div, head, map)+import Halogen.HTML.Core (HTML (..))+import Halogen.HTML.Properties hiding (style, title)+import Halogen.VDom qualified as VDom+import Halogen.VDom.Types++type Node r w msg = [IProp r msg] -> [HTML w msg] -> HTML w msg++type Leaf r w msg = [IProp r msg] -> HTML w msg++type Array a = [a]++-- | Creates an HTML element that expects indexed properties.+element :: forall r w i. ElemName -> Array (IProp r i) -> Array (HTML w i) -> HTML w i+element en props htmls =+  HTML $ VDom.Elem Nothing en (coerce props) (fmap (.unHTML) htmls)++-- | Creates a Namespaced HTML element that expects indexed properties.+elementNS :: forall r w i. Namespace -> ElemName -> Array (IProp r i) -> Array (HTML w i) -> HTML w i+elementNS ns en props htmls =+  HTML $ VDom.Elem (Just ns) en (coerce props) (fmap (.unHTML) htmls)++-- | Creates an HTML element that expects indexed properties, with keyed+-- | children.+keyed :: forall r w i. ElemName -> Array (IProp r i) -> Array (Text, HTML w i) -> HTML w i+keyed _name props children =+  HTML $ VDom.Keyed Nothing _name (coerce props) (fmap (second (.unHTML)) children)++-- | Creates a Namespaced HTML element that expects indexed properties, with+-- | keyed children.+keyedNS :: forall r w i. Namespace -> ElemName -> Array (IProp r i) -> Array (Text, HTML w i) -> HTML w i+keyedNS ns _name props children =+  HTML $ VDom.Keyed (Just ns) _name (coerce props) (fmap (second (.unHTML)) children)++withKeys :: forall r w i. (Array (IProp r i) -> Array (HTML w i) -> HTML w i) -> Array (IProp r i) -> Array (Text, HTML w i) -> HTML w i+withKeys ctor props children =+  case ctor props [] of+    HTML (VDom.Elem x y z _) -> HTML (VDom.Keyed x y z (coerce children))+    h -> h++withKeys_ :: forall w i. (Array (HTML w i) -> HTML w i) -> Array (Text, HTML w i) -> HTML w i+withKeys_ ctor children =+  case ctor [] of+    HTML (VDom.Elem x y z _) -> HTML (VDom.Keyed x y z (coerce children))+    h -> h++a :: forall w i. Node I.HTMLa w i+a = element (ElemName "a")++a_ :: forall w i. Array (HTML w i) -> HTML w i+a_ = a []++abbr :: forall w i. Node I.HTMLabbr w i+abbr = element (ElemName "abbr")++abbr_ :: forall w i. Array (HTML w i) -> HTML w i+abbr_ = abbr []++address :: forall w i. Node I.HTMLaddress w i+address = element (ElemName "address")++address_ :: forall w i. Array (HTML w i) -> HTML w i+address_ = address []++area :: forall w i. Leaf I.HTMLarea w i+area props = element (ElemName "area") props []++article :: forall w i. Node I.HTMLarticle w i+article = element (ElemName "article")++article_ :: forall w i. Array (HTML w i) -> HTML w i+article_ = article []++aside :: forall w i. Node I.HTMLaside w i+aside = element (ElemName "aside")++aside_ :: forall w i. Array (HTML w i) -> HTML w i+aside_ = aside []++audio :: forall w i. Node I.HTMLaudio w i+audio = element (ElemName "audio")++audio_ :: forall w i. Array (HTML w i) -> HTML w i+audio_ = audio []++b :: forall w i. Node I.HTMLb w i+b = element (ElemName "b")++b_ :: forall w i. Array (HTML w i) -> HTML w i+b_ = b []++base :: forall w i. Leaf I.HTMLbase w i+base props = element (ElemName "base") props []++bdi :: forall w i. Node I.HTMLbdi w i+bdi = element (ElemName "bdi")++bdi_ :: forall w i. Array (HTML w i) -> HTML w i+bdi_ = bdi []++bdo :: forall w i. Node I.HTMLbdo w i+bdo = element (ElemName "bdo")++bdo_ :: forall w i. Array (HTML w i) -> HTML w i+bdo_ = bdo []++blockquote :: forall w i. Node I.HTMLblockquote w i+blockquote = element (ElemName "blockquote")++blockquote_ :: forall w i. Array (HTML w i) -> HTML w i+blockquote_ = blockquote []++body :: forall w i. Node I.HTMLbody w i+body = element (ElemName "body")++body_ :: forall w i. Array (HTML w i) -> HTML w i+body_ = body []++br :: forall w i. Leaf I.HTMLbr w i+br props = element (ElemName "br") props []++br_ :: forall w i. HTML w i+br_ = br []++button :: forall w i. Node I.HTMLbutton w i+button = element (ElemName "button")++button_ :: forall w i. Array (HTML w i) -> HTML w i+button_ = button []++canvas :: forall w i. Leaf I.HTMLcanvas w i+canvas props = element (ElemName "canvas") props []++caption :: forall w i. Node I.HTMLcaption w i+caption = element (ElemName "caption")++caption_ :: forall w i. Array (HTML w i) -> HTML w i+caption_ = caption []++cite :: forall w i. Node I.HTMLcite w i+cite = element (ElemName "cite")++cite_ :: forall w i. Array (HTML w i) -> HTML w i+cite_ = cite []++code :: forall w i. Node I.HTMLcode w i+code = element (ElemName "code")++code_ :: forall w i. Array (HTML w i) -> HTML w i+code_ = code []++col :: forall w i. Leaf I.HTMLcol w i+col props = element (ElemName "col") props []++colgroup :: forall w i. Node I.HTMLcolgroup w i+colgroup = element (ElemName "colgroup")++colgroup_ :: forall w i. Array (HTML w i) -> HTML w i+colgroup_ = colgroup []++command :: forall w i. Leaf I.HTMLcommand w i+command props = element (ElemName "command") props []++datalist :: forall w i. Node I.HTMLdatalist w i+datalist = element (ElemName "datalist")++datalist_ :: forall w i. Array (HTML w i) -> HTML w i+datalist_ = datalist []++dd :: forall w i. Node I.HTMLdd w i+dd = element (ElemName "dd")++dd_ :: forall w i. Array (HTML w i) -> HTML w i+dd_ = dd []++del :: forall w i. Node I.HTMLdel w i+del = element (ElemName "del")++del_ :: forall w i. Array (HTML w i) -> HTML w i+del_ = del []++details :: forall w i. Node I.HTMLdetails w i+details = element (ElemName "details")++details_ :: forall w i. Array (HTML w i) -> HTML w i+details_ = details []++dfn :: forall w i. Node I.HTMLdfn w i+dfn = element (ElemName "dfn")++dfn_ :: forall w i. Array (HTML w i) -> HTML w i+dfn_ = dfn []++dialog :: forall w i. Node I.HTMLdialog w i+dialog = element (ElemName "dialog")++dialog_ :: forall w i. Array (HTML w i) -> HTML w i+dialog_ = dialog []++div :: forall w i. Node I.HTMLdiv w i+div = element (ElemName "div")++div_ :: forall w i. Array (HTML w i) -> HTML w i+div_ = div []++dl :: forall w i. Node I.HTMLdl w i+dl = element (ElemName "dl")++dl_ :: forall w i. Array (HTML w i) -> HTML w i+dl_ = dl []++dt :: forall w i. Node (I.HTMLdt) w i+dt = element (ElemName "dt")++dt_ :: forall w i. Array (HTML w i) -> HTML w i+dt_ = dt []++em :: forall w i. Node I.HTMLem w i+em = element (ElemName "em")++em_ :: forall w i. Array (HTML w i) -> HTML w i+em_ = em []++embed :: forall w i. Node I.HTMLembed w i+embed = element (ElemName "embed")++embed_ :: forall w i. Array (HTML w i) -> HTML w i+embed_ = embed []++fieldset :: forall w i. Node I.HTMLfieldset w i+fieldset = element (ElemName "fieldset")++fieldset_ :: forall w i. Array (HTML w i) -> HTML w i+fieldset_ = fieldset []++figcaption :: forall w i. Node I.HTMLfigcaption w i+figcaption = element (ElemName "figcaption")++figcaption_ :: forall w i. Array (HTML w i) -> HTML w i+figcaption_ = figcaption []++figure :: forall w i. Node I.HTMLfigure w i+figure = element (ElemName "figure")++figure_ :: forall w i. Array (HTML w i) -> HTML w i+figure_ = figure []++footer :: forall w i. Node I.HTMLfooter w i+footer = element (ElemName "footer")++footer_ :: forall w i. Array (HTML w i) -> HTML w i+footer_ = footer []++form :: forall w i. Node I.HTMLform w i+form = element (ElemName "form")++form_ :: forall w i. Array (HTML w i) -> HTML w i+form_ = form []++h1 :: forall w i. Node I.HTMLh1 w i+h1 = element (ElemName "h1")++h1_ :: forall w i. Array (HTML w i) -> HTML w i+h1_ = h1 []++h2 :: forall w i. Node I.HTMLh2 w i+h2 = element (ElemName "h2")++h2_ :: forall w i. Array (HTML w i) -> HTML w i+h2_ = h2 []++h3 :: forall w i. Node I.HTMLh3 w i+h3 = element (ElemName "h3")++h3_ :: forall w i. Array (HTML w i) -> HTML w i+h3_ = h3 []++h4 :: forall w i. Node I.HTMLh4 w i+h4 = element (ElemName "h4")++h4_ :: forall w i. Array (HTML w i) -> HTML w i+h4_ = h4 []++h5 :: forall w i. Node I.HTMLh5 w i+h5 = element (ElemName "h5")++h5_ :: forall w i. Array (HTML w i) -> HTML w i+h5_ = h5 []++h6 :: forall w i. Node I.HTMLh6 w i+h6 = element (ElemName "h6")++h6_ :: forall w i. Array (HTML w i) -> HTML w i+h6_ = h6 []++head :: forall w i. Node I.HTMLhead w i+head = element (ElemName "head")++head_ :: forall w i. Array (HTML w i) -> HTML w i+head_ = head []++header :: forall w i. Node I.HTMLheader w i+header = element (ElemName "header")++header_ :: forall w i. Array (HTML w i) -> HTML w i+header_ = header []++hr :: forall w i. Leaf I.HTMLhr w i+hr props = element (ElemName "hr") props []++hr_ :: forall w i. HTML w i+hr_ = hr []++html :: forall w i. Node I.HTMLhtml w i+html = element (ElemName "html")++html_ :: forall w i. Array (HTML w i) -> HTML w i+html_ = html []++i :: forall w i. Node I.HTMLi w i+i = element (ElemName "i")++i_ :: forall w i. Array (HTML w i) -> HTML w i+i_ = i []++iframe :: forall w i. Leaf I.HTMLiframe w i+iframe props = element (ElemName "iframe") props []++img :: forall w i. Leaf I.HTMLimg w i+img props = element (ElemName "img") props []++input :: forall w i. Leaf I.HTMLinput w i+input props = element (ElemName "input") props []++ins :: forall w i. Node I.HTMLins w i+ins = element (ElemName "ins")++ins_ :: forall w i. Array (HTML w i) -> HTML w i+ins_ = ins []++kbd :: forall w i. Node I.HTMLkbd w i+kbd = element (ElemName "kbd")++kbd_ :: forall w i. Array (HTML w i) -> HTML w i+kbd_ = kbd []++label :: forall w i. Node I.HTMLlabel w i+label = element (ElemName "label")++label_ :: forall w i. Array (HTML w i) -> HTML w i+label_ = label []++legend :: forall w i. Node I.HTMLlegend w i+legend = element (ElemName "legend")++legend_ :: forall w i. Array (HTML w i) -> HTML w i+legend_ = legend []++li :: forall w i. Node I.HTMLli w i+li = element (ElemName "li")++li_ :: forall w i. Array (HTML w i) -> HTML w i+li_ = li []++link :: forall w i. Leaf I.HTMLlink w i+link props = element (ElemName "link") props []++main :: forall w i. Node I.HTMLmain w i+main = element (ElemName "main")++main_ :: forall w i. Array (HTML w i) -> HTML w i+main_ = main []++map :: forall w i. Node I.HTMLmap w i+map = element (ElemName "map")++map_ :: forall w i. Array (HTML w i) -> HTML w i+map_ = map []++mark :: forall w i. Node I.HTMLmark w i+mark = element (ElemName "mark")++mark_ :: forall w i. Array (HTML w i) -> HTML w i+mark_ = mark []++menu :: forall w i. Node I.HTMLmenu w i+menu = element (ElemName "menu")++menu_ :: forall w i. Array (HTML w i) -> HTML w i+menu_ = menu []++menuitem :: forall w i. Node I.HTMLmenuitem w i+menuitem = element (ElemName "menuitem")++menuitem_ :: forall w i. Array (HTML w i) -> HTML w i+menuitem_ = menuitem []++meta :: forall w i. Leaf I.HTMLmeta w i+meta props = element (ElemName "meta") props []++meter :: forall w i. Node I.HTMLmeter w i+meter = element (ElemName "meter")++meter_ :: forall w i. Array (HTML w i) -> HTML w i+meter_ = meter []++nav :: forall w i. Node I.HTMLnav w i+nav = element (ElemName "nav")++nav_ :: forall w i. Array (HTML w i) -> HTML w i+nav_ = nav []++noscript :: forall w i. Node I.HTMLnoscript w i+noscript = element (ElemName "noscript")++noscript_ :: forall w i. Array (HTML w i) -> HTML w i+noscript_ = noscript []++object :: forall w i. Node I.HTMLobject w i+object = element (ElemName "object")++object_ :: forall w i. Array (HTML w i) -> HTML w i+object_ = object []++ol :: forall w i. Node I.HTMLol w i+ol = element (ElemName "ol")++ol_ :: forall w i. Array (HTML w i) -> HTML w i+ol_ = ol []++optgroup :: forall w i. Node I.HTMLoptgroup w i+optgroup = element (ElemName "optgroup")++optgroup_ :: forall w i. Array (HTML w i) -> HTML w i+optgroup_ = optgroup []++option :: forall w i. Node I.HTMLoption w i+option = element (ElemName "option")++option_ :: forall w i. Array (HTML w i) -> HTML w i+option_ = option []++output :: forall w i. Node I.HTMLoutput w i+output = element (ElemName "output")++output_ :: forall w i. Array (HTML w i) -> HTML w i+output_ = output []++p :: forall w i. Node I.HTMLp w i+p = element (ElemName "p")++p_ :: forall w i. Array (HTML w i) -> HTML w i+p_ = p []++param :: forall w i. Leaf I.HTMLparam w i+param props = element (ElemName "param") props []++pre :: forall w i. Node I.HTMLpre w i+pre = element (ElemName "pre")++pre_ :: forall w i. Array (HTML w i) -> HTML w i+pre_ = pre []++progress :: forall w i. Node I.HTMLprogress w i+progress = element (ElemName "progress")++progress_ :: forall w i. Array (HTML w i) -> HTML w i+progress_ = progress []++q :: forall w i. Node I.HTMLq w i+q = element (ElemName "q")++q_ :: forall w i. Array (HTML w i) -> HTML w i+q_ = q []++rp :: forall w i. Node I.HTMLrp w i+rp = element (ElemName "rp")++rp_ :: forall w i. Array (HTML w i) -> HTML w i+rp_ = rp []++rt :: forall w i. Node I.HTMLrt w i+rt = element (ElemName "rt")++rt_ :: forall w i. Array (HTML w i) -> HTML w i+rt_ = rt []++ruby :: forall w i. Node I.HTMLruby w i+ruby = element (ElemName "ruby")++ruby_ :: forall w i. Array (HTML w i) -> HTML w i+ruby_ = ruby []++samp :: forall w i. Node I.HTMLsamp w i+samp = element (ElemName "samp")++samp_ :: forall w i. Array (HTML w i) -> HTML w i+samp_ = samp []++script :: forall w i. Node I.HTMLscript w i+script = element (ElemName "script")++script_ :: forall w i. Array (HTML w i) -> HTML w i+script_ = script []++section :: forall w i. Node I.HTMLsection w i+section = element (ElemName "section")++section_ :: forall w i. Array (HTML w i) -> HTML w i+section_ = section []++select :: forall w i. Node I.HTMLselect w i+select = element (ElemName "select")++select_ :: forall w i. Array (HTML w i) -> HTML w i+select_ = select []++small :: forall w i. Node I.HTMLsmall w i+small = element (ElemName "small")++small_ :: forall w i. Array (HTML w i) -> HTML w i+small_ = small []++source :: forall w i. Leaf I.HTMLsource w i+source props = element (ElemName "source") props []++span :: forall w i. Node I.HTMLspan w i+span = element (ElemName "span")++span_ :: forall w i. Array (HTML w i) -> HTML w i+span_ = span []++strong :: forall w i. Node I.HTMLstrong w i+strong = element (ElemName "strong")++strong_ :: forall w i. Array (HTML w i) -> HTML w i+strong_ = strong []++style :: forall w i. Node I.HTMLstyle w i+style = element (ElemName "style")++style_ :: forall w i. Array (HTML w i) -> HTML w i+style_ = style []++sub :: forall w i. Node I.HTMLsub w i+sub = element (ElemName "sub")++sub_ :: forall w i. Array (HTML w i) -> HTML w i+sub_ = sub []++summary :: forall w i. Node I.HTMLsummary w i+summary = element (ElemName "summary")++summary_ :: forall w i. Array (HTML w i) -> HTML w i+summary_ = summary []++sup :: forall w i. Node I.HTMLsup w i+sup = element (ElemName "sup")++sup_ :: forall w i. Array (HTML w i) -> HTML w i+sup_ = sup []++table :: forall w i. Node I.HTMLtable w i+table = element (ElemName "table")++table_ :: forall w i. Array (HTML w i) -> HTML w i+table_ = table []++tbody :: forall w i. Node I.HTMLtbody w i+tbody = element (ElemName "tbody")++tbody_ :: forall w i. Array (HTML w i) -> HTML w i+tbody_ = tbody []++td :: forall w i. Node I.HTMLtd w i+td = element (ElemName "td")++td_ :: forall w i. Array (HTML w i) -> HTML w i+td_ = td []++textarea :: forall w i. Leaf I.HTMLtextarea w i+textarea es = element (ElemName "textarea") es []++tfoot :: forall w i. Node I.HTMLtfoot w i+tfoot = element (ElemName "tfoot")++tfoot_ :: forall w i. Array (HTML w i) -> HTML w i+tfoot_ = tfoot []++th :: forall w i. Node I.HTMLth w i+th = element (ElemName "th")++th_ :: forall w i. Array (HTML w i) -> HTML w i+th_ = th []++thead :: forall w i. Node I.HTMLthead w i+thead = element (ElemName "thead")++thead_ :: forall w i. Array (HTML w i) -> HTML w i+thead_ = thead []++time :: forall w i. Node I.HTMLtime w i+time = element (ElemName "time")++time_ :: forall w i. Array (HTML w i) -> HTML w i+time_ = time []++title :: forall w i. Node I.HTMLtitle w i+title = element (ElemName "title")++title_ :: forall w i. Array (HTML w i) -> HTML w i+title_ = title []++tr :: forall w i. Node I.HTMLtr w i+tr = element (ElemName "tr")++tr_ :: forall w i. Array (HTML w i) -> HTML w i+tr_ = tr []++track :: forall w i. Leaf I.HTMLtrack w i+track props = element (ElemName "track") props []++u :: forall w i. Node I.HTMLu w i+u = element (ElemName "u")++u_ :: forall w i. Array (HTML w i) -> HTML w i+u_ = u []++ul :: forall w i. Node I.HTMLul w i+ul = element (ElemName "ul")++ul_ :: forall w i. Array (HTML w i) -> HTML w i+ul_ = ul []++var :: forall w i. Node I.HTMLvar w i+var = element (ElemName "var")++var_ :: forall w i. Array (HTML w i) -> HTML w i+var_ = var []++video :: forall w i. Node I.HTMLvideo w i+video = element (ElemName "video")++video_ :: forall w i. Array (HTML w i) -> HTML w i+video_ = video []++wbr :: forall w i. Leaf I.HTMLwbr w i+wbr props = element (ElemName "wbr") props []
+ src/Halogen/HTML/Events.hs view
@@ -0,0 +1,245 @@+module Halogen.HTML.Events where++import Data.Foreign+import Data.Row+import HPrelude+import Halogen.HTML.Core qualified as Core+import Halogen.HTML.Properties+import Halogen.Query.Input+import Web.Clipboard.ClipboardEvent+import Web.Clipboard.ClipboardEvent.EventTypes qualified as CET+import Web.Event.Event+import Web.Event.Event qualified as EE+import Web.HTML.Event.DragEvent+import Web.HTML.Event.DragEvent.EventTypes qualified as DET+import Web.HTML.Event.EventTypes qualified as ET+import Web.UIEvent.FocusEvent+import Web.UIEvent.FocusEvent.EventTypes qualified as FET+import Web.UIEvent.KeyboardEvent+import Web.UIEvent.KeyboardEvent.EventTypes qualified as KET+import Web.UIEvent.MouseEvent+import Web.UIEvent.MouseEvent.EventTypes qualified as MET+import Web.UIEvent.TouchEvent+import Web.UIEvent.WheelEvent+import Web.UIEvent.WheelEvent.EventTypes qualified as WET++handler :: forall r i. EventType -> (Event -> i) -> IProp r i+handler et f = IProp $ Core.handler et (Just . Action . f)++handler' :: forall r i. EventType -> (Event -> Maybe i) -> IProp r i+handler' et f = IProp $ Core.handler et (fmap Action . f)++onAbort :: forall r i. (HasType "onAbort" Event r) => (Event -> i) -> IProp r i+onAbort = handler (EventType "abort")++onError :: forall r i. (HasType "onError" Event r) => (Event -> i) -> IProp r i+onError = handler ET.error++onLoad :: forall r i. (HasType "onLoad" Event r) => (Event -> i) -> IProp r i+onLoad = handler ET.load++onScroll :: forall r i. (HasType "onScroll" Event r) => (Event -> i) -> IProp r i+onScroll = handler (EventType "scroll")++onChange :: forall r i. (HasType "onChange" Event r) => (Event -> i) -> IProp r i+onChange = handler ET.change++{-+onFileUpload+  :: forall r i t+   . HasType "onChange" Event r+  => Unfoldable t+  => (t File -> i)+  -> IProp r i+onFileUpload f = handler ET.change $+  ( Event.target+      >=> HTMLInputElement.fromEventTarget+      >=>+        HTMLInputElement.files >>> unsafePerformEffect+  )+    >>> maybe none items+    >>> f+-}++onInput :: forall r i. (HasType "onInput" Event r) => (Event -> i) -> IProp r i+onInput = handler ET.input++onInvalid :: forall r i. (HasType "onInvalid" Event r) => (Event -> i) -> IProp r i+onInvalid = handler ET.invalid++onReset :: forall r i. (HasType "onReset" Event r) => (Event -> i) -> IProp r i+onReset = handler (EventType "reset")++onSelect :: forall r i. (HasType "onSelect" Event r) => (Event -> i) -> IProp r i+onSelect = handler ET.select++onSubmit :: forall r i. (HasType "onSubmit" Event r) => (Event -> i) -> IProp r i+onSubmit = handler (EventType "submit")++onTransitionEnd :: forall r i. (HasType "onTransitionEnd" Event r) => (Event -> i) -> IProp r i+onTransitionEnd = handler (EventType "transitionend")++onCopy :: forall r i. (HasType "onCopy" ClipboardEvent r) => (ClipboardEvent -> i) -> IProp r i+onCopy = handler CET.copy . clipboardHandler++onPaste :: forall r i. (HasType "onPaste" ClipboardEvent r) => (ClipboardEvent -> i) -> IProp r i+onPaste = handler CET.paste . clipboardHandler++onCut :: forall r i. (HasType "onCut" ClipboardEvent r) => (ClipboardEvent -> i) -> IProp r i+onCut = handler CET.cut . clipboardHandler++onAuxClick :: forall r i. (HasType "onAuxClick" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onAuxClick = handler MET.auxclick . mouseHandler++onClick :: forall r i. (HasType "onClick" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onClick = handler MET.click . mouseHandler++-- onContextMenu :: forall r i. HasType "onContextMenu" MouseEvent r => (MouseEvent -> i) -> IProp r i+-- onContextMenu = handler ET.contextmenu . mouseHandler++onDoubleClick :: forall r i. (HasType "onDoubleClick" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onDoubleClick = handler MET.dblclick . mouseHandler++onMouseDown :: forall r i. (HasType "onMouseDown" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseDown = handler MET.mousedown . mouseHandler++onMouseEnter :: forall r i. (HasType "onMouseEnter" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseEnter = handler MET.mouseenter . mouseHandler++onMouseLeave :: forall r i. (HasType "onMouseLeave" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseLeave = handler MET.mouseleave . mouseHandler++onMouseMove :: forall r i. (HasType "onMouseMove" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseMove = handler MET.mousemove . mouseHandler++onMouseOver :: forall r i. (HasType "onMouseOver" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseOver = handler MET.mouseover . mouseHandler++onMouseOut :: forall r i. (HasType "onMouseOut" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseOut = handler MET.mouseout . mouseHandler++onMouseUp :: forall r i. (HasType "onMouseUp" MouseEvent r) => (MouseEvent -> i) -> IProp r i+onMouseUp = handler MET.mouseup . mouseHandler++onWheel :: forall r i. (HasType "onWheel" WheelEvent r) => (WheelEvent -> i) -> IProp r i+onWheel = handler WET.wheel . wheelHandler++onKeyDown :: forall r i. (HasType "onKeyDown" KeyboardEvent r) => (KeyboardEvent -> i) -> IProp r i+onKeyDown = handler KET.keydown . keyHandler++-- onKeyPress :: forall r i. HasType "onKeyPress" KeyboardEvent r => (KeyboardEvent -> i) -> IProp r i+-- onKeyPress = handler KET.keypress . keyHandler++onKeyUp :: forall r i. (HasType "onKeyUp" KeyboardEvent r) => (KeyboardEvent -> i) -> IProp r i+onKeyUp = handler KET.keyup . keyHandler++onBlur :: forall r i. (HasType "onBlur" FocusEvent r) => (FocusEvent -> i) -> IProp r i+onBlur = handler ET.blur . focusHandler++onFocus :: forall r i. (HasType "onFocus" FocusEvent r) => (FocusEvent -> i) -> IProp r i+onFocus = handler FET.focus . focusHandler++onFocusIn :: forall r i. (HasType "onFocusIn" FocusEvent r) => (FocusEvent -> i) -> IProp r i+onFocusIn = handler FET.focusin . focusHandler++onFocusOut :: forall r i. (HasType "onFocusOut" FocusEvent r) => (FocusEvent -> i) -> IProp r i+onFocusOut = handler FET.focusout . focusHandler++onDrag :: forall r i. (HasType "onDrag" DragEvent r) => (DragEvent -> i) -> IProp r i+onDrag = handler DET.drag . dragHandler++onDragEnd :: forall r i. (HasType "onDragEnd" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragEnd = handler DET.dragend . dragHandler++onDragExit :: forall r i. (HasType "onDragExit" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragExit = handler DET.dragexit . dragHandler++onDragEnter :: forall r i. (HasType "onDragEnter" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragEnter = handler DET.dragenter . dragHandler++onDragLeave :: forall r i. (HasType "onDragLeave" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragLeave = handler DET.dragleave . dragHandler++onDragOver :: forall r i. (HasType "onDragOver" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragOver = handler DET.dragover . dragHandler++onDragStart :: forall r i. (HasType "onDragStart" DragEvent r) => (DragEvent -> i) -> IProp r i+onDragStart = handler DET.dragstart . dragHandler++onDrop :: forall r i. (HasType "onDrop" DragEvent r) => (DragEvent -> i) -> IProp r i+onDrop = handler DET.drop . dragHandler++onTouchCancel :: forall r i. (HasType "onTouchCancel" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchCancel = handler (EventType "touchcancel") . touchHandler++onTouchEnd :: forall r i. (HasType "onTouchEnd" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchEnd = handler (EventType "touchend") . touchHandler++onTouchEnter :: forall r i. (HasType "onTouchEnter" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchEnter = handler (EventType "touchenter") . touchHandler++onTouchLeave :: forall r i. (HasType "onTouchLeave" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchLeave = handler (EventType "touchleave") . touchHandler++onTouchMove :: forall r i. (HasType "onTouchMove" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchMove = handler (EventType "touchmove") . touchHandler++onTouchStart :: forall r i. (HasType "onTouchStart" TouchEvent r) => (TouchEvent -> i) -> IProp r i+onTouchStart = handler (EventType "touchstart") . touchHandler++onResize :: forall r i. (HasType "onResize" Event r) => (Event -> i) -> IProp r i+onResize = handler (EventType "resize")++keyHandler :: forall i. (KeyboardEvent -> i) -> Event -> i+keyHandler = coerce++mouseHandler :: forall i. (MouseEvent -> i) -> Event -> i+mouseHandler = coerce++wheelHandler :: forall i. (WheelEvent -> i) -> Event -> i+wheelHandler = coerce++focusHandler :: forall i. (FocusEvent -> i) -> Event -> i+focusHandler = coerce++dragHandler :: forall i. (DragEvent -> i) -> Event -> i+dragHandler = coerce++clipboardHandler :: forall i. (ClipboardEvent -> i) -> Event -> i+clipboardHandler = coerce++touchHandler :: forall i. (TouchEvent -> i) -> Event -> i+touchHandler = coerce++-- | Attaches event handler to event `key` with getting `prop` field as an+-- | argument of `handler`.+addForeignPropHandler :: forall value tag r i. EventType -> Text -> (Foreign tag -> Maybe value) -> (value -> i) -> IProp r i+addForeignPropHandler key prop_ reader_ f =+  handler' key $ EE.currentTarget >=> go+  where+    go a = f <$> readProp prop_ reader_ (coerce a)++-- | Attaches an event handler which will produce an input when the value of an+-- | input field changes.+onValueChange :: forall r i. (HasType "value" Text r, HasType "onChange" Event r) => (Text -> i) -> IProp r i+onValueChange = addForeignPropHandler ET.change "value" (Just . foreignToString)++--  | Reacts to the intermediate value change of the input element by checking the input value of event+onInputValueChange :: forall r i. (HasType "value" Text r, HasType "onInput" Event r) => (Text -> Maybe i) -> IProp r i+onInputValueChange f = handler' ET.input $ \ev -> do+  trg <- coerce <$> currentTarget ev+  readProp "value" (f . foreignToString) trg++-- | Attaches an event handler which will produce an input when the seleced index of a+-- | `select` element changes.+onSelectedIndexChange :: forall r i. (HasType "selectedIndex" Int r, HasType "onChange" Event r) => (Int -> i) -> IProp r i+onSelectedIndexChange = addForeignPropHandler ET.change "selectedIndex" (Just . foreignToInt)++-- | Attaches an event handler which will fire on input.+onValueInput :: forall r i. (HasType "value" Text r, HasType "onInput" Event r) => (Text -> i) -> IProp r i+onValueInput = addForeignPropHandler ET.input "value" (Just . foreignToString)++-- | Attaches an event handler which will fire when a checkbox is checked or+-- | unchecked.+onChecked :: forall r i. (HasType "checked" Bool r, HasType "onChange" Event r) => (Bool -> i) -> IProp r i+onChecked = addForeignPropHandler ET.change "checked" (Just . foreignToBool)
+ src/Halogen/HTML/Layout.hs view
@@ -0,0 +1,59 @@+module Halogen.HTML.Layout where++import Data.Default+import HPrelude hiding ((>>))+import Halogen.HTML qualified as HH++class Layout (f :: Type -> Type -> Type) where+  data LayoutSettings f+  data LayoutConstraints f++  layout :: LayoutSettings f -> f w i -> HH.HTML w i+  layoutEnd :: f w i+  addComponent :: LayoutConstraints f -> HH.HTML w i -> f w i -> f w i++addComponent' :: (Layout f, Default (LayoutConstraints f)) => HH.HTML w i -> f w i -> f w i+addComponent' = addComponent def++layout' :: (Layout f, Default (LayoutSettings f)) => f w i -> HH.HTML w i+layout' = layout def++addComponentIf :: (Layout f) => Bool -> LayoutConstraints f -> HH.HTML w i -> f w i -> f w i+addComponentIf b c h a = if b then addComponent c h a else a++addComponentIf' :: (Layout f, Default (LayoutConstraints f)) => Bool -> HH.HTML w i -> f w i -> f w i+addComponentIf' b h a = addComponentIf b def h a++newtype LayoutM f w i = LayoutM (f w i -> f w i)++runLayoutM :: (Layout f) => LayoutSettings f -> LayoutM f w i -> HH.HTML w i+runLayoutM settings (LayoutM f) = layout settings $ f layoutEnd++end :: (Layout f) => LayoutM f w i+end = LayoutM identity++class (Layout f) => AddLayout f w i a | a -> w i where+  (>>) :: a -> LayoutM f w i -> LayoutM f w i++instance (AddLayout f w i a) => AddLayout f w i (Bool, a) where+  (b, f) >> g = if b then f >> g else g++instance (Layout f) => AddLayout f w i (LayoutConstraints f, HH.HTML w i) where+  (c, h) >> LayoutM f = LayoutM $ f . addComponent c h++instance (Layout f, Default (LayoutConstraints f)) => AddLayout f w i (HH.HTML w i) where+  html >> LayoutM f = LayoutM $ f . addComponent @f def html++instance (Layout f) => AddLayout f w i (f w i -> f w i) where+  f >> l = (True, f) >> l++infixr 1 >>++if_ :: Bool -> a -> (Bool, a)+if_ = (,)++with :: LayoutConstraints f -> HH.HTML w i -> (LayoutConstraints f, HH.HTML w i)+with = (,)++-- (>>) :: (Layout f, Default (LayoutConstraints f)) => HH.HTML w i -> LayoutM f w i -> LayoutM f w i+-- html >> LayoutM g = LayoutM $ g . addComponent' html
+ src/Halogen/HTML/Layout/BorderLayout.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Halogen.HTML.Layout.BorderLayout (BorderLayout) where++import Clay qualified as C+import Clay.Extra.Grid qualified as C+import Data.Default+import HPrelude+import Halogen.HTML qualified as HH+import Halogen.HTML.Layout+import Halogen.HTML.Properties qualified as HP++data BorderLayout w i = BorderLayout+  { north :: Last (HH.HTML w i)+  , south :: Last (HH.HTML w i)+  , east :: Last (HH.HTML w i)+  , west :: Last (HH.HTML w i)+  , center :: Last (HH.HTML w i)+  }++borderLayoutStyle :: LayoutSettings BorderLayout -> C.Css+borderLayoutStyle BorderLayoutSettings {..} = do+  C.display C.inlineGrid+  traverse_ C.gridGap gap+  traverse_ C.width width+  traverse_ C.height height++  C.gridTemplateAreas+    $ [ "north north north"+      , "west center east"+      , "south south south"+      ]++  C.gridTemplateColumns [C.auto, C.fr 1, C.auto]+  C.gridTemplateRows [C.auto, C.fr 1, C.auto]++instance Default (LayoutSettings BorderLayout) where+  def =+    BorderLayoutSettings+      { gap = Nothing+      , width = Nothing+      , height = Nothing+      }++instance Layout BorderLayout where+  data LayoutConstraints _ = North | South | East | West | Center++  data LayoutSettings _ = BorderLayoutSettings+    { gap :: forall a. Maybe (C.Size a)+    , width :: forall a. Maybe (C.Size a)+    , height :: forall a. Maybe (C.Size a)+    }++  layout settings BorderLayout {..} =+    HH.div [HP.style $ borderLayoutStyle settings]+      $ catMaybes+        [ HH.div [HP.style $ C.gridArea "north"] . pure <$> getLast north+        , HH.div [HP.style $ C.gridArea "south"] . pure <$> getLast south+        , HH.div [HP.style $ C.gridArea "east"] . pure <$> getLast east+        , HH.div [HP.style $ C.gridArea "west"] . pure <$> getLast west+        , HH.div [HP.style $ C.gridArea "center"] . pure <$> getLast center+        ]++  layoutEnd = BorderLayout mempty mempty mempty mempty mempty++  addComponent side h b = case side of+    North -> b {north = b.north <> pure h}+    South -> b {south = b.south <> pure h}+    East -> b {east = b.east <> pure h}+    West -> b {west = b.west <> pure h}+    Center -> b {center = b.center <> pure h}
+ src/Halogen/HTML/Layout/BoxLayout.hs view
@@ -0,0 +1,28 @@+module Halogen.HTML.Layout.BoxLayout where++import Clay qualified as C+import Data.Default+import HPrelude+import Halogen.HTML qualified as HH+import Halogen.HTML.Layout+import Halogen.HTML.Properties qualified as HP++newtype BoxLayout w i = BoxLayout [HH.HTML w i]++settingsToDir :: LayoutSettings BoxLayout -> C.FlexDirection+settingsToDir Horizontal = C.row+settingsToDir Vertical = C.column++instance Default (LayoutConstraints BoxLayout) where+  def = Next++instance Layout BoxLayout where+  data LayoutConstraints _ = Next+  data LayoutSettings _ = Horizontal | Vertical+  layout settings (BoxLayout children) =+    HH.div+      [HP.style $ C.display C.inlineFlex <> C.flexDirection (settingsToDir settings)]+      $ reverse children++  layoutEnd = BoxLayout []+  addComponent Next h = coerce (h :)
+ src/Halogen/HTML/Layout/GridBagLayout.hs view
@@ -0,0 +1,65 @@+module Halogen.HTML.Layout.GridBagLayout where++import Clay qualified as C+import Clay.Extra.Grid qualified as C+import Data.Default+import HPrelude+import Halogen.HTML qualified as HH+import Halogen.HTML.Layout+import Halogen.HTML.Properties qualified as HP++newtype GridBagLayout w i = GridBagLayout [(LayoutConstraints GridBagLayout, HH.HTML w i)]++gridBagLayoutStyle :: LayoutSettings GridBagLayout -> C.Css+gridBagLayoutStyle GridBagLayoutSettings {..} = do+  C.display C.inlineGrid+  C.gridTemplateColumns $ replicate cols $ C.fr 1+  C.gridTemplateRows $ replicate rows $ C.fr 1++  traverse_ C.gridGap gap+  traverse_ C.width width+  traverse_ C.height height++defGridBagSettings :: LayoutSettings GridBagLayout+defGridBagSettings = def++instance Default (LayoutSettings GridBagLayout) where+  def =+    GridBagLayoutSettings+      { rows = 1+      , cols = 1+      , gap = Nothing+      , width = Nothing+      , height = Nothing+      }++instance Layout GridBagLayout where+  data LayoutConstraints _ = GridBagLayoutConstraints+    { gridx :: Int+    , gridy :: Int+    , gridwidth :: Int+    , gridheight :: Int+    }++  data LayoutSettings GridBagLayout = GridBagLayoutSettings+    { rows :: Int+    , cols :: Int+    , gap :: forall a. Maybe (C.Size a)+    , width :: forall a. Maybe (C.Size a)+    , height :: forall a. Maybe (C.Size a)+    }++  layout settings (GridBagLayout hms) =+    HH.div+      [HP.style $ gridBagLayoutStyle settings]+      $ flip map hms+      $ \(GridBagLayoutConstraints {..}, html) ->+        HH.div+          [ HP.style $ do+              C.gridRow $ toInteger gridx C.// C.span_ (toInteger gridwidth)+              C.gridColumn $ toInteger gridy C.// C.span_ (toInteger gridheight)+          ]+          [html]++  layoutEnd = GridBagLayout []+  addComponent constraints html = coerce $ (:) (constraints, html)
+ src/Halogen/HTML/Layout/GridLayout.hs view
@@ -0,0 +1,46 @@+module Halogen.HTML.Layout.GridLayout where++import Clay qualified as C+import Data.Default+import HPrelude+import Halogen.HTML.Layout+import Halogen.HTML.Layout.GridBagLayout++-- grid layout is like grid-bag but all cells are the same size++newtype GridLayout w i = GridLayout (GridBagLayout w i)++defGridSettings :: LayoutSettings GridLayout+defGridSettings = def++instance Default (LayoutSettings GridLayout) where+  def =+    GridLayoutSettings+      { rows = 0+      , cols = 0+      , gap = Nothing+      , width = Nothing+      , height = Nothing+      }++instance Layout GridLayout where+  data LayoutConstraints _ = GridLayoutConstraints+    { gridx :: Int+    , gridy :: Int+    }++  data LayoutSettings _ = GridLayoutSettings+    { rows :: Int+    , cols :: Int+    , gap :: forall a. Maybe (C.Size a)+    , width :: forall a. Maybe (C.Size a)+    , height :: forall a. Maybe (C.Size a)+    }++  layout GridLayoutSettings {..} (GridLayout gbl) =+    layout GridBagLayoutSettings {..} gbl++  layoutEnd = GridLayout $ GridBagLayout []++  addComponent GridLayoutConstraints {..} h (GridLayout gbl) =+    GridLayout $ addComponent GridBagLayoutConstraints {gridwidth = 1, gridheight = 1, ..} h gbl
+ src/Halogen/HTML/Layout/NoLayout.hs view
@@ -0,0 +1,15 @@+module Halogen.HTML.Layout.NoLayout where++import HPrelude+import Halogen.HTML qualified as HH+import Halogen.HTML.Layout++newtype NoLayout w i = NoLayout_ [HH.HTML w i]++instance Layout NoLayout where+  data LayoutConstraints _ = Next+  data LayoutSettings _ = NoLayout+  layout _ (NoLayout_ children) = HH.div [] $ reverse children++  layoutEnd = NoLayout_ []+  addComponent Next h = coerce $ (:) h
+ src/Halogen/HTML/Properties.hs view
@@ -0,0 +1,211 @@+module Halogen.HTML.Properties where++import Clay qualified as C+import Clay.Render qualified as C+import DOM.HTML.Indexed qualified as I+import Data.Coerce+import Data.MediaType+import Data.Row+import Data.Text qualified as T+import HPrelude+import Halogen.HTML.Core (IsProp (..), Namespace)+import Halogen.HTML.Core qualified as Core+import Halogen.Query.Input+import Halogen.VDom.DOM.Prop+import Web.DOM.Element+import Web.HTML.Common++newtype IProp (r :: Row Type) msg = IProp (Prop (Input msg))++prop :: forall value r msg. (IsProp value) => PropName value -> value -> IProp r msg+prop _name val = IProp $ Property _name (toPropValue val)++attr :: AttrName -> Text -> IProp r msg+attr _name val = IProp $ Attribute Nothing _name val++attrNS :: Namespace -> AttrName -> Text -> IProp r i+attrNS ns _name val = IProp $ Attribute (Just ns) _name val++rows :: (HasType "rows" Int r) => Int -> IProp r msg+rows = prop "rows"++-- cast property from smaller row to greater row+castProp :: (Subset r1 r2) => IProp r1 msg -> IProp r2 msg+castProp = coerce++-- | The `ref` property allows an input to be raised once a `HTMLElement` has+-- | been created or destroyed in the DOM for the element that the property is+-- | attached to.+ref :: forall r i. RefLabel -> IProp r i+ref = IProp . Core.ref . go+  where+    go :: RefLabel -> Maybe Element -> Maybe (Input i)+    go p mel = Just (RefUpdate p mel)++alt :: (HasType "alt" Text r) => Text -> IProp r i+alt = prop "alt"++charset :: (HasType "charset" Text r) => Text -> IProp r i+charset = prop "charset"++class_ :: (HasType "class" Text r) => ClassName -> IProp r i+class_ (ClassName txt) = prop "className" txt++classes :: (HasType "class" Text r) => [ClassName] -> IProp r i+classes = prop "className" . T.unwords . coerce++cols :: (HasType "cols" Int r) => Int -> IProp r i+cols = prop "cols"++colSpan :: (HasType "colSpan" Int r) => Int -> IProp r i+colSpan = prop "colSpan"++rowSpan :: (HasType "rowSpan" Int r) => Int -> IProp r i+rowSpan = prop "rowSpan"++for :: (HasType "for" Text r) => Text -> IProp r i+for = prop "htmlFor"++height :: (HasType "height" I.CSSPixel r) => I.CSSPixel -> IProp r i+height = prop "height"++width :: (HasType "width" I.CSSPixel r) => I.CSSPixel -> IProp r i+width = prop "width"++href :: (HasType "href" Text r) => Text -> IProp r i+href = prop "href"++id :: (HasType "id" Text r) => Text -> IProp r i+id = prop "id"++name :: (HasType "name" Text r) => Text -> IProp r i+name = prop "name"++rel :: (HasType "rel" Text r) => Text -> IProp r i+rel = prop "rel"++src :: (HasType "src" Text r) => Text -> IProp r i+src = prop "src"++srcDoc :: (HasType "srcDoc" Text r) => Text -> IProp r i+srcDoc = prop "srcdoc"++style :: (HasType "style" Text r) => C.Css -> IProp r i+style = styleText . toS . C.renderWith C.htmlInline []++styleText :: (HasType "style" Text r) => Text -> IProp r i+styleText = attr (AttrName "style")++scope :: (HasType "scope" I.ScopeValue r) => I.ScopeValue -> IProp r i+scope = prop (PropName "scope")++target :: (HasType "target" Text r) => Text -> IProp r i+target = prop (PropName "target")++title :: (HasType "title" Text r) => Text -> IProp r i+title = prop (PropName "title")++download :: (HasType "download" Text r) => Text -> IProp r i+download = prop (PropName "download")++method :: (HasType "method" I.FormMethod r) => I.FormMethod -> IProp r i+method = prop (PropName "method")++action :: (HasType "action" Text r) => Text -> IProp r i+action = prop (PropName "action")++enctype :: (HasType "enctype" MediaType r) => MediaType -> IProp r i+enctype = prop (PropName "enctype")++noValidate :: (HasType "noValidate" Bool r) => Bool -> IProp r i+noValidate = prop (PropName "noValidate")++type_ :: forall value r i. (HasType "type" value r, IsProp value) => value -> IProp r i+type_ = prop (PropName "type")++value :: forall value r i. (HasType "value" value r, IsProp value) => value -> IProp r i+value = prop (PropName "value")++min :: (HasType "min" Double r) => Double -> IProp r i+min = prop (PropName "min")++minLength :: (HasType "minLength" Int r) => Int -> IProp r i+minLength = prop (PropName "minLength")++max :: (HasType "max" Double r) => Double -> IProp r i+max = prop (PropName "max")++maxLength :: (HasType "maxLength" Int r) => Int -> IProp r i+maxLength = prop (PropName "maxLength")++step :: (HasType "step" I.StepValue r) => I.StepValue -> IProp r i+step = prop (PropName "step")++enabled :: (HasType "disabled" Bool r) => Bool -> IProp r i+enabled = disabled . not++disabled :: (HasType "disabled" Bool r) => Bool -> IProp r i+disabled = prop (PropName "disabled")++required :: (HasType "required" Bool r) => Bool -> IProp r i+required = prop (PropName "required")++readOnly :: (HasType "readOnly" Bool r) => Bool -> IProp r i+readOnly = prop (PropName "readOnly")++spellcheck :: (HasType "spellcheck" Bool r) => Bool -> IProp r i+spellcheck = prop (PropName "spellcheck")++checked :: (HasType "checked" Bool r) => Bool -> IProp r i+checked = prop (PropName "checked")++selected :: (HasType "selected" Bool r) => Bool -> IProp r i+selected = prop (PropName "selected")++selectedIndex :: (HasType "selectedIndex" Int r) => Int -> IProp r i+selectedIndex = prop (PropName "selectedIndex")++placeholder :: (HasType "placeholder" Text r) => Text -> IProp r i+placeholder = prop (PropName "placeholder")++autocomplete :: (HasType "autocomplete" I.AutocompleteType r) => I.AutocompleteType -> IProp r i+autocomplete = prop (PropName "autocomplete")++list :: (HasType "list" Text r) => Text -> IProp r i+list = attr (AttrName "list")++autofocus :: (HasType "autofocus" Bool r) => Bool -> IProp r i+autofocus = prop (PropName "autofocus")++multiple :: (HasType "multiple" Bool r) => Bool -> IProp r i+multiple = prop (PropName "multiple")++accept :: (HasType "accept" I.InputAcceptType r) => I.InputAcceptType -> IProp r i+accept = prop (PropName "accept")++pattern_ :: (HasType "pattern" Text r) => Text -> IProp r i+pattern_ = prop (PropName "pattern")++autoplay :: (HasType "autoplay" Bool r) => Bool -> IProp r i+autoplay = prop (PropName "autoplay")++controls :: (HasType "controls" Bool r) => Bool -> IProp r i+controls = prop (PropName "controls")++loop :: (HasType "loop" Bool r) => Bool -> IProp r i+loop = prop (PropName "loop")++muted :: (HasType "muted" Bool r) => Bool -> IProp r i+muted = prop (PropName "muted")++poster :: (HasType "poster" Text r) => Text -> IProp r i+poster = prop (PropName "poster")++preload :: (HasType "preload" I.PreloadValue r) => I.PreloadValue -> IProp r i+preload = prop (PropName "preload")++draggable :: (HasType "draggable" Bool r) => Bool -> IProp r i+draggable = prop (PropName "draggable")++tabIndex :: (HasType "tabIndex" Int r) => Int -> IProp r i+tabIndex = prop (PropName "tabIndex")
+ src/Halogen/HTML/Properties/ARIA.hs view
@@ -0,0 +1,116 @@+module Halogen.HTML.Properties.ARIA where++import HPrelude+import Halogen.HTML.Core (AttrName (..))+import Halogen.HTML.Properties (IProp, attr)++activeDescendant :: forall r i. Text -> IProp r i+activeDescendant = attr (AttrName "aria-activedescendant")++atomic :: forall r i. Text -> IProp r i+atomic = attr (AttrName "aria-atomic")++autoComplete :: forall r i. Text -> IProp r i+autoComplete = attr (AttrName "aria-autocomplete")++busy :: forall r i. Text -> IProp r i+busy = attr (AttrName "aria-busy")++checked :: forall r i. Text -> IProp r i+checked = attr (AttrName "aria-checked")++controls :: forall r i. Text -> IProp r i+controls = attr (AttrName "aria-controls")++describedBy :: forall r i. Text -> IProp r i+describedBy = attr (AttrName "aria-describedby")++disabled :: forall r i. Text -> IProp r i+disabled = attr (AttrName "aria-disabled")++dropEffect :: forall r i. Text -> IProp r i+dropEffect = attr (AttrName "aria-dropeffect")++expanded :: forall r i. Text -> IProp r i+expanded = attr (AttrName "aria-expanded")++flowTo :: forall r i. Text -> IProp r i+flowTo = attr (AttrName "aria-flowto")++grabbed :: forall r i. Text -> IProp r i+grabbed = attr (AttrName "aria-grabbed")++hasPopup :: forall r i. Text -> IProp r i+hasPopup = attr (AttrName "aria-haspopup")++hidden :: forall r i. Text -> IProp r i+hidden = attr (AttrName "aria-hidden")++invalid :: forall r i. Text -> IProp r i+invalid = attr (AttrName "aria-invalid")++label :: forall r i. Text -> IProp r i+label = attr (AttrName "aria-label")++labelledBy :: forall r i. Text -> IProp r i+labelledBy = attr (AttrName "aria-labelledby")++level :: forall r i. Text -> IProp r i+level = attr (AttrName "aria-level")++live :: forall r i. Text -> IProp r i+live = attr (AttrName "aria-live")++modal :: forall r i. Text -> IProp r i+modal = attr (AttrName "aria-modal")++multiLine :: forall r i. Text -> IProp r i+multiLine = attr (AttrName "aria-multiline")++multiSelectable :: forall r i. Text -> IProp r i+multiSelectable = attr (AttrName "aria-multiselectable")++orientation :: forall r i. Text -> IProp r i+orientation = attr (AttrName "aria-orientation")++owns :: forall r i. Text -> IProp r i+owns = attr (AttrName "aria-owns")++posInSet :: forall r i. Text -> IProp r i+posInSet = attr (AttrName "aria-posinset")++pressed :: forall r i. Text -> IProp r i+pressed = attr (AttrName "aria-pressed")++readOnly :: forall r i. Text -> IProp r i+readOnly = attr (AttrName "aria-readonly")++relevant :: forall r i. Text -> IProp r i+relevant = attr (AttrName "aria-relevant")++required :: forall r i. Text -> IProp r i+required = attr (AttrName "aria-required")++selected :: forall r i. Text -> IProp r i+selected = attr (AttrName "aria-selected")++setSize :: forall r i. Text -> IProp r i+setSize = attr (AttrName "aria-setsize")++sort :: forall r i. Text -> IProp r i+sort = attr (AttrName "aria-sort")++valueMax :: forall r i. Text -> IProp r i+valueMax = attr (AttrName "aria-valuemax")++valueMin :: forall r i. Text -> IProp r i+valueMin = attr (AttrName "aria-valuemin")++valueNow :: forall r i. Text -> IProp r i+valueNow = attr (AttrName "aria-valuenow")++valueText :: forall r i. Text -> IProp r i+valueText = attr (AttrName "aria-valuetext")++role :: forall r i. Text -> IProp r i+role = attr (AttrName "role")
+ src/Halogen/IO/Driver.hs view
@@ -0,0 +1,245 @@+module Halogen.IO.Driver+  ( RenderSpec (..)+  , runUI+  , HalogenSocket (..)+  )+where++import Control.Exception.Safe+import Control.Monad.Fork+import Control.Monad.Parallel+import Control.Monad.UUID+import Data.NT+import Data.Row+import HPrelude hiding (get)+import Halogen.Component+import Halogen.Data.Slot qualified as Slot+import Halogen.HTML.Core qualified as HC+import Halogen.IO.Driver.Eval qualified as Eval+import Halogen.IO.Driver.State+import Halogen.Query.HalogenQ qualified as HQ+import Halogen.Query.Input+import Halogen.Query.Input qualified as Input+import Halogen.Subscription qualified as HS+import Unsafe.Coerce (unsafeCoerce)++data HalogenSocket query output m = HalogenSocket+  { query :: forall a. query a -> m (Maybe a)+  , messages :: HS.Emitter m output+  , dispose :: m ()+  }++data RenderSpec (m :: Type -> Type) (r :: Type -> Type -> Row Type -> Type -> Type) = RenderSpec+  { render+      :: forall s act ps o+       . (Input act -> m ())+      -> (ComponentSlotBox ps m act -> m (RenderStateX r))+      -> HC.HTML (ComponentSlot ps m act) act+      -> Maybe (r s act ps o)+      -> m (r s act ps o)+  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o+  , removeChild :: forall s act ps o. r s act ps o -> m ()+  , dispose :: forall s act ps o. r s act ps o -> m ()+  }++{-# SPECIALIZE runUI :: RenderSpec IO r -> Component f i o IO -> i -> IO (HalogenSocket f o IO) #-}+runUI+  :: forall m r f i o+   . (MonadUnliftIO m, MonadFork m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)+  => RenderSpec m r+  -> Component f i o m+  -> i+  -> m (HalogenSocket f o m)+runUI RenderSpec {..} c i = do+  lchs <- newLifecycleHandlers+  disposed <- newIORef False+  Eval.handleLifecycle lchs $ do+    sio <- HS.create+    dsx@(DriverStateX st) <- readDriverStateRef =<< runComponent lchs (HS.notify sio.listener) i c+    pure+      $ HalogenSocket+        { query = evalDriver disposed st.selfRef+        , messages = sio.emitter+        , dispose = dispose' disposed lchs dsx+        }+  where+    evalDriver+      :: forall s f' act ps i' o'+       . IORef Bool+      -> IORef (DriverState m r s f' act ps i' o')+      -> (forall a. f' a -> m (Maybe a))+    evalDriver disposed ref q =+      readIORef disposed >>= \case+        True -> pure Nothing+        False -> Eval.evalQ render' ref q++    runComponent+      :: forall f' i' o'+       . IORef (LifecycleHandlers m)+      -> (o' -> m ())+      -> i'+      -> Component f' i' o' m+      -> m (DriverStateRef m r f' o')+    runComponent lchs handler j (Component cs) = do+      lchs' <- newLifecycleHandlers+      st <- initDriverState cs j handler lchs'+      pre <- readIORef lchs+      atomicWriteIORef lchs $ LifecycleHandlers {initializers = [], finalizers = pre.finalizers}+      render' lchs st.selfRef+      squashChildInitializers lchs pre.initializers (DriverStateX st)+      pure $ DriverStateRef st.selfRef++    render'+      :: forall s f' act ps i' o'+       . IORef (LifecycleHandlers m)+      -> IORef (DriverState m r s f' act ps i' o')+      -> m ()+    render' lchs var =+      readIORef var >>= \ds -> do+        shouldProcessHandlers <- isNothing <$> readIORef ds.pendingHandlers+        when shouldProcessHandlers $ atomicWriteIORef ds.pendingHandlers (Just [])+        atomicWriteIORef ds.childrenOut Slot.empty+        atomicWriteIORef ds.childrenIn ds.children++        let -- The following 3 defs are working around a capture bug, see #586+            -- pendingHandlers = identity ds.pendingHandlers+            -- pendingQueries = identity ds.pendingQueries+            -- selfRef = identity ds.selfRef++            handler :: Input act -> m ()+            handler = Eval.queueOrRun ds.pendingHandlers . void . Eval.evalF render' ds.selfRef++            childHandler :: act -> m ()+            childHandler = Eval.queueOrRun ds.pendingQueries . handler . Input.Action++        rendering <-+          render+            handler+            (renderChild' lchs childHandler ds.childrenIn ds.childrenOut)+            (ds.component.render ds.state)+            ds.rendering++        children <- readIORef ds.childrenOut+        childrenIn <- readIORef ds.childrenIn++        Slot.foreachSlot childrenIn $ \(DriverStateRef childVar) -> do+          childDS <- DriverStateX <$> readIORef childVar+          renderStateX_ removeChild childDS+          finalize lchs childDS++        atomicModifyIORef'_ ds.selfRef $ \ds' ->+          ds' {rendering = Just rendering, children = children}++        when shouldProcessHandlers $ do+          flip loopM () $ \_ -> do+            handlers <- readIORef ds.pendingHandlers+            atomicWriteIORef ds.pendingHandlers (Just [])+            traverse_ (traverse_ fork . reverse) handlers+            mmore <- readIORef ds.pendingHandlers+            if maybe False null mmore+              then atomicWriteIORef ds.pendingHandlers Nothing $> Right ()+              else pure $ Left ()++    renderChild'+      :: forall ps act+       . IORef (LifecycleHandlers m)+      -> (act -> m ())+      -> IORef (Slot.SlotStorage ps (DriverStateRef m r))+      -> IORef (Slot.SlotStorage ps (DriverStateRef m r))+      -> ComponentSlotBox ps m act+      -> m (RenderStateX r)+    renderChild' lchs handler childrenInRef childrenOutRef ComponentSlotBox {..} = do+      childrenIn <- pop <$> readIORef childrenInRef+      var <- case childrenIn of+        Just (existing, childrenIn') -> do+          atomicWriteIORef childrenInRef childrenIn'+          DriverStateX st <- readDriverStateRef existing+          atomicWriteIORef st.handlerRef $ maybe pass handler . output+          -- FIXME+          void $ Eval.evalM render' st.selfRef (runNT (unsafeCoerce st.component.eval) (HQ.Receive input ()))+          pure existing+        Nothing ->+          runComponent lchs (maybe pass handler . output) input component+      isDuplicate <- isJust . get <$> readIORef childrenOutRef+      when isDuplicate+        $ traceM "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"+      atomicModifyIORef'_ childrenOutRef (set var)+      (readDriverStateRef var >>=) $ renderStateX $ \case+        Nothing -> throwString "Halogen internal error: child was not initialized in renderChild"+        Just r -> pure (renderChild r)++    squashChildInitializers+      :: forall f' o'+       . IORef (LifecycleHandlers m)+      -> [m ()]+      -> DriverStateX m r f' o'+      -> m ()+    squashChildInitializers lchs preInits (DriverStateX st) = do+      let parentInitializer = Eval.evalM render' st.selfRef (runNT st.component.eval (HQ.Initialize ()))+      atomicModifyIORef'_ lchs $ \handlers ->+        handlers+          { initializers =+              ( do+                  parSequence_ (reverse handlers.initializers)+                  parentInitializer+                  handlePending st.pendingQueries+                  handlePending st.pendingOuts+              )+                : preInits+          , finalizers = handlers.finalizers+          }++    finalize+      :: forall f' o'+       . IORef (LifecycleHandlers m)+      -> DriverStateX m r f' o'+      -> m ()+    finalize lchs (DriverStateX DriverState {selfRef}) = do+      st <- readIORef selfRef+      cleanupSubscriptionsAndForks st+      let f = Eval.evalM render' st.selfRef (runNT st.component.eval (HQ.Finalize ()))+      atomicModifyIORef'_ lchs $ \handlers ->+        handlers+          { initializers = handlers.initializers+          , finalizers = f : handlers.finalizers+          }+      Slot.foreachSlot st.children $ \(DriverStateRef ref) -> do+        ds <- DriverStateX <$> readIORef ref+        finalize lchs ds++    dispose'+      :: forall f' o'+       . IORef Bool+      -> IORef (LifecycleHandlers m)+      -> DriverStateX m r f' o'+      -> m ()+    dispose' disposed lchs dsx@(DriverStateX DriverState {selfRef}) = Eval.handleLifecycle lchs $ do+      readIORef disposed >>= \case+        True -> pass+        False -> do+          atomicWriteIORef disposed True+          finalize lchs dsx+          ds <- readIORef selfRef+          for_ ds.rendering dispose++{-# INLINE newLifecycleHandlers #-}+newLifecycleHandlers :: (MonadIO m) => m (IORef (LifecycleHandlers m))+newLifecycleHandlers = newIORef $ LifecycleHandlers {initializers = [], finalizers = []}++{-# SPECIALIZE handlePending :: IORef (Maybe [IO ()]) -> IO () #-}+handlePending :: (MonadIO m, MonadFork m) => IORef (Maybe [m ()]) -> m ()+handlePending ref = do+  queue <- readIORef ref+  atomicWriteIORef ref Nothing+  for_ queue (traverse_ fork . reverse)++{-# SPECIALIZE cleanupSubscriptionsAndForks :: DriverState IO r s f act ps i o -> IO () #-}+cleanupSubscriptionsAndForks+  :: (MonadIO m, MonadKill m)+  => DriverState m r s f act ps i o+  -> m ()+cleanupSubscriptionsAndForks ds = do+  traverse_ (traverse_ HS.unsubscribe) =<< readIORef ds.subscriptions+  atomicWriteIORef ds.subscriptions Nothing+  traverse_ (kill AsyncCancelled) =<< readIORef ds.forks+  atomicWriteIORef ds.forks mempty
+ src/Halogen/IO/Driver/Eval.hs view
@@ -0,0 +1,189 @@+module Halogen.IO.Driver.Eval+  ( Renderer+  , evalF+  , evalQ+  , evalM+  , handleLifecycle+  , queueOrRun+  -- , handleIO+  )+where++import Control.Applicative.Free.Fast+import Control.Exception.Safe (finally)+import Control.Monad.Fork+import Control.Monad.Free.Church (foldF)+import Control.Monad.Parallel+import Data.Foreign+import Data.Functor.Coyoneda+import Data.Map.Strict qualified as M+import Data.NT+import HPrelude hiding (Concurrently, finally, join, runConcurrently, state)+import Halogen.Component+import Halogen.IO.Driver.State+import Halogen.Query.ChildQuery qualified as CQ+import Halogen.Query.HalogenM hiding (fork, join, kill, query, unsubscribe)+import Halogen.Query.HalogenQ qualified as HQ+import Halogen.Query.Input+import Halogen.Query.Input qualified as Input+import Halogen.Subscription qualified as HS++type Renderer m r =+  forall s f act ps i o+   . IORef (LifecycleHandlers m)+  -> IORef (DriverState m r s f act ps i o)+  -> m ()++{-# SPECIALIZE evalF :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> Input act -> IO () #-}+evalF+  :: (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)+  => Renderer m r+  -> IORef (DriverState m r s f act ps i o)+  -> Input act+  -> m ()+evalF render ref = \case+  Input.RefUpdate (Input.RefLabel p) el -> do+    atomicModifyIORef'_ ref $ \st ->+      st {refs = M.alter (const el) p st.refs}+  Input.Action act -> do+    st <- readIORef ref+    evalM render ref (runNT st.component.eval (HQ.Action act ()))++{-# SPECIALIZE evalQ :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> f a -> IO (Maybe a) #-}+evalQ+  :: (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)+  => Renderer m r+  -> IORef (DriverState m r s f act ps i o)+  -> f a+  -> m (Maybe a)+evalQ render ref q = do+  st <- readIORef ref+  evalM render ref (runNT st.component.eval (HQ.Query (Just <$> liftCoyoneda q) (const Nothing)))++{-# SPECIALIZE evalM :: Renderer IO r -> IORef (DriverState IO r s f act ps i o) -> HalogenM s act ps o IO a -> IO a #-}+evalM+  :: forall m r s f act ps i o a+   . (MonadUnliftIO m, MonadParallel m, MonadMask m, MonadFork m, MonadKill m)+  => Renderer m r+  -> IORef (DriverState m r s f act ps i o)+  -> HalogenM s act ps o m a+  -> m a+evalM render initRef (HalogenM hm) = foldF (go initRef) hm+  where+    go+      :: forall x+       . IORef (DriverState m r s f act ps i o)+      -> HalogenF s act ps o m x+      -> m x+    go ref = \case+      State f -> do+        st@DriverState {state, lifecycleHandlers} <- readIORef ref+        case f state of+          (a, state')+            | unsafeRefEq state state' -> pure a+            | otherwise -> do+                atomicWriteIORef ref (st {state = state'})+                handleLifecycle lifecycleHandlers (render lifecycleHandlers ref)+                pure a+      Subscribe fes k -> do+        sid <- fresh SubscriptionId ref+        finalize <- fmap (HS.hoistSubscription (NT liftIO)) $ withRunInIO $ \runInIO -> HS.subscribe (fes sid) $ \act ->+          runInIO $ evalF render ref (Input.Action act)+        DriverState {subscriptions} <- readIORef ref+        atomicModifyIORef'_ subscriptions (map (M.insert sid finalize))+        pure (k sid)+      Unsubscribe sid next -> do+        unsubscribe sid ref+        pure next+      Lift aff ->+        aff+      Unlift q -> withRunInIO $ \runInIO -> q (UnliftIO $ runInIO . evalM render initRef)+      ChildQuery cq ->+        evalChildQuery ref cq+      Raise o a -> do+        DriverState {handlerRef, pendingOuts} <- readIORef ref+        handler <- readIORef handlerRef+        queueOrRun pendingOuts (handler o)+        pure a+      Par (HalogenAp p) -> sequential $ retractAp $ hoistAp (parallel . evalM render ref) p+      Fork hmu k -> do+        fid <- fresh ForkId ref+        DriverState {forks} <- readIORef ref+        doneRef <- newIORef False+        fiber <-+          fork+            $ finally+              ( do+                  atomicModifyIORef'_ forks (M.delete fid)+                  atomicWriteIORef doneRef True+              )+              (evalM render ref hmu)+        unlessM (readIORef doneRef) $ do+          atomicModifyIORef'_ forks (M.insert fid fiber)+        pure (k fid)+      Join fid a -> do+        DriverState {forks} <- readIORef ref+        forkMap <- readIORef forks+        traverse_ join (M.lookup fid forkMap)+        pure a+      Kill fid a -> do+        DriverState {forks} <- readIORef ref+        forkMap <- readIORef forks+        traverse_ (kill AsyncCancelled) (M.lookup fid forkMap)+        pure a+      GetRef (Input.RefLabel p) k -> do+        DriverState {refs} <- readIORef ref+        pure $ k $ M.lookup p refs++    evalChildQuery+      :: IORef (DriverState m r s f act ps i o)+      -> CQ.ChildQuery ps x+      -> m x+    evalChildQuery ref (CQ.ChildQuery unpack query reply) = do+      st <- readIORef ref+      let evalChild (DriverStateRef var) = parallel $ do+            dsx <- readIORef var+            evalQ render dsx.selfRef query+      reply <$> sequential (unpack evalChild st.children)++{-# SPECIALIZE unsubscribe :: SubscriptionId -> IORef (DriverState IO r s f act ps i o) -> IO () #-}+unsubscribe+  :: (MonadIO m)+  => SubscriptionId+  -> IORef (DriverState m r s' f' act' ps' i' o')+  -> m ()+unsubscribe sid ref = do+  DriverState {subscriptions} <- readIORef ref+  subs <- readIORef subscriptions+  traverse_ HS.unsubscribe (M.lookup sid =<< subs)++{-# SPECIALIZE handleLifecycle :: IORef (LifecycleHandlers IO) -> IO a -> IO a #-}+handleLifecycle :: (MonadIO m, MonadParallel m, MonadFork m) => IORef (LifecycleHandlers m) -> m a -> m a+handleLifecycle lchs f = do+  atomicWriteIORef lchs $ LifecycleHandlers {initializers = [], finalizers = []}+  result <- f+  LifecycleHandlers {initializers, finalizers} <- readIORef lchs+  traverse_ fork finalizers+  parSequence_ initializers+  pure result++{-# SPECIALIZE fresh :: (Int -> a) -> IORef (DriverState IO r s f act ps i o) -> IO a #-}+fresh+  :: (MonadIO m)+  => (Int -> a)+  -> IORef (DriverState m r s f act ps i o)+  -> m a+fresh f ref = do+  st <- readIORef ref+  atomicModifyIORef' st.fresh (\i -> (i + 1, f i))++{-# SPECIALIZE queueOrRun :: IORef (Maybe [IO ()]) -> IO () -> IO () #-}+queueOrRun+  :: (MonadIO m)+  => IORef (Maybe [m ()])+  -> m ()+  -> m ()+queueOrRun ref au =+  readIORef ref >>= \case+    Nothing -> au+    Just p -> atomicWriteIORef ref (Just (au : p))
+ src/Halogen/IO/Driver/State.hs view
@@ -0,0 +1,122 @@+module Halogen.IO.Driver.State+  ( LifecycleHandlers (..)+  , DriverState (..)+  , DriverStateRef (..)+  , DriverStateX (..)+  , unDriverStateX+  -- , mkDriverStateXRef+  , readDriverStateRef+  , RenderStateX (..)+  , renderStateX+  , renderStateX_+  -- , unRenderStateX+  , initDriverState+  )+where++import Control.Monad.Fork+import Data.Row+import HPrelude hiding (state)+import Halogen.Component+import Halogen.Data.Slot as SlotStorage+import Halogen.Query.HalogenM+import Halogen.Subscription qualified as HS+import Web.DOM.Element (Element)++data LifecycleHandlers m = LifecycleHandlers+  { initializers :: [m ()]+  , finalizers :: [m ()]+  }++data DriverState m r s f act ps i o = DriverState+  { component :: ComponentSpec s f act ps i o m+  , state :: s+  , refs :: Map Text Element+  , children :: SlotStorage ps (DriverStateRef m r)+  , childrenIn :: IORef (SlotStorage ps (DriverStateRef m r))+  , childrenOut :: IORef (SlotStorage ps (DriverStateRef m r))+  , selfRef :: IORef (DriverState m r s f act ps i o)+  , handlerRef :: IORef (o -> m ())+  , pendingQueries :: IORef (Maybe [m ()])+  , pendingOuts :: IORef (Maybe [m ()])+  , pendingHandlers :: IORef (Maybe [m ()])+  , rendering :: Maybe (r s act ps o)+  , fresh :: IORef Int+  , subscriptions :: IORef (Maybe (Map SubscriptionId (HS.Subscription m)))+  , forks :: IORef (Map ForkId (Fork m ()))+  , lifecycleHandlers :: IORef (LifecycleHandlers m)+  }++data DriverStateX m r f o = forall s act ps i. DriverStateX (DriverState m r s f act ps i o)++data DriverStateRef m r f o = forall s act ps i. DriverStateRef (IORef (DriverState m r s f act ps i o))++{-# INLINE readDriverStateRef #-}+readDriverStateRef :: (MonadIO m) => DriverStateRef m r f o -> m (DriverStateX m r f o)+readDriverStateRef (DriverStateRef ref) = DriverStateX <$> readIORef ref++data RenderStateX (r :: Type -> Type -> Row Type -> Type -> Type) = forall s act ps o. RenderStateX (r s act ps o)++{-# INLINE renderStateX #-}+renderStateX+  :: (Functor m)+  => (forall s act ps. Maybe (r s act ps o) -> m (r s act ps o))+  -> DriverStateX m r f o+  -> m (RenderStateX r)+renderStateX f = unDriverStateX $ \st ->+  RenderStateX <$> f st.rendering++{-# INLINE renderStateX_ #-}+renderStateX_+  :: (Applicative m)+  => (forall s act ps. r s act ps o -> m ())+  -> DriverStateX m r f o+  -> m ()+renderStateX_ f = unDriverStateX $ \st ->+  traverse_ f st.rendering++{-# INLINE unDriverStateX #-}+unDriverStateX :: (forall s act ps i. DriverState m r s f act ps i o -> a) -> DriverStateX m r f o -> a+unDriverStateX f (DriverStateX st) = f st++{-# SPECIALIZE initDriverState :: ComponentSpec s f act ps i o IO -> i -> (o -> IO ()) -> IORef (LifecycleHandlers IO) -> IO (DriverState IO r s f act ps i o) #-}+initDriverState+  :: (MonadIO m)+  => ComponentSpec s f act ps i o m+  -> i+  -> (o -> m ())+  -> IORef (LifecycleHandlers m)+  -> m (DriverState m r s f act ps i o)+initDriverState component input handler lchs = do+  selfRef <- newIORef (fix identity)+  childrenIn <- newIORef SlotStorage.empty+  childrenOut <- newIORef SlotStorage.empty+  handlerRef <- newIORef handler+  pendingQueries <- newIORef (Just [])+  pendingOuts <- newIORef (Just [])+  pendingHandlers <- newIORef Nothing+  fresh <- newIORef 1+  subscriptions <- newIORef (Just mempty)+  forks <- newIORef mempty+  state <- component.initialState input+  let ds =+        DriverState+          { component+          , state+          , refs = mempty+          , children = SlotStorage.empty+          , childrenIn+          , childrenOut+          , selfRef+          , handlerRef+          , pendingQueries+          , pendingOuts+          , pendingHandlers+          , rendering = Nothing+          , fresh+          , subscriptions+          , forks+          , lifecycleHandlers = lchs+          }+  atomicWriteIORef selfRef ds+  pure ds
+ src/Halogen/IO/Util.hs view
@@ -0,0 +1,36 @@+module Halogen.IO.Util where++import HPrelude+import Halogen.VDom.DOM.Monad+import Web.DOM.Internal.Types+import Web.DOM.ParentNode+import Web.HTML.Event.EventTypes qualified as ET+import Web.HTML.HTMLDocument qualified as HTMLDocument+import Web.HTML.HTMLDocument.ReadyState++-- | Waits for the document to load.+awaitLoad :: (MonadDOM m, MonadIO m) => m ()+awaitLoad = do+  rs <- readyState =<< document =<< window+  mvar <- liftIO newEmptyMVar+  case rs of+    Loading -> do+      et <- toEventTarget <$> window+      listener <- mkEventListener (const $ liftIO $ putMVar mvar ())+      addEventListener ET.domcontentloaded listener et+      liftIO $ takeMVar mvar+      removeEventListener ET.domcontentloaded listener et+    _ -> pass++-- | Waits for the document to load and then finds the `body` element.+awaitBody :: (MonadDOM m, MonadIO m) => m HTMLElement+awaitBody = do+  awaitLoad+  body <- selectElement (QuerySelector "body")+  maybe (panic "Could not find body") pure body++-- | Tries to find an element in the document.+selectElement :: (MonadDOM m) => QuerySelector -> m (Maybe HTMLElement)+selectElement query = do+  mel <- (querySelector query . HTMLDocument.toParentNode <=< document) =<< window+  pure $ fromElement =<< mel
+ src/Halogen/Portal.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- | A container component which renders a sub-tree to a DOM node not in the+-- | tree. This is useful for when a child component needs to 'break out' of a+-- | parent, like dialogs, modals, and tooltips, especially if the parent has+-- | z-indexing or overflow: hidden set.+module Halogen.Portal where++import Control.Monad.Fork+import Control.Monad.Parallel+import Control.Monad.UUID+import Data.Functor.Coyoneda (Coyoneda (..), hoistCoyoneda)+import Data.NT+import Data.Row+import HPrelude hiding (State)+import Halogen as H hiding (ChildQuery, State)+import Halogen.HTML as HH+import Halogen.HTML.Properties as HP+import Halogen.IO.Util (awaitBody)+import Halogen.Subscription qualified as HS+import Halogen.VDom.DOM.Monad+import Halogen.VDom.Driver as VDom+import Web.DOM.Internal.Types++data Input query input output m = Input+  { input :: input+  , child :: H.Component query input output m+  , targetElement :: Maybe HTMLElement+  }++data State query input output m = State+  { socket :: Maybe (H.HalogenSocket (Query input query) output m)+  , input :: input+  , child :: H.Component query input output m+  , targetElement :: Maybe HTMLElement+  }++portal+  :: forall label+    ->forall query action input output slots slot m+   . ( HasType label (H.Slot query output slot) slots+     , MonadUnliftIO m+     , MonadDOM m+     , MonadKill m+     , MonadParallel m+     , MonadMask m+     , MonadUUID m+     )+  => (KnownSymbol label)+  => (Ord slot)+  => slot+  -> H.Component query input output m+  -> input+  -> Maybe HTMLElement+  -> (output -> action)+  -> H.ComponentHTML action slots m+portal label' slot' child input' htmlElement handler' =+  HH.slot+    label'+    slot'+    component+    ( Input+        { child+        , input = input'+        , targetElement = htmlElement+        }+    )+    handler'++data Query input query a+  = SetInput input a+  | ChildQuery (query a)++-- wraps the portalled component and provides a SetInput query+-- that can be used by the Portal component to update the child's+-- input when it receives new values from the parent+wrapper+  :: forall query input output m+   . (MonadIO m)+  => H.Component (Query input query) (State query input output m) output m+wrapper =+  H.mkComponent+    $ H.ComponentSpec+      { initialState = pure+      , render+      , eval =+          H.mkEval+            $ H.defaultEval+              { H.handleQuery = handleQuery+              , H.handleAction = H.raise+              }+      }+  where+    render (State {input, child}) =+      HH.div+        [HP.styleText "display: contents"]+        [HH.slot "content" () child input identity]++    handleQuery+      :: forall action a+       . Query input query a+      -> H.HalogenM (State query input output m) action ("content" .== H.Slot _ _ _) output m (Maybe a)+    handleQuery = \case+      SetInput input a -> do+        modify $ \s -> s {input} :: State query input output m+        pure $ Just a+      ChildQuery query -> do+        res <- H.query "content" () query+        pure res++component+  :: forall q i o m+   . (MonadDOM m, MonadUnliftIO m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)+  => H.Component q (Input q i o m) o m+component =+  H.mkComponent+    $ H.ComponentSpec+      { initialState = \Input {..} -> pure State {socket = Nothing, ..}+      , render+      , eval+      }+  where+    eval+      :: H.HalogenQ q o (Input q i o m) ~> H.HalogenM (State q i o m) o Empty o m+    eval = NT $ \case+      H.Initialize a -> do+        state <- get+        UnliftIO f <- lift askUnliftIO+        -- The target element can either be the one supplied by the user, or the+        -- document body. Either way, we'll run the sub-tree at the target and+        -- save the resulting interface.+        target <- maybe (lift awaitBody) pure state.targetElement+        socket@H.HalogenSocket {messages = HS.Emitter k} <- lift $ VDom.runUI wrapper state target+        -- Subscribe to the child component's messages+        void $ H.subscribe $ HS.Emitter $ \emit' ->+          fmap (HS.hoistSubscription (NT f)) $ f $ k $ liftIO . emit'+        modify $ \s -> s {socket = Just socket} :: State q i o m+        pure a+      H.Finalize a -> do+        gets (.socket) >>= traverse_ (lift . (.dispose))+        pure a+      H.Receive (Input {input}) a ->+        gets (.socket)+          >>= \case+            Nothing -> pure a+            Just io -> do+              void $ lift $ ioq io (SetInput input a)+              pure a+      H.Action output a -> do+        H.raise output+        pure a+      H.Query query fail ->+        gets (.socket)+          >>= \case+            Nothing -> pure $ fail ()+            Just io -> lift $ case hoistCoyoneda ChildQuery query of+              Coyoneda k q -> maybe (fail ()) k <$> ioq io q++    -- We don't need to render anything; this component is explicitly meant to be+    -- passed through.+    render :: State q i o m -> H.ComponentHTML o Empty m+    render _ = HH.text ""++    -- This is needed for a hint to the typechecker. Without it there's an+    -- impredicativity issue with `a` when `HalogenIO` is taken from `State`.+    ioq :: forall a. H.HalogenSocket (Query i q) o m -> Query i q a -> m (Maybe a)+    ioq H.HalogenSocket {query} = query
+ src/Halogen/Query.hs view
@@ -0,0 +1,133 @@+-- | Functions and types used to describe the `HalogenF` algebra used in a+-- | component's `eval` function.+module Halogen.Query+  ( Tell+  , mkTell+  , tell+  , tellAll+  , Request+  , mkRequest+  , request+  , requestAll+  , getHTMLElementRef+  , module Halogen.Query.Input+  , module Halogen.Query.HalogenM+  , module Halogen.Query.HalogenQ+  )+where++import Data.Row as Row+import HPrelude+import Halogen.Data.Slot (Slot)+import Halogen.Query.HalogenM (ForkId, HalogenF (..), HalogenM (..), SubscriptionId, fork, getRef, join, kill, query, queryAll, raise, subscribe, subscribe', unsubscribe)+import Halogen.Query.HalogenQ (HalogenQ (..))+import Halogen.Query.Input (RefLabel (..))+import Web.DOM.Internal.Types++-- | Type synonym for a "tell-style" query - queries that only cause effects,+-- | but that cannot receive a return value.+-- |+-- | In a query algebra, a tell constructor carries the algebra's type variable+-- | as its last argument. For example:+-- |+-- | ``` purescript+-- | data Query a+-- |   = SomeTell a+-- |   | SomeOtherTell String a+-- |   | NotATell (Boolean -> a)+-- | ```+-- |+-- | Both `SomeTell` and `SomeOtherTell` carry a plain `a` as a value, whereas+-- | `NotATell` has `a` as the result of a function so is considered to be a+-- | "request" ([see below](#Request)).+type Tell f = () -> f ()++-- | Takes a data constructor of query algebra `f` and creates a tell query.+-- |+-- | For example:+-- |+-- | ```purescript+-- | data Query a = Tick a+-- |+-- | sendTick :: forall o. H.HalogenSocket Query o IO -> IO (Maybe ())+-- | sendTick app = app.query (H.mkTell Tick)+-- | ```+mkTell :: forall f. Tell f -> f ()+mkTell act = act ()++tell+  :: forall label+    ->forall state action output m slots query output' slot+   . (HasType label (Slot query output' slot) slots, Functor m)+  => (KnownSymbol label)+  => (Ord slot)+  => slot+  -> Tell query+  -> HalogenM state action slots output m ()+tell label slot req = void $ query label slot (req ())++tellAll+  :: forall label+    ->forall state action output m slots query output' slot+   . (HasType label (Slot query output' slot) slots, Functor m)+  => (KnownSymbol label)+  => (Ord slot)+  => Tell query+  -> HalogenM state action slots output m ()+tellAll label req = void $ queryAll label (req ())++-- | Type synonym for an "request-style" query - queries that can cause effects+-- | as well as fetching some information from a component.+-- |+-- | In a query algebra, a request constructor carries the algebra's type+-- | variable as the return value of a function as its last argument. For+-- | example:+-- |+-- | ``` purescript+-- | data Query a = SomeRequest (Boolean -> a)+-- | ```+type Request f a = (a -> a) -> f a++-- | Takes a data constructor of query algebra `f` and creates a request query.+-- |+-- | For example:+-- |+-- | ```purescript+-- | data Query a = GetTickCount (Int -> a)+-- |+-- | getTickCount :: forall o. H.HalogenSocket Query o IO -> IO (Maybe Int)+-- | getTickCount app = app.query (H.mkRequest GetTickCount)+-- | ```+mkRequest :: forall f a. Request f a -> f a+mkRequest req = req identity++request+  :: forall label+    ->forall state action output m slots query output' slot a+   . (HasType label (Slot query output' slot) slots, Functor m)+  => (KnownSymbol label)+  => (Ord slot)+  => slot+  -> Request query a+  -> HalogenM state action slots output m (Maybe a)+request slot label req = query slot label (req identity)++requestAll+  :: forall label+    ->forall state action output m slots query output' slot a+   . (HasType label (Slot query output' slot) slots, Functor m)+  => (KnownSymbol label)+  => (Ord slot)+  => Request query a+  -> HalogenM state action slots output m (Map slot a)+requestAll label req = queryAll label (req identity)++-- | Retrieves a `HTMLElement` value that is associated with a `Ref` in the+-- | rendered output of a component. If there is no currently rendered value (or+-- | it is not an `HTMLElement`) for the request will return `Nothing`.+getHTMLElementRef+  :: forall state action slots output m+   . (Functor m)+  => RefLabel+  -> HalogenM state action slots output m (Maybe HTMLElement)+getHTMLElementRef = map (fromElement =<<) . getRef
+ src/Halogen/Query/ChildQuery.hs view
@@ -0,0 +1,14 @@+module Halogen.Query.ChildQuery where++import Data.Row+import HPrelude+import Halogen.Data.Slot++data ChildQuery (ps :: Row Type) (a :: Type) where+  ChildQuery+    :: (forall slot m. (Applicative m) => (slot g o -> m (Maybe b)) -> SlotStorage ps slot -> m (f b))+    -> (g b)+    -> (f b -> a)+    -> ChildQuery ps a++deriving instance Functor (ChildQuery ps)
+ src/Halogen/Query/Event.hs view
@@ -0,0 +1,18 @@+module Halogen.Query.Event where++import HPrelude+import Halogen.Subscription+import Halogen.VDom.DOM.Monad+import Web.Event.Event++eventListener+  :: (MonadDOM m)+  => EventType+  -> EventTarget+  -> (Event -> Maybe a)+  -> Emitter m a+eventListener eventType target f =+  makeEmitter $ \push -> do+    listener <- mkEventListener $ \ev -> traverse_ push (f ev)+    addEventListener eventType listener target+    pure $ removeEventListener eventType listener target
+ src/Halogen/Query/HalogenM.hs view
@@ -0,0 +1,232 @@+module Halogen.Query.HalogenM where++import Control.Applicative.Free.Fast+import Control.Monad.Free.Church+import Control.Monad.Parallel+import Data.Map.Strict qualified as M+import Data.NT+import Data.Row+import HPrelude hiding (Ap)+import Halogen.Data.Slot as Slot+import Halogen.Query.ChildQuery qualified as CQ+import Halogen.Query.Input+import Halogen.Subscription hiding (Subscribe)+import Halogen.Subscription qualified as HS+import Web.DOM.Element++newtype SubscriptionId = SubscriptionId Int+  deriving newtype (Eq, Ord, Show)++newtype ForkId = ForkId Int+  deriving newtype (Eq, Ord, Show)++data HalogenF state action slots output m a+  = State (state -> (a, state))+  | Subscribe (SubscriptionId -> Emitter IO action) (SubscriptionId -> a)+  | Unsubscribe SubscriptionId a+  | Lift (m a)+  | Unlift (UnliftIO (HalogenM state action slots output m) -> IO a)+  | ChildQuery (CQ.ChildQuery slots a)+  | Raise output a+  | Par (HalogenAp state action slots output m a)+  | Fork (HalogenM state action slots output m ()) (ForkId -> a)+  | Join ForkId a+  | Kill ForkId a+  | GetRef RefLabel (Maybe Element -> a)+  deriving (Functor)++newtype HalogenM state action slots output m a+  = HalogenM (F (HalogenF state action slots output m) a)+  deriving (Functor, Applicative, Monad)++instance MonadTrans (HalogenM state' action slots' output) where+  lift = HalogenM . liftF . Lift++instance (MonadIO m) => MonadIO (HalogenM state' action slots' output m) where+  liftIO = HalogenM . liftF . Lift . liftIO++instance (MonadUnliftIO m) => MonadUnliftIO (HalogenM state' action slots' output m) where+  withRunInIO inner =+    HalogenM $ liftF $ Unlift $ \(UnliftIO q) -> inner q++type HalogenIO state action slots output a = HalogenM state action slots output IO a++newtype HalogenAp state action slots output m a+  = HalogenAp (Ap (HalogenM state action slots output m) a)+  deriving (Functor, Applicative)++instance (Functor m) => MonadState state' (HalogenM state' action slots' output m) where+  state = HalogenM . liftF . State++instance (Functor m) => MonadParallel (HalogenM state' action slots' output m) where+  type Parallel (HalogenM state' action slots' output m) = HalogenAp state' action slots' output m+  parallel = HalogenAp . liftAp+  sequential = HalogenM . liftF . Par++-- | Raises an output message for the component.+raise :: forall state action slots output m. (Functor m) => output -> HalogenM state action slots output m ()+raise o = HalogenM $ liftF $ Raise o ()++-- | Sends a query to a child of a component at the specified slot.+query+  :: forall label+    ->forall state action output m slots query output' slot a+   . (HasType label (Slot query output' slot) slots)+  => (KnownSymbol label)+  => (Ord slot)+  => (Functor m)+  => slot+  -> query a+  -> HalogenM state action slots output m (Maybe a)+query label p q =+  HalogenM+    $ liftF+    $ ChildQuery+    $ CQ.ChildQuery (\k -> maybe (pure Nothing) k . Slot.lookup label p) q identity++-- | Sends a query to all children of a component at a given slot label.+queryAll+  :: forall label+    ->forall state action output m slots query output' slot a+   . (HasType label (Slot query output' slot) slots)+  => (KnownSymbol label)+  => (Ord slot)+  => (Functor m)+  => query a+  -> HalogenM state action slots output m (Map slot a)+queryAll label q =+  HalogenM+    $ liftF+    $ ChildQuery+    $ CQ.ChildQuery (\k -> map catMapMaybes . traverse k . Slot.slots label) q identity+  where+    catMapMaybes :: forall k v. (Ord k) => Map k (Maybe v) -> Map k v+    catMapMaybes = M.foldlWithKey' (\acc k v -> maybe acc (flip (M.insert k) acc) v) M.empty++-- | Subscribes a component to an `Emitter`.+-- |+-- | When a component is disposed of any active subscriptions will automatically+-- | be stopped and no further subscriptions will be possible during+-- | finalization.+subscribe :: forall state action slots output m. (Functor m) => HS.Emitter IO action -> HalogenM state action slots output m SubscriptionId+subscribe es = HalogenM $ liftF $ Subscribe (const es) identity++-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe+-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it+-- | is passed into an `Emitter` constructor. This allows emitted queries+-- | to include the `SubscriptionId`, rather than storing it in the state of the+-- | component.+-- |+-- | When a component is disposed of any active subscriptions will automatically+-- | be stopped and no further subscriptions will be possible during+-- | finalization.+subscribe' :: forall state action slots output m. (Functor m) => (SubscriptionId -> HS.Emitter IO action) -> HalogenM state action slots output m ()+subscribe' esc = HalogenM $ liftF $ Subscribe esc (const ())++-- | Unsubscribes a component from a subscription. If the subscription associated+-- | with the ID has already ended this will have no effect.+unsubscribe :: forall state action slots output m. (Functor m) => SubscriptionId -> HalogenM state action slots output m ()+unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid ()++-- | Starts a `HalogenM` process running independent from the current `eval`+-- | "thread".+-- |+-- | A commonly use case for `fork` is in component initializers where some+-- | async action is started. Normally all interaction with the component will+-- | be blocked until the initializer completes, but if the async action is+-- | `fork`ed instead, the initializer can complete synchronously while the+-- | async action continues.+-- |+-- | Some care needs to be taken when using a `fork` that can modify the+-- | component state, as it's easy for the forked process to "clobber" the state+-- | (overwrite some or all of it with an old value) by mistake.+-- |+-- | When a component is disposed of any active forks will automatically+-- | be killed. New forks can be started during finalization but there will be+-- | no means of killing them.+fork :: forall state action slots output m. (Functor m) => HalogenM state action slots output m () -> HalogenM state action slots output m ForkId+fork hmu = HalogenM $ liftF $ Fork hmu identity++-- | Joins a forked process. Attempting to join a forked process that has+-- | already ended will result in eval continuing immediately. Attempting+-- | to join a forked process that has been killed will also terminate the+-- | current eval.+join :: forall state action slots output m. (Functor m) => ForkId -> HalogenM state action slots output m ()+join fid = HalogenM $ liftF $ Join fid ()++-- | Kills a forked process if it is still running. Attempting to kill a forked+-- | process that has already ended will have no effect.+kill :: forall state action slots output m. (Functor m) => ForkId -> HalogenM state action slots output m ()+kill fid = HalogenM $ liftF $ Kill fid ()++-- | Retrieves an `Element` value that is associated with a `Ref` in the+-- | rendered output of a component. If there is no currently rendered value for+-- | the requested ref this will return `Nothing`.+getRef :: forall state action slots output m. (Functor m) => RefLabel -> HalogenM state action slots output m (Maybe Element)+getRef p = HalogenM $ liftF $ GetRef p identity++imapState+  :: forall state state' action slots output m a+   . (state -> state')+  -> (state' -> state)+  -> HalogenM state action slots output m a+  -> HalogenM state' action slots output m a+imapState f f' = mapState (\s' -> (f' s', f))++mapState+  :: forall state state' action slots output m a+   . (state' -> (state, state -> state'))+  -> HalogenM state action slots output m a+  -> HalogenM state' action slots output m a+mapState lens = mapHalogen lens identity identity (NT identity)++mapAction+  :: forall state action action' slots output m a+   . (Functor m)+  => (action -> action')+  -> HalogenM state action slots output m a+  -> HalogenM state action' slots output m a+mapAction f = mapHalogen identityLens f identity (NT identity)++mapOutput+  :: forall state action slots output output' m a+   . (output -> output')+  -> HalogenM state action slots output m a+  -> HalogenM state action slots output' m a+mapOutput fo = mapHalogen identityLens identity fo (NT identity)++hoist+  :: forall state action slots output m m' a+   . (Functor m')+  => (m ~> m')+  -> HalogenM state action slots output m a+  -> HalogenM state action slots output m' a+hoist = mapHalogen identityLens identity identity++mapHalogen+  :: forall state state' action action' slots output output' m m' a+   . (state' -> (state, state -> state'))+  -> (action -> action')+  -> (output -> output')+  -> (m ~> m')+  -> HalogenM state action slots output m a+  -> HalogenM state' action' slots output' m' a+mapHalogen lens fa fo nat (HalogenM alg) = HalogenM (hoistF go alg)+  where+    go :: forall x. HalogenF state action slots output m x -> HalogenF state' action' slots output' m' x+    go = \case+      State f -> State (\s' -> let (s, g) = lens s' in map g (f s))+      Subscribe fes k -> Subscribe (map fa . fes) k+      Unsubscribe sid a -> Unsubscribe sid a+      Lift q -> Lift (runNT nat q)+      Unlift q -> Unlift $ q . mapUnliftIO (mapHalogen lens fa fo nat)+      ChildQuery cq -> ChildQuery cq+      Raise o a -> Raise (fo o) a+      Par (HalogenAp p) -> Par (HalogenAp $ hoistAp (mapHalogen lens fa fo nat) p)+      Fork hmu k -> Fork (mapHalogen lens fa fo nat hmu) k+      Join fid a -> Join fid a+      Kill fid a -> Kill fid a+      GetRef p k -> GetRef p k++identityLens :: forall s. s -> (s, s -> s)+identityLens s = (s, identity)
+ src/Halogen/Query/HalogenQ.hs view
@@ -0,0 +1,20 @@+module Halogen.Query.HalogenQ where++import Data.Functor.Coyoneda+import HPrelude++data HalogenQ query msg input a+  = Initialize a+  | Finalize a+  | Receive input a+  | Action msg a+  | Query (Coyoneda query a) (() -> a)+  deriving (Functor)++instance Bifunctor (HalogenQ query msg) where+  bimap f g = \case+    Initialize a -> Initialize (g a)+    Finalize a -> Finalize (g a)+    Receive i a -> Receive (f i) (g a)+    Action msg a -> Action msg (g a)+    Query y g' -> Query (fmap g y) (g . g')
+ src/Halogen/Query/Input.hs view
@@ -0,0 +1,11 @@+module Halogen.Query.Input where++import HPrelude+import Web.DOM.Element++newtype RefLabel = RefLabel Text++data Input msg+  = Action msg+  | RefUpdate RefLabel (Maybe Element)+  deriving (Functor)
+ src/Halogen/Subscription.hs view
@@ -0,0 +1,110 @@+module Halogen.Subscription where++import Control.Arrow ((&&&))+import Control.Monad.UUID+import Data.Coerce+import Data.Functor.Contravariant+import Data.NT+import HPrelude++-- | A paired `Listener` and `Emitter` produced with the `create` function.+data Subscribe m a = Subscribe+  { listener :: Listener m a+  , emitter :: Emitter m a+  }++create :: (MonadIO m, MonadUUID m) => m (Subscribe m a)+create = do+  subscribers <- newIORef []+  pure+    $ Subscribe+      { emitter = Emitter $ \handler -> do+          uuid <- generateV4+          atomicModifyIORef'_ subscribers (<> [(handler, uuid)])+          pure+            $ Subscription+              { unsubscribe = atomicModifyIORef'_ subscribers (HPrelude.filter (\(_, uuid') -> uuid /= uuid'))+              }+      , listener = Listener {notify = \a -> readIORef subscribers >>= traverse_ (\(k, _) -> k a)}+      }++newtype Emitter m a = Emitter {registerHandler :: (a -> m ()) -> m (Subscription m)}+  deriving (Functor)++hoistEmitter :: (MonadUnliftIO m) => Emitter IO a -> Emitter m a+hoistEmitter (Emitter g) = Emitter $ \k -> withRunInIO $ \runInIO ->+  fmap (hoistSubscription $ NT liftIO) $ g $ runInIO . k++instance (MonadIO m) => Applicative (Emitter m) where+  pure a = Emitter $ \k -> do+    k a+    pure (Subscription (pure ()))++  (Emitter e1) <*> (Emitter e2) = Emitter $ \k -> do+    latestA <- newIORef Nothing+    latestB <- newIORef Nothing+    Subscription c1 <- e1 $ \a -> do+      atomicWriteIORef latestA (Just a)+      readIORef latestB >>= traverse_ (k . a)+    Subscription c2 <- e2 $ \b -> do+      atomicWriteIORef latestB (Just b)+      readIORef latestA >>= traverse_ (k . ($ b))+    pure (Subscription (c1 *> c2))++instance (MonadIO m) => Alternative (Emitter m) where+  empty = Emitter $ \_ -> pure (Subscription (pure ()))+  (Emitter f) <|> (Emitter g) = Emitter $ \k -> do+    Subscription c1 <- f k+    Subscription c2 <- g k+    pure (Subscription (c1 *> c2))++makeEmitter+  :: (Functor m)+  => ((a -> m ()) -> m (m ()))+  -> Emitter m a+makeEmitter f = Emitter (fmap Subscription . f)++----------------------------------------------------------------------++newtype Listener m a = Listener {notify :: a -> m ()}++notify :: Listener m a -> a -> m ()+notify (Listener f) = f++instance Contravariant (Listener m) where+  contramap f (Listener g) = coerce (g . f)++newtype Subscription m = Subscription {unsubscribe :: m ()}++hoistSubscription :: (m ~> n) -> Subscription m -> Subscription n+hoistSubscription (NT f) (Subscription unsub) = Subscription (f unsub)++subscribe+  :: (Functor m)+  => Emitter m a+  -> (a -> m r)+  -> m (Subscription m)+subscribe em k = em.registerHandler (void . k)++unsubscribe :: Subscription m -> m ()+unsubscribe (Subscription unsub) = unsub++fold :: (MonadIO m) => (a -> b -> b) -> Emitter m a -> b -> Emitter m b+fold f (Emitter e) b = Emitter $ \k -> do+  result <- newIORef b+  e $ \a -> atomicModifyIORef' result (f a &&& f a) >>= k++filter :: (Applicative m) => (a -> Bool) -> Emitter m a -> Emitter m a+filter p (Emitter e) = Emitter $ \k -> e $ \a -> when (p a) (k a)++{-+-- | Compute a fixed point.+fix :: forall i o. (Emitter i -> (Emitter i, Emitter o)) -> Emitter o+fix f = Emitter $ \k -> do+  Subscription c1 <- subscribe input (notify listener)+  Subscription c2 <- subscribe output k+  pure (Subscription (c1 *> c2))+  where+  SubscribeIO { emitter, listener } = unsafePerformIO create+  (input, output) = f emitter+  -}
+ src/Halogen/Svg/Attributes.hs view
@@ -0,0 +1,449 @@+module Halogen.Svg.Attributes (module Halogen.Svg.Attributes) where++import Clay hiding (Baseline, attr, map, max)+import Data.Coerce+import Data.Row+import Data.Text qualified as T+import GHC.Show qualified+import Halogen.HTML.Core qualified as H+import Halogen.HTML.Properties (IProp, attr, attrNS)+import Protolude++--------------------------------------------------------------------------------++data Align+  = Min+  | Mid+  | Max+  deriving (Eq, Show)++--------------------------------------------------------------------------------++data Baseline+  = Auto+  | UseScript+  | NoChange+  | ResetSize+  | Ideographic+  | Alphabetic+  | Hanging+  | Mathematical+  | Central+  | BaselineMiddle+  | TextAfterEdge+  | TextBeforeEdge+  deriving (Eq, Show)++printBaseline :: Baseline -> Text+printBaseline = \case+  Auto -> "auto"+  UseScript -> "use-script"+  NoChange -> "no-change"+  ResetSize -> "reset-size"+  Ideographic -> "ideographic"+  Alphabetic -> "alphabetic"+  Hanging -> "hanging"+  Mathematical -> "mathematical"+  Central -> "central"+  BaselineMiddle -> "middle"+  TextAfterEdge -> "text-after-edge"+  TextBeforeEdge -> "text-before-edge"++--------------------------------------------------------------------------------++newtype PathCommand = PathCommand Text+  deriving newtype (Eq)++instance Show PathCommand where+  show (PathCommand txt) = toS txt++--------------------------------------------------------------------------------++data Duration = Duration+  { hours :: Maybe Double+  , minutes :: Maybe Double+  , seconds :: Maybe Double+  , milliseconds :: Maybe Double+  }++defaultDuration :: Duration+defaultDuration =+  Duration+    { hours = Nothing+    , minutes = Nothing+    , seconds = Nothing+    , milliseconds = Nothing+    }++--------------------------------------------------------------------------------++data FillState+  = Freeze+  | Remove+  deriving (Eq, Show)++printFillState :: FillState -> Text+printFillState = \case+  Freeze -> "freeze"+  Remove -> "remove"++--------------------------------------------------------------------------------++data FontStretch+  = StretchNormal+  | StretchUltraCondensed+  | StretchExtraCondensed+  | StretchCondensed+  | StretchSemiCondensed+  | StretchSemiExpanded+  | StretchExpanded+  | StretchExtraExpanded+  | StretchUltraExpanded+  | StretchPercent Number+  deriving (Eq, Show)++printFontStretch :: FontStretch -> Text+printFontStretch = \case+  StretchNormal -> "normal"+  StretchUltraCondensed -> "ultra-condensed"+  StretchExtraCondensed -> "extra-condensed"+  StretchCondensed -> "condensed"+  StretchSemiCondensed -> "semi-condensed"+  StretchSemiExpanded -> "semi-expanded"+  StretchExpanded -> "expanded"+  StretchExtraExpanded -> "extra-expanded"+  StretchUltraExpanded -> "ultra-expanded"+  StretchPercent n -> show n <> "%"++--------------------------------------------------------------------------------++data MarkerUnit+  = UserSpaceOnUse+  | StrokeWidth+  deriving (Eq, Show)++printMarkerUnit :: MarkerUnit -> Text+printMarkerUnit = \case+  UserSpaceOnUse -> "userSpaceOnUse"+  StrokeWidth -> "strokeWidth"++--------------------------------------------------------------------------------++data MaskUnit+  = UserSpaceOnUse_+  | ObjectBoundingBox+  deriving (Eq, Show)++-- This instance of Show is currently identical to printMaskUnit. That is+-- likely to change so don't rely on it++printMaskUnit :: MaskUnit -> Text+printMaskUnit = \case+  UserSpaceOnUse_ -> "userSpaceOnUse"+  ObjectBoundingBox -> "objectBoundingBox"++--------------------------------------------------------------------------------++data Orient+  = AutoOrient+  | AutoStartReverse+  deriving (Eq, Ord)++printOrient :: Orient -> Text+printOrient = \case+  AutoOrient -> "auto"+  AutoStartReverse -> "auto-start-reverse"++--------------------------------------------------------------------------------++data TextAnchor+  = AnchorStart+  | AnchorMiddle+  | AnchorEnd+  deriving (Eq, Show)++printTextAnchor :: TextAnchor -> Text+printTextAnchor = \case+  AnchorStart -> "start"+  AnchorMiddle -> "middle"+  AnchorEnd -> "end"++--------------------------------------------------------------------------------++data MeetOrSlice+  = Meet+  | Slice+  deriving (Eq, Show)++printMeetOrSlice :: MeetOrSlice -> Text+printMeetOrSlice = \case+  Meet -> "meet"+  Slice -> "slice"++--------------------------------------------------------------------------------++data StrokeLineCap+  = LineCapButt+  | LineCapSquare+  | LineCapRound+  deriving (Eq, Show)++printStrokeLineCap :: StrokeLineCap -> Text+printStrokeLineCap = \case+  LineCapButt -> "butt"+  LineCapSquare -> "square"+  LineCapRound -> "round"++--------------------------------------------------------------------------------++data StrokeLineJoin+  = LineJoinArcs+  | LineJoinBevel+  | LineJoinMiter+  | LineJoinMiterClip+  | LineJoinRound+  deriving (Eq, Show)++printStrokeLineJoin :: StrokeLineJoin -> Text+printStrokeLineJoin = \case+  LineJoinArcs -> "arcs"+  LineJoinBevel -> "bevel"+  LineJoinMiter -> "miter"+  LineJoinMiterClip -> "miter-clip"+  LineJoinRound -> "round"++--------------------------------------------------------------------------------++renderValue :: forall a. (Val a) => a -> Text+renderValue = plain . coerce . value++attributeName :: forall r i. (HasType "attributeName" Text r) => Text -> IProp r i+attributeName = attr (H.AttrName "attributeName")++-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/begin+begin :: forall r i. (HasType "begin" Text r) => Text -> IProp r i+begin = attr (H.AttrName "begin")++class_ :: forall r i. (HasType "class" Text r) => H.ClassName -> IProp r i+class_ = attr (H.AttrName "class") . coerce++classes :: forall r i. (HasType "class" Text r) => [H.ClassName] -> IProp r i+classes = attr (H.AttrName "class") . T.unwords . coerce++cx :: forall r i. (HasType "cx" Double r) => Double -> IProp r i+cx = attr (H.AttrName "cx") . show++cy :: forall r i. (HasType "cy" Double r) => Double -> IProp r i+cy = attr (H.AttrName "cy") . show++d :: forall r i. (HasType "d" Text r) => [PathCommand] -> IProp r i+d = attr (H.AttrName "d") . T.unwords . coerce++dominantBaseline :: forall r i. (HasType "dominantBaseline" Text r) => Baseline -> IProp r i+dominantBaseline = attr (H.AttrName "dominant-baseline") . printBaseline++dur :: forall r i. (HasType "dur" Text r) => Duration -> IProp r i+dur = attr (H.AttrName "dur") . printDuration+  where+    printDuration :: Duration -> Text+    printDuration (Duration {hours, minutes, seconds, milliseconds}) =+      f "h" hours <> f "m" minutes <> f "s" seconds <> f "i" milliseconds++    f unit_ = maybe "" (\val -> show val <> unit_)++fill :: forall r i. (HasType "fill" Text r) => Color -> IProp r i+fill = attr (H.AttrName "fill") . renderValue++-- Note: same as 'fill' but that function is already specialised to Color+fillAnim :: forall r i. (HasType "fill" Text r) => FillState -> IProp r i+fillAnim = attr (H.AttrName "fill") . printFillState++fillOpacity :: forall r i. (HasType "fillOpacity" Double r) => Double -> IProp r i+fillOpacity = attr (H.AttrName "fill-opacity") . show++fontFamily :: forall r i. (HasType "fontFamily" Text r) => Text -> IProp r i+fontFamily = attr (H.AttrName "font-family")++fontSize :: forall r i. (HasType "fontSize" Text r) => FontSize -> IProp r i+fontSize = attr (H.AttrName "font-size") . renderValue++fontSizeAdjust :: forall r i. (HasType "fontSizeAdjust" Text r) => Double -> IProp r i+fontSizeAdjust = attr (H.AttrName "font-size-adjust") . show++fontStretch :: forall r i. (HasType "fontStretch" Text r) => FontStretch -> IProp r i+fontStretch = attr (H.AttrName "font-stretch") . printFontStretch++fontStyle :: forall r i. (HasType "fontStyle" Text r) => FontStyle -> IProp r i+fontStyle = attr (H.AttrName "font-style") . renderValue++fontVariant :: forall r i. (HasType "fontVariant" Text r) => Text -> IProp r i+fontVariant = attr (H.AttrName "font-variant")++fontWeight :: forall r i. (HasType "fontWeight" Text r) => FontWeight -> IProp r i+fontWeight = attr (H.AttrName "font-weight") . renderValue++-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/from+from :: forall r i. (HasType "from" Text r) => Text -> IProp r i+from = attr (H.AttrName "from")++-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/to+to :: forall r i. (HasType "to" Text r) => Text -> IProp r i+to = attr (H.AttrName "to")++id :: forall r i. (HasType "id" Text r) => Text -> IProp r i+id = attr (H.AttrName "id")++markerStart :: forall r i. (HasType "markerStart" Text r) => Text -> IProp r i+markerStart = attr (H.AttrName "marker-start")++markerMid :: forall r i. (HasType "markerMid" Text r) => Text -> IProp r i+markerMid = attr (H.AttrName "marker-mid")++markerEnd :: forall r i. (HasType "markerEnd" Text r) => Text -> IProp r i+markerEnd = attr (H.AttrName "marker-end")++markerUnits :: forall r i. (HasType "markerUnits" Text r) => MarkerUnit -> IProp r i+markerUnits = attr (H.AttrName "markerUnits") . printMarkerUnit++markerWidth :: forall r i. (HasType "markerWidth" Double r) => Double -> IProp r i+markerWidth = attr (H.AttrName "markerWidth") . show++markerHeight :: forall r i. (HasType "markerHeight" Double r) => Double -> IProp r i+markerHeight = attr (H.AttrName "markerHeight") . show++mask :: forall r i. (HasType "mask" Text r) => Text -> IProp r i+mask = attr (H.AttrName "mask")++maskUnits :: forall r i. (HasType "maskUnits" Text r) => MaskUnit -> IProp r i+maskUnits = attr (H.AttrName "maskUnits") . printMaskUnit++maskContentUnits :: forall r i. (HasType "maskContentUnits" Text r) => MaskUnit -> IProp r i+maskContentUnits = attr (H.AttrName "maskContentUnits") . printMaskUnit++orient :: forall r i. (HasType "orient" Text r) => Orient -> IProp r i+orient = attr (H.AttrName "orient") . printOrient++path :: forall r i. (HasType "path" Text r) => [PathCommand] -> IProp r i+path = attr (H.AttrName "path") . T.intercalate " " . coerce++-- | An array of x-y value pairs (e.g. `[(x, y)]`).+points :: forall r i. (HasType "points" Text r) => [(Double, Double)] -> IProp r i+points = attr (H.AttrName "points") . T.intercalate " " . map (\(x_, y_) -> show x_ <> "," <> show y_)++pathLength :: forall r i. (HasType "pathLength" Text r) => Double -> IProp r i+pathLength = attr (H.AttrName "pathLength") . show++patternContentUnits :: forall r i. (HasType "patternContentUnits" Text r) => Text -> IProp r i+patternContentUnits = attr (H.AttrName "patternContentUnits")++patternTransformation :: forall r i. (HasType "patternTransformation" Text r) => [Transformation] -> IProp r i+patternTransformation = attr (H.AttrName "patternTransformation") . T.unwords . map renderValue++patternUnits :: forall r i. (HasType "patternUnits" Text r) => Text -> IProp r i+patternUnits = attr (H.AttrName "patternUnits")++preserveAspectRatio+  :: forall r i+   . (HasType "preserveAspectRatio" Text r)+  => Maybe (Align, Align)+  -> MeetOrSlice+  -> IProp r i+preserveAspectRatio align slice =+  attr+    (H.AttrName "preserveAspectRatio")+    (T.intercalate " " $ [align_str, printMeetOrSlice slice])+  where+    align_str = case align of+      Nothing -> "none"+      Just (x_, y_) -> T.intercalate "" $ ["x", show x_, "Y", show y_]++r :: forall r i. (HasType "r" Text r) => Double -> IProp r i+r = attr (H.AttrName "r") . show++refX :: forall r i. (HasType "refX" Text r) => Double -> IProp r i+refX = attr (H.AttrName "refX") . show++refY :: forall r i. (HasType "refY" Text r) => Double -> IProp r i+refY = attr (H.AttrName "refY") . show++repeatCount :: forall r i. (HasType "repeatCount" Text r) => Text -> IProp r i+repeatCount = attr (H.AttrName "repeatCount")++rx :: forall r i. (HasType "rx" Text r) => Double -> IProp r i+rx = attr (H.AttrName "rx") . show++ry :: forall r i. (HasType "ry" Text r) => Double -> IProp r i+ry = attr (H.AttrName "ry") . show++stroke :: forall r i. (HasType "stroke" Text r) => Color -> IProp r i+stroke = attr (H.AttrName "stroke") . renderValue++strokeDashArray :: forall r i. (HasType "strokeDashArray" Text r) => Text -> IProp r i+strokeDashArray = attr (H.AttrName "stroke-dasharray")++strokeDashOffset :: forall r i. (HasType "strokeDashOffset" Text r) => Double -> IProp r i+strokeDashOffset = attr (H.AttrName "stroke-dashoffset") . show++strokeLineCap :: forall r i. (HasType "strokeLineCap" Text r) => StrokeLineCap -> IProp r i+strokeLineCap = attr (H.AttrName "stroke-linecap") . printStrokeLineCap++strokeLineJoin :: forall r i. (HasType "strokeLineJoin" Text r) => StrokeLineJoin -> IProp r i+strokeLineJoin = attr (H.AttrName "stroke-linejoin") . printStrokeLineJoin++-- | The `Double` arg must be greater than or equal to 1. Thus, this function+-- | will use `1.0` if given any value less than `1.0`.+strokeMiterLimit :: forall r i. (HasType "strokeMiterLimit" Text r) => Double -> IProp r i+strokeMiterLimit = attr (H.AttrName "stroke-miterlimit") . show . max 1.0++strokeOpacity :: forall r i. (HasType "strokeOpacity" Text r) => Double -> IProp r i+strokeOpacity = attr (H.AttrName "stroke-opacity") . show++strokeWidth :: forall r i. (HasType "strokeWidth" Text r) => Double -> IProp r i+strokeWidth = attr (H.AttrName "stroke-width") . show++textAnchor :: forall r i. (HasType "textAnchor" Text r) => TextAnchor -> IProp r i+textAnchor = attr (H.AttrName "text-anchor") . printTextAnchor++transformation :: forall r i. (HasType "Transformation" Text r) => [Transformation] -> IProp r i+transformation = attr (H.AttrName "Transformation") . T.unwords . map renderValue++viewBox+  :: forall r i+   . (HasType "viewBox" Text r)+  => Double+  -> Double+  -> Double+  -> Double+  -> IProp r i+viewBox x_ y_ w h_ =+  attr (H.AttrName "viewBox") (T.unwords $ map show [x_, y_, w, h_])++width :: forall r i. (HasType "width" Text r) => Double -> IProp r i+width = attr (H.AttrName "width") . show++height :: forall r i. (HasType "height" Text r) => Double -> IProp r i+height = attr (H.AttrName "height") . show++x :: forall r i. (HasType "x" Text r) => Double -> IProp r i+x = attr (H.AttrName "x") . show++y :: forall r i. (HasType "y" Text r) => Double -> IProp r i+y = attr (H.AttrName "y") . show++x1 :: forall r i. (HasType "x1" Text r) => Double -> IProp r i+x1 = attr (H.AttrName "x1") . show++y1 :: forall r i. (HasType "y1" Text r) => Double -> IProp r i+y1 = attr (H.AttrName "y1") . show++x2 :: forall r i. (HasType "x2" Text r) => Double -> IProp r i+x2 = attr (H.AttrName "x2") . show++y2 :: forall r i. (HasType "y2" Text r) => Double -> IProp r i+y2 = attr (H.AttrName "y2") . show++href :: forall r i. (HasType "href" Text r) => Text -> IProp r i+href = attr (H.AttrName "href")++xlinkHref :: forall r i. (HasType "xlinkHref" Text r) => Text -> IProp r i+xlinkHref = attrNS (H.Namespace "xlink") (H.AttrName "xlink:href")
+ src/Halogen/Svg/Elements.hs view
@@ -0,0 +1,118 @@+-- | Similar to `Halogen.HTML as HH` but contains SVG elements.+-- | We recommend importing this module via the `SE` module alias:+-- | ```+-- | import Halogen.Svg.Elements as SE+-- | ```+module Halogen.Svg.Elements+  ( element+  , svg+  , g+  , circle+  , image+  , ellipse+  , rect+  , path+  , pattern_+  , line+  , polyline+  , polygon+  , text+  , foreignObject+  , defs+  , mask+  , marker+  , animate+  , animateMotion+  , circleNode+  , mpath+  , title+  , use+  )+where++-- Like Halogen.HTML.Elements++import Halogen.HTML.Core (ElemName (..), HTML, Namespace (..))+import Halogen.HTML.Elements (Leaf, Node, elementNS)+import Halogen.HTML.Properties (IProp)+import Halogen.Svg.Indexed qualified as I+import Protolude hiding (mask)++-- | This `element` rather than `Halogen.HTML.Elements.element` must be used+-- | because all SVG elements created via JavaScript must have the svg namespace:+-- | `"http://www.w3.org/2000/svg"`+element :: forall r w i. ElemName -> [IProp r i] -> [HTML w i] -> HTML w i+element = elementNS (Namespace "http://www.w3.org/2000/svg")++svg :: forall p i. Node I.SVGsvg p i+svg = element $ ElemName "svg"++g :: forall p i. Node I.SVGg p i+g = element $ ElemName "g"++circle :: forall p i. Leaf I.SVGcircle p i+circle props = element (ElemName "circle") props []++image :: forall p i. Leaf I.SVGimage p i+image props = element (ElemName "image") props []++ellipse :: forall p i. Leaf I.SVGellipse p i+ellipse props = element (ElemName "ellipse") props []++rect :: forall p i. Leaf I.SVGrect p i+rect props = element (ElemName "rect") props []++path :: forall p i. Leaf I.SVGpath p i+path props = element (ElemName "path") props []++pattern_ :: forall p i. Node I.SVGpattern p i+pattern_ = element (ElemName "pattern")++line :: forall p i. Leaf I.SVGline p i+line props = element (ElemName "line") props []++polyline :: forall p i. Leaf I.SVGpolyline p i+polyline props = element (ElemName "polyline") props []++polygon :: forall p i. Leaf I.SVGpolygon p i+polygon props = element (ElemName "polygon") props []++text :: forall p i. Node I.SVGtext p i+text = element (ElemName "text")++use :: forall p i. Leaf I.SVGuse p i+use props = element (ElemName "use") props []++foreignObject :: forall p i. Node I.SVGforeignObject p i+foreignObject = element (ElemName "foreignObject")++defs :: forall p i. Node I.SVGg p i+defs = element $ ElemName "defs"++mask :: forall p i. Node I.SVGg p i+mask = element $ ElemName "mask"++marker :: forall p i. Node I.SVGmarker p i+marker = element $ ElemName "marker"++--------------------------------------------------------------------------------++animate :: forall p i. Leaf I.SVGanimate p i+animate props = element (ElemName "animate") props []++-- TODO there's also animateTransform, etc+animateMotion :: forall p i. Node I.SVGanimateMotion p i+animateMotion = element (ElemName "animateMotion")++circleNode :: forall p i. Node I.SVGcircle p i+circleNode = element (ElemName "circle")++-- TODO Node or Leaf? mpath :: forall p i. Node I.SVGmpath p i+-- https://developer.mozilla.org/en-US/docs/Web/SVG/Element/mpath+mpath :: forall p i. Leaf I.SVGmpath p i+mpath props = element (ElemName "mpath") props []++--------------------------------------------------------------------------------++title :: forall p i. Node I.SVGtitle p i+title = element (ElemName "title")
+ src/Halogen/Svg/Indexed.hs view
@@ -0,0 +1,422 @@+-- | Note: an element may contain more attributes than what+-- | we currently allow in its corresponding `SVGelemName`.+module Halogen.Svg.Indexed+  ( CoreAttributes+  , GlobalEventAttributes+  , GlobalAttributes+  , StrokeAttributes+  , StokeEndAttributes+  , StrokeJoinAttributes+  , FillAttributes+  , MarkerAttributes+  , FontAttributes+  , CanBeMaskedAttributes+  , AllPresentationAttributes+  , SVGsvg+  , SVGg+  , SVGforeignObject+  , SVGmarker+  , SVGcircle+  , SVGellipse+  , SVGline+  , SVGpolyline+  , SVGpolygon+  , SVGpath+  , SVGpattern+  , SVGrect+  , SVGtext+  , SVGmask+  , AnimationAttributes+  , SVGanimate+  , SVGanimateMotion+  , SVGimage+  , SVGmpath+  , SVGtitle+  , SVGuse+  )+where++import Data.Row+import Protolude+import Web.UIEvent.KeyboardEvent (KeyboardEvent)+import Web.UIEvent.MouseEvent (MouseEvent)+import Web.UIEvent.WheelEvent (WheelEvent)++{-+The table below show which groups of attributes apply to which elements. This+table is compiled by looking up each attribute on MDN+(e.g..+ https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke)+and looking at the list labeled "You can use this attribute with the following+SVG elements:". Groups are formed from attributes that have the same element+applicability.++element            stroke | strokeEnd | strokeJoin | fill  | font  | marker+circle                X   |     -     |     -      |   X   |   -   |    X+ellipse               X   |     -     |     -      |   X   |   -   |    X+line                  X   |     X     |     -      |   -   |   -   |    X+path                  X   |     X     |     X      |   X   |   -   |    X+rect                  X   |     -     |     X      |   X   |   -   |    X+text                  X   |     X     |     X      |   X   |   X   |    -+svg                   C   |     C     |     C      |   C   |   C   |    C+g                     C   |     C     |     C      |   C   |   C   |    C+marker                C   |     C     |     C      |   C   |   C   |    C+foreignObject         C   |     C     |     C      |   C   |   C   |    C+use                   -   |     -     |     -      |   -   |   -   |    -++X indicates that the collection of attributes applies to that element+- indicates that the collection of attributes does not apply to that element+C indicates that the collection of attributes does not apply to that element+  but may apply to a child element and hence can still be set+-}++-- These core attributes are applicable to every element+type CoreAttributes r = ("id" .== Text .+ "class" .== Text .+ "style" .== Text .+ "tabIndex" .== Int .+ "lang" .== Text .+ r)++-- Subset of events that work on Firefox 60/Chromium 66+type GlobalEventAttributes r =+  ( "onClick" .== MouseEvent+      .+ "onDoubleClick" .== MouseEvent+      .+ "onContextMenu" .== MouseEvent+      .+ "onKeyDown" .== KeyboardEvent+      .+ "onKeyPress" .== KeyboardEvent+      .+ "onKeyUp" .== KeyboardEvent+      .+ "onMouseDown" .== MouseEvent+      .+ "onMouseEnter" .== MouseEvent+      .+ "onMouseLeave" .== MouseEvent+      .+ "onMouseMove" .== MouseEvent+      .+ "onMouseOut" .== MouseEvent+      .+ "onMouseOver" .== MouseEvent+      .+ "onMouseUp" .== MouseEvent+      .+ "onWheel" .== WheelEvent+      .+ r+  )++type GlobalAttributes r = CoreAttributes (GlobalEventAttributes r)++-- Presentation attributes.+ grouped by applicability (see table above) ---------+type StrokeAttributes r =+  ( "stroke" .== Text+      .+ "strokeDashArray" .== Text+      .+ "strokeDashOffset" .== Double+      .+ "strokeOpacity" .== Double+      .+ "strokeWidth" .== Double+      .+ r+  )++type StokeEndAttributes r =+  ( "strokeLineCap" .== Text+      .+ r+  )++type StrokeJoinAttributes r =+  ( "strokeLineJoin" .== Text+      .+ "strokeMiterLimit" .== Text+      .+ r+  )++type FillAttributes r =+  ( "fill" .== Text+      .+ "fillOpacity" .== Double+      .+ r+  )++type MarkerAttributes r =+  ( "markerStart" .== Text+      .+ "markerMid" .== Text+      .+ "markerEnd" .== Text+      .+ r+  )++type FontAttributes r =+  ( "fontFamily" .== Text+      .+ "fontSize" .== Text+      .+ "fontSizeAdjust" .== Double+      .+ "fontStretch" .== Text+      .+ "fontStyle" .== Text+      .+ "fontVariant" .== Text+      .+ "fontWeight" .== Text+      .+ r+  )++type CanBeMaskedAttributes r =+  ( "mask" .== Text+      .+ r+  )++type AllPresentationAttributes r =+  StrokeAttributes+    ( StrokeJoinAttributes+        ( StokeEndAttributes+            ( FillAttributes+                ( FontAttributes+                    ( MarkerAttributes+                        (CanBeMaskedAttributes r)+                    )+                )+            )+        )+    )++-- Specific SVG elements -------------------------------------------------------+type SVGsvg =+  GlobalAttributes+    ( AllPresentationAttributes+        ( "width" .== Double+            .+ "height" .== Double+            .+ "viewBox" .== Text+            .+ "preserveAspectRatio" .== Text+        )+    )++type SVGg =+  GlobalAttributes+    ( AllPresentationAttributes+        ("transform" .== Text)+    )++type SVGforeignObject =+  GlobalAttributes+    ( AllPresentationAttributes+        ( "x" .== Double+            .+ "y" .== Double+            .+ "height" .== Double+            .+ "width" .== Double+        )+    )++type SVGmarker =+  GlobalAttributes+    ( AllPresentationAttributes+        ( "markerWidth" .== Double+            .+ "markerHeight" .== Double+            .+ "strokeWidth" .== Double+            .+ "refX" .== Double+            .+ "refY" .== Double+            .+ "orient" .== Text+            .+ "markerUnits" .== Text+        )+    )++type SVGmask =+  GlobalAttributes+    ( AllPresentationAttributes+        ( "transform" .== Text+            .+ "x" .== Double+            .+ "y" .== Double+            .+ "width" .== Double+            .+ "height" .== Double+            .+ "maskUnits" .== Text+            .+ "maskContentsUnits" .== Text+        )+    )++type SVGcircle =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( FillAttributes+                ( MarkerAttributes+                    ( "cx" .== Double+                        .+ "cy" .== Double+                        .+ "r" .== Double+                        .+ "transform" .== Text+                    )+                )+            )+        )+    )++type SVGellipse =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( FillAttributes+                ( MarkerAttributes+                    ( "cx" .== Double+                        .+ "cy" .== Double+                        .+ "rx" .== Double+                        .+ "ry" .== Double+                        .+ "transform" .== Text+                    )+                )+            )+        )+    )++type SVGline =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( MarkerAttributes+                    ( "x1" .== Double+                        .+ "y1" .== Double+                        .+ "x2" .== Double+                        .+ "y2" .== Double+                        .+ "transform" .== Text+                    )+                )+            )+        )+    )++type SVGpolyline =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( MarkerAttributes+                    ( "points" .== Text+                        .+ "pathLength" .== Double+                    )+                )+            )+        )+    )++type SVGpolygon =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( MarkerAttributes+                    ( "points" .== Text+                        .+ "pathLength" .== Double+                    )+                )+            )+        )+    )++type SVGpath =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( StrokeJoinAttributes+                    ( FillAttributes+                        ( MarkerAttributes+                            ( "d" .== Text+                                .+ "transform" .== Text+                            )+                        )+                    )+                )+            )+        )+    )++type SVGpattern =+  GlobalAttributes+    ( "height" .== Double+        .+ "href" .== Text+        .+ "patternContentUnits" .== Text+        .+ "patternTransform" .== Text+        .+ "patternUnits" .== Text+        .+ "preserveAspectRatio" .== Text+        .+ "viewBox" .== Text+        .+ "width" .== Double+        .+ "x" .== Double+        .+ "xlinkHref" .== Text+        .+ "y" .== Double+    )++type SVGrect =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StrokeJoinAttributes+                ( FillAttributes+                    ( MarkerAttributes+                        ( "x" .== Double+                            .+ "y" .== Double+                            .+ "rx" .== Double+                            .+ "ry" .== Double+                            .+ "width" .== Double+                            .+ "height" .== Double+                            .+ "transform" .== Text+                        )+                    )+                )+            )+        )+    )++type SVGtext =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( StrokeJoinAttributes+                    ( FillAttributes+                        ( FontAttributes+                            ( "x" .== Double+                                .+ "y" .== Double+                                .+ "textAnchor" .== Text+                                .+ "dominantBaseline" .== Text+                                .+ "transform" .== Text+                            )+                        )+                    )+                )+            )+        )+    )++type SVGuse =+  GlobalAttributes+    ( CanBeMaskedAttributes+        ( StrokeAttributes+            ( StokeEndAttributes+                ( StrokeJoinAttributes+                    ( FillAttributes+                        ( FontAttributes+                            ( "x" .== Double+                                .+ "y" .== Double+                                .+ "width" .== Double+                                .+ "height" .== Double+                                .+ "transform" .== Text+                                .+ "href" .== Text+                            )+                        )+                    )+                )+            )+        )+    )++--------------------------------------------------------------------------------++type AnimationAttributes r =+  GlobalAttributes+    ( "from" .== Text+        .+ "to" .== Text+        .+ "begin" .== Text+        .+ "dur" .== Text+        .+ "repeatCount" .== Text+        .+ "fill" .== Text+        .+ r+    )+-- ^ Unlike `fill` in `GlobalAttributes`, `fill` in `AnimationAttributes` is+-- intended to record a `FillState` via `fillAnim`.++type SVGanimate = AnimationAttributes ("attributeName" .== Text)++type SVGanimateMotion = AnimationAttributes ("path" .== Text)++type SVGimage =+  GlobalAttributes+    ( "x" .== Double+        .+ "y" .== Double+        .+ "width" .== Double+        .+ "height" .== Double+        .+ "href" .== Text+        .+ "preserveAspectRatio" .== Text+    )++-- TODO should this have GlobalAttributes?+type SVGmpath = ("xlinkHref" .== Text)++--------------------------------------------------------------------------------++type SVGtitle = GlobalAttributes Empty
+ src/Halogen/VDom.hs view
@@ -0,0 +1,5 @@+module Halogen.VDom (module X) where++import Halogen.VDom.DOM as X (VDomSpec (..), buildVDom)+import Halogen.VDom.Machine as X (Machine, Step (..), extract, halt, step)+import Halogen.VDom.Types as X (ElemName (..), Graft, Namespace (..), VDom (..), runGraft)
+ src/Halogen/VDom/DOM.hs view
@@ -0,0 +1,272 @@+module Halogen.VDom.DOM+  ( VDomSpec (..)+  , buildVDom+  , buildText+  , buildElem+  , buildWidget+  , buildKeyed+  )+where++import HPrelude hiding (state)+import Halogen.VDom.DOM.Monad+import Halogen.VDom.Machine+import Halogen.VDom.Types+import Halogen.VDom.Utils+import Web.DOM.Element+import Web.DOM.Internal.Types+import Web.DOM.ParentNode++#if defined(javascript_HOST_ARCH)+{-# SPECIALISE buildVDom :: VDomSpec IO a w -> VDomMachine IO a w #-}+{-# SPECIALISE buildText :: VDomSpec IO a w -> VDomMachine IO a w -> Text -> IO (VDomStep IO a w) #-}+{-# SPECIALISE patchText :: TextState IO a w -> VDom a w -> IO (VDomStep IO a w) #-}+{-# SPECIALISE haltText :: TextState IO a w -> IO () #-}+{-# SPECIALISE buildKeyed :: VDomSpec IO a w -> VDomMachine IO a w -> Maybe Namespace -> ElemName -> a -> [(Text, VDom a w)] -> IO (VDomStep IO a w) #-}+{-# SPECIALISE patchKeyed :: KeyedState IO a w -> VDom a w -> IO (VDomStep IO a w) #-}+{-# SPECIALISE haltKeyed :: KeyedState IO a w -> IO () #-}+{-# SPECIALISE buildElem :: VDomSpec IO a w -> VDomMachine IO a w -> Maybe Namespace -> ElemName -> a -> [VDom a w] -> IO (VDomStep IO a w) #-}+{-# SPECIALISE patchElem :: ElemState IO a w -> VDom a w -> IO (VDomStep IO a w) #-}+{-# SPECIALISE haltElem :: ElemState IO a w -> IO () #-}+{-# SPECIALISE buildWidget :: VDomSpec IO a w -> VDomMachine IO a w -> w -> IO (VDomStep IO a w) #-}+{-# SPECIALISE patchWidget :: WidgetState IO a w -> VDom a w -> IO (VDomStep IO a w) #-}+#endif++type VDomMachine m a w = Machine m (VDom a w) Node++type VDomStep m a w = Step m (VDom a w) Node++data VDomSpec m a w = VDomSpec+  { buildWidget :: VDomSpec m a w -> Machine m w Node+  , buildAttributes :: Element -> Machine m a ()+  , document :: Document+  }++buildVDom :: (MonadDOM m) => VDomSpec m a w -> VDomMachine m a w+buildVDom spec = build+  where+    build = \case+      Text txt -> buildText spec build txt+      Elem ns n props children -> buildElem spec build ns n props children+      Keyed ns n props children -> buildKeyed spec build ns n props children+      Widget w -> buildWidget spec build w+      Grafted g -> build (runGraft g)++----------------------------------------------------------------------++data TextState m a w = TextState+  { build :: VDomMachine m a w+  , node :: Node+  , value :: Text+  }++buildText :: (MonadDOM m) => VDomSpec m a w -> VDomMachine m a w -> Text -> m (VDomStep m a w)+buildText spec build value = do+  node <- createTextNode value spec.document+  let state = TextState {..}+  pure $ Step node state patchText haltText++patchText :: (MonadDOM m) => TextState m a w -> VDom a w -> m (VDomStep m a w)+patchText state vdom = do+  let TextState {build, node, value = value1} = state+  case vdom of+    Text value2+      | value1 == value2 ->+          pure $ Step node state patchText haltText+      | otherwise -> do+          let nextState = TextState {build, node, value = value2}+          setTextContent value2 node+          pure $ Step node nextState patchText haltText+    _ -> do+      haltText state+      build vdom++haltText :: (MonadDOM m) => TextState m a w -> m ()+haltText TextState {node} =+  traverse_ (removeChild node) =<< parentNode node++----------------------------------------------------------------------++data KeyedState m a w = KeyedState+  { build :: VDomMachine m a w+  , node :: Node+  , attrs :: Step m a ()+  , ns :: Maybe Namespace+  , name :: ElemName+  , children :: Map Text (VDomStep m a w)+  , length :: Int+  }++buildKeyed :: (MonadDOM m) => VDomSpec m a w -> VDomMachine m a w -> Maybe Namespace -> ElemName -> a -> [(Text, VDom a w)] -> m (VDomStep m a w)+buildKeyed spec build ns1 name1 as1 ch1 = do+  el <- createElement ns1 name1 spec.document+  let node = elementToNode el+      onChild _ ix (_, vdom) = do+        res <- build vdom+        insertChildIx ix (extract res) $ toParentNode node+        pure res+  children <- strMapWithIxE ch1 fst onChild+  attrs <- spec.buildAttributes el as1+  let state =+        KeyedState+          { build+          , node+          , attrs+          , ns = ns1+          , name = name1+          , children+          , length = length ch1+          }+  pure $ Step node state patchKeyed haltKeyed++patchKeyed :: (MonadDOM m) => KeyedState m a w -> VDom a w -> m (VDomStep m a w)+patchKeyed state vdom = do+  let KeyedState {build, node, attrs, ns = ns1, name = name1, children = ch1, length = len1} = state+  case vdom of+    Grafted g ->+      patchKeyed state (runGraft g)+    Keyed ns2 name2 as2 ch2 | (ns1, name1) == (ns2, name2) ->+      case (len1, length ch2) of+        (0, 0) -> do+          attrs2 <- step attrs as2+          let nextState =+                KeyedState+                  { build+                  , node+                  , attrs = attrs2+                  , ns = ns2+                  , name = name2+                  , children = ch1+                  , length = 0+                  }+          pure $ Step node nextState patchKeyed haltKeyed+        (_, len2) -> do+          let onThese _ ix' s (_, v) = do+                res <- step s v+                insertChildIx ix' (extract res) $ toParentNode node+                pure res+              onThis _ = halt+              onThat _ ix (_, v) = do+                res <- build v+                insertChildIx ix (extract res) $ toParentNode node+                pure res+          children2 <- diffWithKeyAndIxE ch1 ch2 fst onThese onThis onThat+          attrs2 <- step attrs as2+          let nextState =+                KeyedState+                  { build+                  , node+                  , attrs = attrs2+                  , ns = ns2+                  , name = name2+                  , children = children2+                  , length = len2+                  }+          pure $ Step node nextState patchKeyed haltKeyed+    _ -> do+      haltKeyed state+      build vdom++haltKeyed :: (MonadDOM m) => KeyedState m a w -> m ()+haltKeyed (KeyedState {node, attrs, children}) = do+  parent <- parentNode node+  traverse_ (removeChild node) parent+  for_ children halt+  halt attrs++----------------------------------------------------------------------++data ElemState m a w = ElemState+  { build :: VDomMachine m a w+  , node :: Node+  , attrs :: Step m a ()+  , ns :: Maybe Namespace+  , name :: ElemName+  , children :: [VDomStep m a w]+  }++buildElem+  :: (MonadDOM m)+  => VDomSpec m a w+  -> VDomMachine m a w+  -> Maybe Namespace+  -> ElemName+  -> a+  -> [VDom a w]+  -> m (VDomStep m a w)+buildElem spec build ns1 name1 as1 ch1 = do+  el <- createElement ns1 name1 spec.document+  let node = elementToNode el+      onChild ix child = do+        res <- build child+        insertChildIx ix (extract res) $ toParentNode node+        pure res++  children <- for (zip [0 ..] ch1) (uncurry onChild)+  attrs <- spec.buildAttributes el as1+  let state = ElemState {build, node, attrs, ns = ns1, name = name1, children}+  pure $ Step node state patchElem haltElem++patchElem :: (MonadDOM m) => ElemState m a w -> VDom a w -> m (VDomStep m a w)+patchElem state vdom = do+  let ElemState {build, node, attrs, ns = ns1, name = name1, children = ch1} = state+  case vdom of+    Grafted g ->+      patchElem state (runGraft g)+    Elem ns2 name2 as2 ch2 | (ns1, name1) == (ns2, name2) ->+      case (ch1, ch2) of+        ([], []) -> do+          attrs2 <- step attrs as2+          let nextState = ElemState {attrs = attrs2, ns = ns2, name = name2, children = ch1, ..}+          pure $ Step node nextState patchElem haltElem+        _ -> do+          let onThese ix s v = do+                res <- step s v+                insertChildIx ix (extract res) $ toParentNode node+                pure $ Just res+              onThis _ s = halt s $> Nothing+              onThat ix v = do+                res <- build v+                insertChildIx ix (extract res) $ toParentNode node+                pure $ Just res+          children2 <- diffWithIxE ch1 ch2 onThese onThis onThat+          attrs2 <- step attrs as2+          let nextState = ElemState {attrs = attrs2, ns = ns2, name = name2, children = children2, ..}+          pure $ Step node nextState patchElem haltElem+    _ -> do+      haltElem state+      build vdom++haltElem :: (MonadDOM m) => ElemState m a w -> m ()+haltElem ElemState {node, attrs, children} = do+  traverse_ (removeChild node) =<< parentNode node+  for_ children halt+  halt attrs++----------------------------------------------------------------------++data WidgetState m a w = WidgetState+  { build :: VDomMachine m a w+  , widget :: Step m w Node+  }++buildWidget :: (Monad m) => VDomSpec m a w -> VDomMachine m a w -> w -> m (VDomStep m a w)+buildWidget spec build w = do+  res@(Step node _ _ _) <- spec.buildWidget spec w+  pure $ Step node (WidgetState {build, widget = res}) patchWidget haltWidget++patchWidget :: (Monad m) => WidgetState m a w -> VDom a w -> m (VDomStep m a w)+patchWidget state vdom = do+  let WidgetState {build, widget} = state+  case vdom of+    Grafted g -> patchWidget state (runGraft g)+    Widget w -> do+      res@(Step n _ _ _) <- step widget w++      pure $ Step n (WidgetState {build, widget = res}) patchWidget haltWidget+    _ -> do+      haltWidget state+      build vdom++haltWidget :: WidgetState m a w -> m ()+haltWidget WidgetState {widget} = halt widget
+ src/Halogen/VDom/DOM/Monad.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP #-}++module Halogen.VDom.DOM.Monad where++import HPrelude+import Halogen.VDom.Types+import Unsafe.Coerce (unsafeCoerce)+import Web.DOM.Element+import Web.DOM.Internal.Types+import Web.DOM.ParentNode+import Web.Event.Event+import Web.HTML.Common+import Web.HTML.HTMLDocument.ReadyState as ReadyState+import Web.UIEvent.MouseEvent++#if defined(javascript_HOST_ARCH)+import Data.Foreign+import GHC.JS.Prim+import GHC.JS.Foreign.Callback+#endif++data PropValue val where+  IntProp :: (Integral a) => a -> PropValue a+  NumProp :: Double -> PropValue Double+  BoolProp :: Bool -> PropValue Bool+  TxtProp :: Text -> PropValue Text+  ViaTxtProp :: (a -> Text) -> a -> PropValue a++class (Monad m) => MonadDOM m where+  mkEventListener :: (Event -> m ()) -> m EventListener++  createTextNode :: Text -> Document -> m Node+  setTextContent :: Text -> Node -> m ()+  createElement :: Maybe Namespace -> ElemName -> Document -> m Element+  insertBefore :: Node -> Node -> ParentNode -> m ()+  appendChild :: Node -> ParentNode -> m ()+  replaceChild :: Node -> Node -> ParentNode -> m ()+  insertChildIx :: Int -> Node -> ParentNode -> m ()+  removeChild :: Node -> ParentNode -> m ()+  parentNode :: Node -> m (Maybe ParentNode)+  nextSibling :: Node -> m (Maybe Node)+  setAttribute :: Maybe Namespace -> AttrName -> Text -> Element -> m ()+  setProperty :: PropName a -> PropValue a -> Element -> m ()+  unsafeGetProperty :: PropName a -> Element -> m a+  removeProperty :: PropName a -> Element -> m ()+  removeAttribute :: Maybe Namespace -> AttrName -> Element -> m ()+  hasAttribute :: Maybe Namespace -> AttrName -> Element -> m Bool++  addEventListener :: EventType -> EventListener -> EventTarget -> m ()+  removeEventListener :: EventType -> EventListener -> EventTarget -> m ()++  window :: m Window+  document :: Window -> m HTMLDocument++  querySelector :: QuerySelector -> ParentNode -> m (Maybe Element)+  readyState :: HTMLDocument -> m ReadyState+  log :: Text -> m ()++mouseHandler :: (MouseEvent -> a) -> Event -> a+mouseHandler = coerce++elementToNode :: Element -> Node+elementToNode = coerce++toEventTarget :: a -> EventTarget+toEventTarget = unsafeCoerce++#if defined(javascript_HOST_ARCH)+-- implementation of MonadDOM for IO++foreign import javascript unsafe "js_create_text_node" js_create_text_node :: JSVal -> Document -> IO Node+foreign import javascript unsafe "js_set_text_content" js_set_text_content :: JSVal -> Node -> IO ()+foreign import javascript unsafe "js_create_element" js_create_element :: JSVal -> JSVal -> Document -> IO Element+foreign import javascript unsafe "js_insert_before" js_insert_before :: Node -> Node -> ParentNode -> IO ()+foreign import javascript unsafe "js_get_window" js_get_window :: IO Window+foreign import javascript unsafe "js_get_document" js_get_document :: Window -> IO HTMLDocument+foreign import javascript unsafe "js_append_child" js_append_child :: Node -> ParentNode -> IO ()+foreign import javascript unsafe "js_replace_child" js_replace_child :: Node -> Node -> ParentNode -> IO ()+foreign import javascript unsafe "js_insert_child_ix" js_insert_child_ix :: Int -> Node -> ParentNode -> IO ()+foreign import javascript unsafe "js_remove_child" js_remove_child :: Node -> ParentNode -> IO ()+foreign import javascript unsafe "js_parent_node" js_parent_node :: Node -> IO (Nullable ParentNode)+foreign import javascript unsafe "js_next_sibling" js_next_sibling :: Node -> IO (Nullable Node)+foreign import javascript unsafe "js_set_attribute" js_set_attribute :: JSVal -> JSVal -> JSVal -> Element -> IO ()+foreign import javascript unsafe "js_set_property" js_set_property :: JSVal -> JSVal -> Element -> IO ()+foreign import javascript unsafe "js_unsafe_get_property" js_unsafe_get_property :: JSVal -> Element -> IO JSVal+foreign import javascript unsafe "js_remove_property" js_remove_property :: JSVal -> Element -> IO ()+foreign import javascript unsafe "js_remove_attribute" js_remove_attribute :: JSVal -> JSVal -> Element -> IO ()+foreign import javascript unsafe "js_has_attribute" js_has_attribute :: JSVal -> JSVal -> Element -> IO Bool+foreign import javascript unsafe "js_add_event_listener" js_add_event_listener :: JSVal -> EventListener -> EventTarget -> IO ()+foreign import javascript unsafe "js_remove_event_listener" js_remove_event_listener :: JSVal -> EventListener -> EventTarget -> IO ()+foreign import javascript unsafe "js_query_selector" js_query_selector :: JSVal -> ParentNode -> IO (Nullable Element)+foreign import javascript unsafe "js_ready_state" js_ready_state :: HTMLDocument -> IO JSVal++foreign import javascript unsafe "(($1) => { return $1; })"+  js_toJSBool :: Bool -> JSVal++foreign import javascript unsafe "(($1) => { return $1; })"+  js_toJSNum :: Double -> JSVal++foreign import javascript unsafe "(($1) => { console.log($1); })"+  js_log :: JSVal -> IO ()++instance MonadDOM IO where+  mkEventListener f = EventListener <$> asyncCallback1 (f . Event)++  window = js_get_window+  document = js_get_document+  createTextNode txt doc = js_create_text_node (toJSString $ toS txt) doc+  setTextContent txt node = js_set_text_content (toJSString $ toS txt) node+  createElement ns (ElemName name) doc = js_create_element (maybe jsNull (toJSString . toS . unNamespace) ns) (toJSString $ toS name) doc+  insertBefore newNode sibling parent = js_insert_before newNode sibling parent+  appendChild child parent = js_append_child child parent+  replaceChild newChild oldChild parent = js_replace_child newChild oldChild parent+  insertChildIx ix child parent = js_insert_child_ix ix child parent+  removeChild child parent = js_remove_child child parent+  parentNode node = fmap ParentNode . nullableToMaybe <$> js_parent_node node+  nextSibling node = fmap Node . nullableToMaybe <$> js_next_sibling node+  setAttribute ns (AttrName name) val el = js_set_attribute (maybe jsNull (toJSString . toS . unNamespace) ns) (toJSString $ toS name) (toJSString $ toS val) el+  setProperty (PropName name) val el = js_set_property (toJSString $ toS name) (propValueToJSVal val) el+  unsafeGetProperty (PropName name) el = unsafeFromForeign <$> js_unsafe_get_property (toJSString $ toS name) el+  removeProperty (PropName name) el = js_remove_property (toJSString $ toS name) el+  removeAttribute ns (AttrName name) el = js_remove_attribute (maybe jsNull (toJSString . toS . unNamespace) ns) (toJSString $ toS name) el+  hasAttribute ns (AttrName name) el = js_has_attribute (maybe jsNull (toJSString . toS . unNamespace) ns) (toJSString $ toS name) el+  addEventListener (EventType et) listener target = js_add_event_listener (toJSString $ toS et) listener target+  +  removeEventListener (EventType et) listener@(EventListener clb) target = do+    js_remove_event_listener (toJSString $ toS et) listener target+    releaseCallback clb++  querySelector (QuerySelector qs) parent = fmap Element . nullableToMaybe <$> js_query_selector (toJSString $ toS qs) parent+  readyState doc = (fromMaybe ReadyState.Loading . ReadyState.parse . toS . fromJSString) <$> js_ready_state doc+  log txt = js_log (toJSString $ toS txt)++propValueToJSVal :: PropValue a -> JSVal+propValueToJSVal (IntProp x) = toJSInt $ fromIntegral x+propValueToJSVal (NumProp x) = js_toJSNum x+propValueToJSVal (BoolProp x) = js_toJSBool x+propValueToJSVal (TxtProp x) = toJSString $ toS x+propValueToJSVal (ViaTxtProp f x) = toJSString $ toS $ f x+#endif
+ src/Halogen/VDom/DOM/Prop.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Redundant <$>" #-}+module Halogen.VDom.DOM.Prop+  ( Prop (..)+  , ElemRef (..)+  , PropValue (..)+  , buildProp+  )+where++import Data.Foreign+import Data.Map.Strict qualified as M+import HPrelude hiding (state)+import Halogen.VDom.DOM.Monad+import Halogen.VDom.Machine qualified as V+import Halogen.VDom.Types+import Halogen.VDom.Utils qualified as Util+import Web.DOM.Element+import Web.DOM.Internal.Types qualified as DOM+import Web.Event.Event+import Web.Event.Event qualified as DOM+import Web.HTML.Common++data Prop msg+  = Attribute (Maybe Namespace) AttrName Text+  | forall val. Property (PropName val) (PropValue val)+  | Handler EventType (Event -> Maybe msg)+  | Ref (ElemRef Element -> Maybe msg)++deriving instance Functor Prop++data ElemRef a+  = Created a+  | Removed a+  deriving (Functor)++type EventMap m a = Map Text (DOM.EventListener, IORef (Event -> Maybe a))++data PropState m a = PropState+  { events :: IORef (EventMap m a)+  , props :: Map Text (Prop a)+  }++propToStrKey :: Prop i -> Text+propToStrKey = \case+  Attribute (Just (Namespace ns)) (AttrName attr) _ -> "attr/" <> ns <> ":" <> attr+  Attribute _ (AttrName attr) _ -> "attr/:" <> attr+  Property (PropName prop) _ -> "prop/" <> prop+  Handler (DOM.EventType ty) _ -> "handler/" <> ty+  Ref _ -> "ref"++#if defined(javascript_HOST_ARCH)+{-# SPECIALISE buildProp :: (a -> IO ()) -> DOM.Element -> V.Machine IO [Prop a] () #-}+#endif+buildProp+  :: forall m a+   . (MonadIO m, MonadDOM m)+  => (a -> m ())+  -> DOM.Element+  -> V.Machine m [Prop a] ()+buildProp emit el = renderProp+  where+    renderProp :: V.Machine m [Prop a] ()+    renderProp ps1 = do+      events <- newIORef mempty+      ps1' <- Util.strMapWithIxE ps1 propToStrKey (applyProp events)+      let state =+            PropState+              { events+              , props = ps1'+              }+      pure $ V.Step () state patchProp haltProp++    patchProp :: PropState m a -> [Prop a] -> m (V.Step m [Prop a] ())+    patchProp state ps2 = do+      events <- newIORef mempty+      let PropState {events = prevEvents, props = ps1} = state+          onThese = diffProp prevEvents events+          onThis = removeProp prevEvents+          onThat = applyProp events+      props <- Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat+      let nextState =+            PropState+              { events+              , props+              }+      pure $ V.Step () nextState patchProp haltProp++    haltProp state = do+      case M.lookup "ref" state.props of+        Just (Ref f) ->+          mbEmit (f (Removed el))+        _ -> pass++    mbEmit = traverse_ emit++    applyProp :: IORef (EventMap m a) -> Text -> Int -> Prop a -> m (Prop a)+    applyProp events _ _ v =+      case v of+        Attribute ns attr val -> do+          setAttribute ns attr val el+          pure v+        Property prop val -> do+          setProperty prop val el+          pure v+        Handler evty@(DOM.EventType ty) f -> do+          M.lookup ty+            <$> readIORef events+            >>= \case+              Just handler -> do+                atomicWriteIORef (snd handler) f+                pure v+              _ -> do+                ref <- newIORef f+                listener <- mkEventListener $ \ev -> do+                  f' <- readIORef ref+                  mbEmit (f' ev)+                atomicModifyIORef'_ events (M.insert ty (listener, ref))+                addEventListener evty listener $ toEventTarget el+                pure v+        Ref f -> do+          mbEmit (f (Created el))+          pure v++    diffProp+      :: IORef (EventMap m a)+      -> IORef (EventMap m a)+      -> Text+      -> Int+      -> Prop a+      -> Prop a+      -> m (Prop a)+    diffProp prevEvents events _ _ v1 v2 = do+      case (v1, v2) of+        (Attribute _ _ val1, Attribute ns2 attr2 val2) ->+          if val1 == val2+            then pure v2+            else do+              setAttribute ns2 attr2 val2 el+              pure v2+        (Property _ val1, Property prop2 val2) ->+          case (val1 `unsafeRefEq'` val2, prop2) of+            (True, _) ->+              pure v2+            (_, "value") -> do+              elVal <- unsafeGetProperty "value" el+              if elVal `unsafeRefEq` val2+                then pure v2+                else do+                  setProperty prop2 val2 el+                  pure v2+            (_, _) -> do+              setProperty prop2 val2 el+              pure v2+        (Handler _ _, Handler (DOM.EventType ty) f) -> do+          handler <- (M.! ty) <$> readIORef prevEvents+          atomicWriteIORef (snd handler) f+          atomicModifyIORef'_ events (M.insert ty handler)+          pure v2+        (_, _) ->+          pure v2++    removeProp prevEvents _ v =+      case v of+        Attribute ns attr _ ->+          removeAttribute ns attr el+        Property prop _ ->+          removeProperty prop el+        Handler evty@(DOM.EventType ty) _ -> do+          handler <- (M.! ty) <$> readIORef prevEvents+          removeEventListener evty (fst handler) $ toEventTarget el+        Ref _ -> pass
+ src/Halogen/VDom/Driver.hs view
@@ -0,0 +1,182 @@+module Halogen.VDom.Driver+  ( runUI+  , module Halogen.IO.Driver+  )+where++import Control.Exception.Safe+import Control.Monad.Fork+import Control.Monad.Parallel+import Control.Monad.UUID+import Data.Coerce+import Data.Foreign+import HPrelude+import Halogen.Component+import Halogen.HTML.Core (HTML (..))+import Halogen.IO.Driver (HalogenSocket)+import Halogen.IO.Driver qualified as AD+import Halogen.IO.Driver.State+import Halogen.Query.Input+import Halogen.VDom qualified as V+import Halogen.VDom.DOM.Monad qualified as DOM+import Halogen.VDom.DOM.Prop+import Halogen.VDom.DOM.Prop qualified as VP+import Halogen.VDom.Thunk (Thunk)+import Halogen.VDom.Thunk qualified as Thunk+import Web.DOM.Internal.Types+import Web.DOM.Internal.Types qualified as DOM+import Web.DOM.ParentNode (ParentNode, toParentNode)++#if defined(javascript_HOST_ARCH)+{-# SPECIALISE substInParent :: DOM.Node -> Maybe DOM.Node -> Maybe ParentNode -> IO () #-}+{-# SPECIALISE removeChild :: forall state action slots output. RenderState IO state action slots output -> IO () #-}+{-# SPECIALISE renderSpec :: DOM.Document -> DOM.HTMLElement -> AD.RenderSpec IO (RenderState IO) #-}+{-# SPECIALISE runUI :: forall query input output. Component query input output IO -> input -> DOM.HTMLElement -> IO (HalogenSocket query output IO) #-}+{-# SPECIALISE mkSpec :: forall action slots. (Input action -> IO ()) -> IORef (ChildRenderer IO action slots) -> DOM.Document -> V.VDomSpec IO [Prop (Input action)] (ComponentSlot slots IO action) #-}+#endif++type VHTML m action slots =+  V.VDom [Prop (Input action)] (ComponentSlot slots m action)++type ChildRenderer m action slots = ComponentSlotBox slots m action -> m (RenderStateX (RenderState m))++data RenderState m state action slots output+  = RenderState+  { node :: DOM.Node+  , machine :: V.Step m (VHTML m action slots) DOM.Node+  , renderChildRef :: IORef (ChildRenderer m action slots)+  }++type HTMLThunk m slots action =+  Thunk (HTML (ComponentSlot slots m action)) action++type WidgetState m slots action =+  Maybe (V.Step m (HTMLThunk m slots action) DOM.Node)++mkSpec+  :: forall m action slots+   . (MonadIO m, DOM.MonadDOM m)+  => (Input action -> m ())+  -> IORef (ChildRenderer m action slots)+  -> DOM.Document+  -> V.VDomSpec m [Prop (Input action)] (ComponentSlot slots m action)+mkSpec handler renderChildRef document =+  V.VDomSpec {buildWidget, buildAttributes, document}+  where+    buildAttributes+      :: DOM.Element+      -> V.Machine m [Prop (Input action)] ()+    buildAttributes = VP.buildProp handler++    buildWidget+      :: V.VDomSpec+           m+           [Prop (Input action)]+           (ComponentSlot slots m action)+      -> V.Machine+           m+           (ComponentSlot slots m action)+           DOM.Node+    buildWidget spec = render+      where+        render :: V.Machine m (ComponentSlot slots m action) DOM.Node+        render = \case+          ComponentSlot cs ->+            renderComponentSlot cs+          ThunkSlot t -> do+            step <- buildThunk t+            pure $ V.Step (V.extract step) (Just step) patch done++        patch+          :: WidgetState m slots action+          -> ComponentSlot slots m action+          -> m (V.Step m (ComponentSlot slots m action) DOM.Node)+        patch st slot =+          case st of+            Just step -> case slot of+              ComponentSlot cs -> do+                V.halt step+                renderComponentSlot cs+              ThunkSlot t -> do+                step' <- V.step step t+                pure $ V.Step (V.extract step') (Just step') patch done+            _ -> render slot++        buildThunk :: V.Machine m (HTMLThunk m slots action) DOM.Node+        buildThunk = Thunk.buildThunk coerce spec++        renderComponentSlot+          :: ComponentSlotBox slots m action+          -> m (V.Step m (ComponentSlot slots m action) DOM.Node)+        renderComponentSlot cs = do+          renderChild <- readIORef renderChildRef+          rsx <- renderChild cs+          let node = getNode rsx+          pure $ V.Step node Nothing patch done++    done :: WidgetState m slots action -> m ()+    done = traverse_ V.halt++    getNode :: RenderStateX (RenderState m) -> DOM.Node+    getNode (RenderStateX (RenderState {node})) = node++runUI+  :: forall m query input output+   . (DOM.MonadDOM m, MonadUnliftIO m, MonadFork m, MonadKill m, MonadParallel m, MonadMask m, MonadUUID m)+  => Component query input output m+  -> input+  -> DOM.HTMLElement+  -> m (HalogenSocket query output m)+runUI component i element = do+  document <- toDocument <$> (DOM.document =<< DOM.window)+  AD.runUI (renderSpec document element) component i++renderSpec+  :: forall m+   . (DOM.MonadDOM m, MonadIO m)+  => DOM.Document+  -> DOM.HTMLElement+  -> AD.RenderSpec m (RenderState m)+renderSpec document container =+  AD.RenderSpec+    { render+    , renderChild = identity+    , removeChild+    , dispose = removeChild+    }+  where+    render+      :: forall state action slots output+       . (Input action -> m ())+      -> (ComponentSlotBox slots m action -> m (RenderStateX (RenderState m)))+      -> HTML (ComponentSlot slots m action) action+      -> Maybe (RenderState m state action slots output)+      -> m (RenderState m state action slots output)+    render handler child (HTML vdom) =+      \case+        Nothing -> do+          renderChildRef <- newIORef child+          let spec = mkSpec handler renderChildRef document+          machine <- V.buildVDom spec vdom+          let node = V.extract machine+          void $ DOM.appendChild node $ toParentNode $ toNode container+          pure $ RenderState {machine, node, renderChildRef}+        Just (RenderState {machine, node, renderChildRef}) -> do+          atomicWriteIORef renderChildRef child+          parent <- DOM.parentNode node+          nextSib <- DOM.nextSibling node+          machine' <- V.step machine vdom+          let newNode = V.extract machine'+          unless (node `unsafeRefEq` newNode)+            $ substInParent newNode nextSib parent+          pure $ RenderState {machine = machine', node = newNode, renderChildRef}++removeChild :: forall m state action slots output. (DOM.MonadDOM m) => RenderState m state action slots output -> m ()+removeChild (RenderState {node}) = do+  npn <- DOM.parentNode node+  traverse_ (DOM.removeChild node) npn++substInParent :: (DOM.MonadDOM m) => DOM.Node -> Maybe DOM.Node -> Maybe ParentNode -> m ()+substInParent newNode (Just sib) (Just pn) = void $ DOM.insertBefore newNode sib pn+substInParent newNode Nothing (Just pn) = void $ DOM.appendChild newNode pn+substInParent _ _ _ = pass
+ src/Halogen/VDom/Machine.hs view
@@ -0,0 +1,24 @@+module Halogen.VDom.Machine+  ( Machine+  , Step (..)+  , extract+  , step+  , halt+  )+where++type Machine m a b = a -> m (Step m a b)++data Step m a b = forall s. Step b s (s -> a -> m (Step m a b)) (s -> m ())++{-# INLINE extract #-}+extract :: Step m a b -> b+extract (Step r _ _ _) = r++{-# INLINE step #-}+step :: Step m a b -> a -> m (Step m a b)+step (Step _ s stp _) = stp s++{-# INLINE halt #-}+halt :: Step m a b -> m ()+halt (Step _ s _ h) = h s
+ src/Halogen/VDom/Thunk.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}+module Halogen.VDom.Thunk where++import Data.Foreign+import HPrelude hiding (state)+import Halogen.VDom qualified as V+import Halogen.VDom.DOM.Monad+import Unsafe.Coerce+import Web.DOM.Internal.Types++newtype ThunkId = ThunkId (Foreign ThunkId)++unsafeThunkId :: a -> ThunkId+unsafeThunkId = unsafeCoerce++data Thunk f i = forall a. Thunk ThunkId (a -> a -> Bool) (a -> f i) a++deriving instance (Functor f) => Functor (Thunk f)++unsafeEqThunk :: forall f i. Thunk f i -> Thunk f i -> Bool+unsafeEqThunk (Thunk a1 b1 _ d1) (Thunk a2 b2 _ d2) =+  unsafeRefEq a1 a2+    && unsafeRefEq' b1 b2+    && b1 d1 (unsafeCoerce d2)++data ThunkState m f i a w = ThunkState+  { vdom :: V.Step m (V.VDom a w) Node+  , thunk :: Thunk f i+  }++hoist :: forall f g a. (forall x. f x -> g x) -> Thunk f a -> Thunk g a+hoist f = mapThunk f++mapThunk :: forall f g i j. (f i -> g j) -> Thunk f i -> Thunk g j+mapThunk k (Thunk a b c d) = Thunk a b (k . c) d++runThunk :: forall f i. Thunk f i -> f i+runThunk (Thunk _ _ render arg) = render arg++#if defined(javascript_HOST_ARCH)+{-# SPECIALISE buildThunk :: (f i -> V.VDom a w) -> V.VDomSpec IO a w -> V.Machine IO (Thunk f i) Node #-}+#endif+buildThunk+  :: forall m f i a w+   . (MonadDOM m)+  => (f i -> V.VDom a w)+  -> V.VDomSpec m a w+  -> V.Machine m (Thunk f i) Node+buildThunk toVDom = renderThunk+  where+    renderThunk :: V.VDomSpec m a w -> V.Machine m (Thunk f i) Node+    renderThunk spec t = do+      vdom <- V.buildVDom spec (toVDom (runThunk t))+      pure $ V.Step (V.extract vdom) (ThunkState {thunk = t, vdom}) patchThunk haltThunk++    patchThunk :: ThunkState m f i a w -> Thunk f i -> m (V.Step m (Thunk f i) Node)+    patchThunk state t2 = do+      let ThunkState {vdom = prev, thunk = t1} = state+      if unsafeEqThunk t1 t2+        then pure $ V.Step (V.extract prev) state patchThunk haltThunk+        else do+          vdom <- V.step prev (toVDom (runThunk t2))+          pure $ V.Step (V.extract vdom) (ThunkState {vdom, thunk = t2}) patchThunk haltThunk++    haltThunk :: ThunkState m f i a w -> m ()+    haltThunk state = V.halt state.vdom
+ src/Halogen/VDom/Types.hs view
@@ -0,0 +1,57 @@+module Halogen.VDom.Types+  ( VDom (..)+  , renderWidget+  , Graft (..)+  , runGraft+  , ElemName (..)+  , Namespace (..)+  , unNamespace+  )+where++import HPrelude++newtype ElemName = ElemName Text+  deriving (Eq, Ord, Show, IsString)++newtype Namespace = Namespace Text+  deriving (Eq, Ord, Show, IsString)++unNamespace :: Namespace -> Text+unNamespace (Namespace ns) = ns++data VDom a w+  = Text Text+  | Elem (Maybe Namespace) ElemName a [VDom a w]+  | Keyed (Maybe Namespace) ElemName a [(Text, VDom a w)]+  | Widget w+  | Grafted (Graft a w)+  deriving (Functor)++instance Bifunctor VDom where+  bimap f g = \case+    Text s -> Text s+    Elem ns'm en props children -> Elem ns'm en (f props) (map (bimap f g) children)+    Keyed ns'm en props children -> Keyed ns'm en (f props) (map (second (bimap f g)) children)+    Widget w -> Widget $ g w+    Grafted graft -> Grafted $ bimap f g graft++data Graft a w = forall a' w'. Graft (a' -> a) (w' -> w) (VDom a' w')++deriving instance Functor (Graft a)++instance Bifunctor Graft where+  bimap f g (Graft fm wm v) = Graft (f . fm) (g . wm) v++runGraft :: Graft a w -> VDom a w+runGraft (Graft fm fw v) = bimap fm fw v++renderWidget :: (a -> a') -> (w -> VDom a' w') -> VDom a w -> VDom a' w'+renderWidget fm injWidget = \case+  Text txt -> Text txt+  Elem ns'm en props children ->+    Elem ns'm en (fm props) (map (renderWidget fm injWidget) children)+  Keyed ns'm en props children ->+    Keyed ns'm en (fm props) (map (second (renderWidget fm injWidget)) children)+  Widget w -> injWidget w+  Grafted graft -> renderWidget fm injWidget (runGraft graft)
+ src/Halogen/VDom/Utils.hs view
@@ -0,0 +1,72 @@+module Halogen.VDom.Utils where++import Data.Map.Strict qualified as M+import HPrelude++{-# SPECIALIZE diffWithIxE ::+  [a]+  -> [b]+  -> (Int -> a -> b -> IO (Maybe c))+  -> (Int -> a -> IO (Maybe c))+  -> (Int -> b -> IO (Maybe c))+  -> IO [c]+  #-}+diffWithIxE :: (Monad m) => [b] -> [c] -> (Int -> b -> c -> m (Maybe d)) -> (Int -> b -> m (Maybe d)) -> (Int -> c -> m (Maybe d)) -> m [d]+diffWithIxE u v onThese onThis onThat = reverse . catMaybes <$> go 0 u v []+  where+    go _ [] [] acc = pure acc+    go i (x : xs) [] acc = do+      void $ onThis i x+      go (i + 1) xs [] acc+    go i [] (y : ys) acc = do+      val <- onThat i y+      go (i + 1) [] ys (val : acc)+    go i (x : xs) (y : ys) acc = do+      val <- onThese i x y+      go (i + 1) xs ys (val : acc)++{-# SPECIALIZE diffWithKeyAndIxE ::+  Map Text a+  -> [b]+  -> (b -> Text)+  -> (Text -> Int -> a -> b -> IO c)+  -> (Text -> a -> IO d)+  -> (Text -> Int -> b -> IO c)+  -> IO (Map Text c)+  #-}+diffWithKeyAndIxE+  :: (Monad m)+  => Map Text a+  -> [b]+  -> (b -> Text)+  -> (Text -> Int -> a -> b -> m c)+  -> (Text -> a -> m d)+  -> (Text -> Int -> b -> m c)+  -> m (Map Text c)+diffWithKeyAndIxE o1 as fk f1 f2 f3 = do+  o2 <- foldM go M.empty (zip [0 ..] as)+  traverse_ (uncurry f2) (M.toAscList (M.difference o1 o2))+  pure o2+  where+    go acc (i, a) = do+      let k = fk a+      val <- case M.lookup k o1 of+        Just v -> f1 k i v a+        Nothing -> f3 k i a+      pure $ M.insert k val acc++{-# SPECIALIZE strMapWithIxE ::+  [a]+  -> (a -> Text)+  -> (Text -> Int -> a -> IO b)+  -> IO (Map Text b)+  #-}+strMapWithIxE :: (Monad m) => [a] -> (a -> Text) -> (Text -> Int -> a -> m b) -> m (Map Text b)+strMapWithIxE = strMapWithIxE' . zip [0 ..]+  where+    strMapWithIxE' :: (Monad m) => [(Int, a)] -> (a -> Text) -> (Text -> Int -> a -> m b) -> m (Map Text b)+    strMapWithIxE' [] _ _ = pure mempty+    strMapWithIxE' ((i, x) : xs) f g = do+      val <- g (f x) i x+      m <- strMapWithIxE' xs f g+      pure $ M.insert (f x) val m
+ src/Web/Clipboard.hs view
@@ -0,0 +1,1 @@+module Web.Clipboard where
+ src/Web/Clipboard/ClipboardEvent.hs view
@@ -0,0 +1,5 @@+module Web.Clipboard.ClipboardEvent where++import Web.Event.Internal.Types++newtype ClipboardEvent = ClipboardEvent Event
+ src/Web/Clipboard/ClipboardEvent/EventTypes.hs view
@@ -0,0 +1,15 @@+module Web.Clipboard.ClipboardEvent.EventTypes where++import Web.Event.Event (EventType (..))++clipboardchange :: EventType+clipboardchange = EventType "clipboardchange"++copy :: EventType+copy = EventType "copy"++cut :: EventType+cut = EventType "cut"++paste :: EventType+paste = EventType "paste"
+ src/Web/DOM/Element.hs view
@@ -0,0 +1,6 @@+module Web.DOM.Element+  ( module Exports+  )+where++import Web.DOM.Internal.Types as Exports (Element)
+ src/Web/DOM/Internal/Types.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}++module Web.DOM.Internal.Types where++import Data.Foreign (Foreign)+import HPrelude+import Unsafe.Coerce (unsafeCoerce)++#if defined(javascript_HOST_ARCH)+import GHC.JS.Prim+import GHC.JS.Foreign.Callback+#endif++newtype Node = Node (Foreign Node)++newtype NodeList = NodeList (Foreign NodeList)++newtype Element = Element (Foreign Element)++newtype HTMLElement = HTMLElement (Foreign HTMLElement)++newtype HTMLCollection = HTMLCollection (Foreign HTMLCollection)++#if defined(javascript_HOST_ARCH)+newtype EventListener = EventListener (Callback (JSVal -> IO ()))+#else+newtype EventListener = EventListener (Foreign EventListener)+#endif++newtype Document = Document (Foreign Document)++newtype HTMLDocument = HTMLDocument (Foreign HTMLDocument)++newtype Window = Window (Foreign Window)++fromElement :: Element -> Maybe HTMLElement+fromElement = Just . coerce++toDocument :: a -> Document+toDocument = unsafeCoerce++toNode :: a -> Node+toNode = unsafeCoerce
+ src/Web/DOM/ParentNode.hs view
@@ -0,0 +1,12 @@+module Web.DOM.ParentNode where++import Data.Foreign+import HPrelude+import Web.DOM.Internal.Types++newtype ParentNode = ParentNode (Foreign ParentNode)++toParentNode :: Node -> ParentNode+toParentNode = coerce++newtype QuerySelector = QuerySelector Text
+ src/Web/Event/Event.hs view
@@ -0,0 +1,21 @@+module Web.Event.Event+  ( EventType (..)+  , Event (..)+  , EventTarget (..)+  , currentTarget+  )+where++import Data.Foreign+import HPrelude+import Web.Event.Internal.Types++newtype EventType = EventType Text++currentTarget :: Event -> Maybe EventTarget+#if defined(javascript_HOST_ARCH)+foreign import javascript unsafe "js_current_target" js_current_target :: Event -> Nullable EventTarget+currentTarget e = EventTarget <$> nullableToMaybe (js_current_target e)+#else+currentTarget _ = panic "currentTarget: not available in GHC" -- TODO+#endif
+ src/Web/Event/Internal/Types.hs view
@@ -0,0 +1,7 @@+module Web.Event.Internal.Types where++import Data.Foreign (Foreign)++newtype Event = Event (Foreign Event)++newtype EventTarget = EventTarget (Foreign EventTarget)
+ src/Web/HTML/Common.hs view
@@ -0,0 +1,12 @@+module Web.HTML.Common where++import HPrelude++newtype PropName value = PropName Text+  deriving (Eq, Ord, Show, IsString)++newtype AttrName = AttrName Text+  deriving (Eq, Ord, Show, IsString)++newtype ClassName = ClassName Text+  deriving (Eq, Ord, Show, IsString)
+ src/Web/HTML/Event/DragEvent.hs view
@@ -0,0 +1,5 @@+module Web.HTML.Event.DragEvent where++import Web.Event.Internal.Types++newtype DragEvent = DragEvent Event
+ src/Web/HTML/Event/DragEvent/EventTypes.hs view
@@ -0,0 +1,27 @@+module Web.HTML.Event.DragEvent.EventTypes where++import Web.Event.Event (EventType (..))++dragstart :: EventType+dragstart = EventType "dragstart"++drag :: EventType+drag = EventType "drag"++dragenter :: EventType+dragenter = EventType "dragenter"++dragexit :: EventType+dragexit = EventType "dragexit"++dragleave :: EventType+dragleave = EventType "dragleave"++dragover :: EventType+dragover = EventType "dragover"++drop :: EventType+drop = EventType "drop"++dragend :: EventType+dragend = EventType "dragend"
+ src/Web/HTML/Event/EventTypes.hs view
@@ -0,0 +1,102 @@+module Web.HTML.Event.EventTypes where++import Web.Event.Event (EventType (..))++abort :: EventType+abort = EventType "abort"++afterprint :: EventType+afterprint = EventType "afterprint"++afterscriptexecute :: EventType+afterscriptexecute = EventType "afterscriptexecute"++beforeprint :: EventType+beforeprint = EventType "beforeprint"++beforescriptexecute :: EventType+beforescriptexecute = EventType "beforescriptexecute"++blur :: EventType+blur = EventType "blur"++cancel :: EventType+cancel = EventType "cancel"++change :: EventType+change = EventType "change"++click :: EventType+click = EventType "click"++close :: EventType+close = EventType "close"++copy :: EventType+copy = EventType "copy"++cut :: EventType+cut = EventType "cut"++domcontentloaded :: EventType+domcontentloaded = EventType "DOMContentLoaded"++error :: EventType+error = EventType "error"++focus :: EventType+focus = EventType "focus"++input :: EventType+input = EventType "input"++invalid :: EventType+invalid = EventType "invalid"++languagechange :: EventType+languagechange = EventType "languagechange"++load :: EventType+load = EventType "load"++loadend :: EventType+loadend = EventType "loadend"++loadstart :: EventType+loadstart = EventType "loadstart"++message :: EventType+message = EventType "message"++offline :: EventType+offline = EventType "offline"++online :: EventType+online = EventType "online"++paste :: EventType+paste = EventType "paste"++progress :: EventType+progress = EventType "progress"++readystatechange :: EventType+readystatechange = EventType "readystatechange"++reset :: EventType+reset = EventType "reset"++select :: EventType+select = EventType "select"++storage :: EventType+storage = EventType "storage"++submit :: EventType+submit = EventType "submit"++toggle :: EventType+toggle = EventType "toggle"++unload :: EventType+unload = EventType "unload"
+ src/Web/HTML/HTMLDocument.hs view
@@ -0,0 +1,8 @@+module Web.HTML.HTMLDocument where++import Data.Coerce+import Web.DOM.Internal.Types+import Web.DOM.ParentNode++toParentNode :: HTMLDocument -> ParentNode+toParentNode = coerce
+ src/Web/HTML/HTMLDocument/ReadyState.hs view
@@ -0,0 +1,22 @@+module Web.HTML.HTMLDocument.ReadyState where++import HPrelude++data ReadyState+  = Loading+  | Interactive+  | Complete+  deriving (Eq, Ord, Show)++print :: ReadyState -> Text+print = \case+  Loading -> "loading"+  Interactive -> "interactive"+  Complete -> "complete"++parse :: Text -> Maybe ReadyState+parse = \case+  "loading" -> Just Loading+  "interactive" -> Just Interactive+  "complete" -> Just Complete+  _ -> Nothing
+ src/Web/UIEvent/FocusEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.FocusEvent where++import Web.Event.Internal.Types++newtype FocusEvent = FocusEvent Event
+ src/Web/UIEvent/FocusEvent/EventTypes.hs view
@@ -0,0 +1,15 @@+module Web.UIEvent.FocusEvent.EventTypes where++import Web.Event.Event (EventType (..))++blur :: EventType+blur = EventType "blur"++focus :: EventType+focus = EventType "focus"++focusin :: EventType+focusin = EventType "focusin"++focusout :: EventType+focusout = EventType "focusout"
+ src/Web/UIEvent/KeyboardEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.KeyboardEvent where++import Web.Event.Internal.Types++newtype KeyboardEvent = KeyboardEvent Event
+ src/Web/UIEvent/KeyboardEvent/EventTypes.hs view
@@ -0,0 +1,9 @@+module Web.UIEvent.KeyboardEvent.EventTypes where++import Web.Event.Event (EventType (..))++keydown :: EventType+keydown = EventType "keydown"++keyup :: EventType+keyup = EventType "keyup"
+ src/Web/UIEvent/MouseEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.MouseEvent where++import Web.Event.Internal.Types++newtype MouseEvent = MouseEvent Event
+ src/Web/UIEvent/MouseEvent/EventTypes.hs view
@@ -0,0 +1,33 @@+module Web.UIEvent.MouseEvent.EventTypes where++import Web.Event.Event (EventType (..))++auxclick :: EventType+auxclick = EventType "auxclick"++click :: EventType+click = EventType "click"++dblclick :: EventType+dblclick = EventType "dblclick"++mousedown :: EventType+mousedown = EventType "mousedown"++mouseenter :: EventType+mouseenter = EventType "mouseenter"++mouseleave :: EventType+mouseleave = EventType "mouseleave"++mousemove :: EventType+mousemove = EventType "mousemove"++mouseout :: EventType+mouseout = EventType "mouseout"++mouseover :: EventType+mouseover = EventType "mouseover"++mouseup :: EventType+mouseup = EventType "mouseup"
+ src/Web/UIEvent/PointerEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.PointerEvent where++import Web.Event.Internal.Types++newtype PointerEvent = PointerEvent Event
+ src/Web/UIEvent/TouchEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.TouchEvent where++import Web.Event.Internal.Types++newtype TouchEvent = TouchEvent Event
+ src/Web/UIEvent/WheelEvent.hs view
@@ -0,0 +1,5 @@+module Web.UIEvent.WheelEvent where++import Web.Event.Internal.Types++newtype WheelEvent = WheelEvent Event
+ src/Web/UIEvent/WheelEvent/EventTypes.hs view
@@ -0,0 +1,6 @@+module Web.UIEvent.WheelEvent.EventTypes where++import Web.Event.Event (EventType (..))++wheel :: EventType+wheel = EventType "wheel"
+ test/Test.hs view
@@ -0,0 +1,19 @@+module Main (main) where++import Control.Exception+import Data.Foreign+import Prelude++-- import Test.Hspec++foreign import javascript unsafe "(() => { return true; })" js_true :: Foreign Bool++foreign import javascript unsafe "(() => { return false; })" js_false :: Foreign Bool++assertWith :: String -> Bool -> IO ()+assertWith msg b = if b then pure () else throwIO $ AssertionFailed msg++main :: IO ()+main = do+  assertWith "should convert true to true" $ foreignToBool js_true+  assertWith "should convert false to false" $ not $ foreignToBool js_false