├── .github └── workflows │ └── test.yml ├── .gitignore ├── LICENSE ├── README.md ├── example ├── .gitignore ├── LICENSE ├── README.md ├── dist │ └── index.html ├── package-lock.json ├── package.json ├── packages.dhall ├── postcss.config.js ├── spago.dhall ├── src │ ├── App │ │ ├── Button.purs │ │ ├── Compat.purs │ │ └── KitchenSink.purs │ ├── Main.purs │ ├── index.js │ └── style.css ├── tailwind.config.js └── webpack.config.js ├── package-lock.json ├── package.json ├── packages.dhall ├── spago.dhall ├── src └── Halogen │ ├── IHooks.js │ ├── IHooks.purs │ └── IHooks │ ├── Compat.purs │ └── Sugar.purs └── test ├── Performance ├── Main.purs ├── Setup │ ├── Measure.purs │ ├── Puppeteer.js │ └── Puppeteer.purs ├── Snapshot.purs ├── Snapshot │ ├── StateTest.js │ ├── StateTest.purs │ ├── TodoTest.js │ ├── TodoTest.purs │ └── Write.purs └── Test │ ├── App.purs │ ├── State │ ├── Component.purs │ ├── Hook.purs │ ├── README.md │ └── Shared.purs │ ├── Todo │ ├── Component.purs │ ├── Hook.purs │ ├── README.md │ └── Shared.purs │ └── Types.purs ├── test.dhall └── test.html /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Tests project 2 | on: push 3 | jobs: 4 | container-job: 5 | runs-on: ubuntu-latest 6 | strategy: 7 | matrix: 8 | node-version: [14.x] 9 | steps: 10 | - name: Check out repository code 11 | uses: actions/checkout@v2 12 | - name: Install dependencies 13 | run: npm ci 14 | - name: Spago install 15 | run: npx spago install 16 | - name: Spago build 17 | run: npx spago build 18 | - name: Build test 19 | run: npm run build:performance 20 | - name: Bundle test 21 | run: npm run bundle:performance 22 | - name: Run test 23 | run: npm run test:performance 24 | - name: Archive test results 25 | uses: actions/upload-artifact@v2 26 | with: 27 | name: test-results 28 | path: | 29 | test-results -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /test-results 12 | /test/test.js -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Mike Solomon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-halogen-ihooks 2 | 3 | A hooks library for halogen. 4 | 5 | ## Structure 6 | 7 | The library is comprised of three modules: 8 | 9 | - `Halogen.IHooks`: core hooks library. 10 | - `Halogen.IHooks.Sugar`: one-liners for stuff that I found myself writing over and over. 11 | - `Halogen.IHooks.Compat`: a "drop-in" library for [`purescript-halogen-hooks`](https://github.com/thomashoneyman/purescript-halogen-hooks). The types are different, but the syntax should be identical. 12 | 13 | ## Basic example 14 | 15 | ```purescript 16 | myComponent = Hooks.component Hooks.defaultOptions \input -> Ix.do 17 | count <- Sugar.hookConsPure (Proxy :: _ "count") 0 18 | 19 | ipure $ 20 | HH.button 21 | [ HE.onClick \_ -> Sugar.modify_ (Proxy :: _ "count") (_ + 1) ] 22 | [ HH.text $ show count ] 23 | ``` 24 | 25 | The main difference with [`purescript-halogen-hooks`](https://github.com/thomashoneyman/purescript-halogen-hooks) is that the index of the hook is a `Symbol` proxy determined by the calling code. 26 | 27 | ![Hook indices set by calling code](https://i.ibb.co/swSvkfN/hooks0.png) 28 | 29 | This allows you to inspect the type in the IDE as you're putting together the hooks. 30 | 31 | ![Hook indices inspected in the IDE](https://i.ibb.co/7YLWqvD/hooks1.png) 32 | 33 | ## Example 34 | 35 | Check out [the example](./example) code, and play with it live on [purescript-halogen-ihooks.surge.sh](https://purescript-halogen-ihooks.surge.sh/). 36 | 37 | ## Contributing 38 | 39 | Contributions are welcome! If you feel anything could be improved or needs more clarity, please don't hesitate to open an issue or make a pull request. 40 | 41 | ## Goals 42 | 43 | - Type-safety 44 | - Small core API (less than 300 lines of code) 45 | - Helpful error messages 46 | - Semantic naming of hooks via symbols 47 | - Performance 48 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /dist/bundle.js 12 | /scripts/.venv -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # purescript-halogen-ihooks example 2 | 3 | ## Howto 4 | 5 | ```bash 6 | npm install 7 | npm start 8 | ``` -------------------------------------------------------------------------------- /example/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Wags Lib Example 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /example/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-wags-lib-hello-world", 3 | "devDependencies": { 4 | "@babel/core": "^7.13.10", 5 | "@babel/preset-env": "^7.13.10", 6 | "babel-loader": "^8.2.2", 7 | "css-loader": "^5.1.3", 8 | "netlify-cli": "^6.7.5", 9 | "postcss": "^8.2.8", 10 | "postcss-loader": "^5.2.0", 11 | "postcss-preset-env": "^6.7.0", 12 | "purescript": "^0.14.3", 13 | "purs-tidy": "^0.4.6", 14 | "spago": "^0.20.3", 15 | "style-loader": "^2.0.0", 16 | "tailwind": "^4.0.0", 17 | "tailwindcss": "^2.0.4", 18 | "webpack": "^5.27.0", 19 | "webpack-cli": "^4.5.0", 20 | "webpack-dev-server": "^3.11.2" 21 | }, 22 | "scripts": { 23 | "postinstall": "spago install && spago build", 24 | "start": "webpack serve --mode=development", 25 | "build": "webpack", 26 | "clean": "rm -rf node_modules && rm -rf .spago && rm -rf output" 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /example/packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = 102 | https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20210826/packages.dhall sha256:eee0765aa98e0da8fc414768870ad588e7cada060f9f7c23c37385c169f74d9f 103 | 104 | 105 | let overrides = {=} 106 | 107 | let additions = 108 | { event = 109 | { dependencies = 110 | [ "console" 111 | , "effect" 112 | , "filterable" 113 | , "nullable" 114 | , "unsafe-reference" 115 | , "js-timers" 116 | , "now" 117 | ] 118 | , repo = "https://github.com/mikesol/purescript-event.git" 119 | , version = "v1.4.1" 120 | } 121 | } 122 | 123 | in upstream // overrides // additions 124 | -------------------------------------------------------------------------------- /example/postcss.config.js: -------------------------------------------------------------------------------- 1 | const tailwindcss = require("tailwindcss"); 2 | module.exports = { 3 | plugins: ["postcss-preset-env", tailwindcss], 4 | }; -------------------------------------------------------------------------------- /example/spago.dhall: -------------------------------------------------------------------------------- 1 | let conf = ../spago.dhall 2 | 3 | in conf 4 | // { sources = conf.sources # [ "../src/**/*.purs" ] 5 | , dependencies = 6 | conf.dependencies 7 | # [ "aff" 8 | , "console" 9 | , "event" 10 | , "halogen-storybook" 11 | , "halogen-subscriptions" 12 | , "foreign-object" 13 | ] 14 | } 15 | -------------------------------------------------------------------------------- /example/src/App/Button.purs: -------------------------------------------------------------------------------- 1 | module App.Button where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Indexed (ipure) 6 | import Control.Monad.Indexed.Qualified as Ix 7 | import Effect.Aff (Aff) 8 | import Effect.Class.Console as Log 9 | import Halogen (lift) 10 | import Halogen as H 11 | import Halogen.HTML as HH 12 | import Halogen.HTML.Events as HE 13 | import Halogen.HTML.Properties as HP 14 | import Halogen.IHooks as Hooks 15 | import Halogen.IHooks.Sugar as Sugar 16 | import Type.Proxy (Proxy(..)) 17 | 18 | aff0 :: Aff Int 19 | aff0 = pure 0 20 | 21 | affAdd1 :: Int -> Aff Int 22 | affAdd1 = pure <<< add 1 23 | 24 | classes :: forall r p. Array String -> HP.IProp (class :: String | r) p 25 | classes = HP.classes <<< map H.ClassName 26 | 27 | component :: forall q i o. H.Component q i o Aff 28 | component = 29 | Hooks.component Hooks.defaultOptions \_ -> Ix.do 30 | -- a pure hook 31 | foo <- Sugar.hookConsPure (Proxy :: _ "foo") 0 32 | -- an effectful hook 33 | bar <- Hooks.hookCons (Proxy :: _ "bar") (lift aff0) 34 | when (bar `mod` 3 == 0) (Hooks.lift (Log.info $ "Bar at " <> show bar <> " is mod 3!")) 35 | ipure 36 | ( HH.div [ classes [ "w-screen", "h-screen" ] ] 37 | [ HH.div [ classes [ "flex", "flex-col", "w-full", "h-full" ] ] 38 | [ HH.div [ classes [ "flex-grow" ] ] [] 39 | , HH.div [ classes [ "flex-grow-0", "flex", "flex-row" ] ] 40 | [ HH.div [ classes [ "flex-grow" ] ] 41 | [] 42 | , HH.div [ classes [ "flex", "flex-col" ] ] 43 | [ HH.h1 [ classes [ "text-center", "text-3xl", "font-bold" ] ] 44 | [ HH.text ("Foo is: " <> show foo <> " Bar is: " <> show bar) ] 45 | -- effectful setter 46 | , HH.button 47 | [ classes [ "text-2xl", "m-5", "bg-indigo-500", "p-3", "rounded-lg", "text-white", "hover:bg-indigo-400" ], HE.onClick \_ -> Sugar.doSetM (Proxy :: _ "foo") (lift $ affAdd1 foo) ] 48 | [ HH.text "Increment foo" ] 49 | -- pure modifier 50 | , HH.button 51 | [ classes [ "text-2xl", "m-5", "bg-pink-500", "p-3", "rounded-lg", "text-white", "hover:bg-pink-400" ], HE.onClick \_ -> Sugar.doModify_ (Proxy :: _ "bar") (add 1) ] 52 | [ HH.text "Increment bar" ] 53 | ] 54 | , HH.div [ classes [ "flex-grow" ] ] [] 55 | ] 56 | , HH.div [ classes [ "flex-grow" ] ] [] 57 | ] 58 | ] 59 | ) 60 | -------------------------------------------------------------------------------- /example/src/App/Compat.purs: -------------------------------------------------------------------------------- 1 | module App.Compat where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Data.Tuple.Nested ((/\)) 7 | import Effect.Aff (Aff) 8 | import Halogen as H 9 | import Halogen.HTML as HH 10 | import Halogen.HTML.Events as HE 11 | import Halogen.HTML.Properties as HP 12 | import Halogen.IHooks.Compat as Hooks 13 | 14 | data Query a = IsOn (Boolean -> a) 15 | 16 | classes :: forall r p. Array String -> HP.IProp (class :: String | r) p 17 | classes = HP.classes <<< map H.ClassName 18 | 19 | component :: forall i o. H.Component Query i o Aff 20 | component = Hooks.component \{ queryToken } _ -> Hooks.do 21 | count /\ countId <- Hooks.useState 0 22 | Hooks.useQuery queryToken case _ of 23 | IsOn reply -> do 24 | pure (Just (reply true)) 25 | 26 | Hooks.pure 27 | ( HH.div [ classes [ "w-screen", "h-screen" ] ] 28 | [ HH.div [ classes [ "flex", "flex-col", "w-full", "h-full" ] ] 29 | [ HH.div [ classes [ "flex-grow" ] ] [] 30 | , HH.div [ classes [ "flex-grow-0", "flex", "flex-row" ] ] 31 | [ HH.div [ classes [ "flex-grow" ] ] 32 | [] 33 | , HH.div [ classes [ "flex", "flex-col" ] ] 34 | [ HH.h1 [ classes [ "text-center", "text-3xl", "font-bold" ] ] 35 | [ HH.text (show count) ] 36 | , HH.button 37 | [ classes [ "text-2xl", "m-5", "bg-indigo-500", "p-3", "rounded-lg", "text-white", "hover:bg-indigo-400" ], HE.onClick \_ -> Hooks.modify_ countId (_ + 1)] 38 | [ HH.text "Increment foo" ] 39 | ] 40 | , HH.div [ classes [ "flex-grow" ] ] [] 41 | ] 42 | , HH.div [ classes [ "flex-grow" ] ] [] 43 | ] 44 | ] 45 | ) 46 | -------------------------------------------------------------------------------- /example/src/App/KitchenSink.purs: -------------------------------------------------------------------------------- 1 | module App.KitchenSink where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Indexed (ipure) 6 | import Control.Monad.Indexed.Qualified as Ix 7 | import Effect.Aff (Aff) 8 | import Effect.Class.Console as Log 9 | import FRP.Event (subscribe) 10 | import FRP.Event.Time (interval) 11 | import Halogen (lift, unsubscribe) 12 | import Halogen as H 13 | import Halogen.HTML as HH 14 | import Halogen.HTML.Events as HE 15 | import Halogen.HTML.Properties as HP 16 | import Halogen.IHooks as Hooks 17 | import Halogen.IHooks.Sugar as Sugar 18 | import Halogen.Subscription as HS 19 | import Type.Proxy (Proxy(..)) 20 | 21 | aff0 :: Aff Int 22 | aff0 = pure 0 23 | 24 | affAdd1 :: Int -> Aff Int 25 | affAdd1 = pure <<< add 1 26 | 27 | classes :: forall r p. Array String -> HP.IProp (class :: String | r) p 28 | classes = HP.classes <<< map H.ClassName 29 | 30 | component :: forall q i o. H.Component q i o Aff 31 | component = 32 | Sugar.componentF Hooks.defaultOptions \_ -> Ix.do 33 | -- a pure hook 34 | foo <- Sugar.hookConsPure (Proxy :: _ "foo") 0 35 | -- an effectful hook 36 | bar <- Hooks.hookCons (Proxy :: _ "bar") (lift aff0) 37 | -- captures the value of a hook, running an effect only when it changes 38 | Sugar.capture (Proxy :: _ "deltaFoo") foo (Log.info $ "Foo changed") 39 | -- adds an effect to the finalizer 40 | -- reading the "bar" hook during finalization 41 | Hooks.lift 42 | $ Sugar.addToFinalize 43 | $ Sugar.withHook (Proxy :: _ "bar") 44 | \bar' -> Log.info $ "I finalized with a bar of " <> show bar' 45 | -- garden-varienty applicative logic 46 | when (bar `mod` 3 == 0) (Hooks.lift (Log.info $ "Bar at " <> show bar <> " is mod 3!")) 47 | -- adds an emitter that increments foo even if we don't! 48 | -- should respond to both the passage of time and clicks 49 | Hooks.hookCons (Proxy :: _ "emitter") do 50 | { emitter, listener } <- H.liftEffect HS.create 51 | Sugar.addToFinalize <<< unsubscribe =<< H.subscribe emitter 52 | Sugar.addToFinalize <<< H.liftEffect =<< 53 | ( H.liftEffect 54 | $ subscribe (interval 1000) 55 | (const $ HS.notify listener (Sugar.doModify_ (Proxy :: _ "foo") (add 1))) 56 | ) 57 | -- html 58 | ipure 59 | ( HH.div [ classes [ "w-screen", "h-screen" ] ] 60 | [ HH.div [ classes [ "flex", "flex-col", "w-full", "h-full" ] ] 61 | [ HH.div [ classes [ "flex-grow" ] ] [] 62 | , HH.div [ classes [ "flex-grow-0", "flex", "flex-row" ] ] 63 | [ HH.div [ classes [ "flex-grow" ] ] 64 | [] 65 | , HH.div [ classes [ "flex", "flex-col" ] ] 66 | [ HH.h1 [ classes [ "text-center", "text-3xl", "font-bold" ] ] 67 | [ HH.text ("Foo is: " <> show foo <> " Bar is: " <> show bar) ] 68 | -- effectful setter 69 | , HH.button 70 | [ classes [ "text-2xl", "m-5", "bg-indigo-500", "p-3", "rounded-lg", "text-white", "hover:bg-indigo-400" ], HE.onClick \_ -> Sugar.doSetM (Proxy :: _ "foo") (lift $ affAdd1 foo) ] 71 | [ HH.text "Increment foo" ] 72 | -- pure modifier 73 | , HH.button 74 | [ classes [ "text-2xl", "m-5", "bg-pink-500", "p-3", "rounded-lg", "text-white", "hover:bg-pink-400" ], HE.onClick \_ -> Sugar.doModify_ (Proxy :: _ "bar") (add 1) ] 75 | [ HH.text "Increment bar" ] 76 | ] 77 | , HH.div [ classes [ "flex-grow" ] ] [] 78 | ] 79 | , HH.div [ classes [ "flex-grow" ] ] [] 80 | ] 81 | ] 82 | ) 83 | -------------------------------------------------------------------------------- /example/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import App.Button as Button 6 | import App.Compat as Compat 7 | import App.KitchenSink as KitchenSink 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Tuple (Tuple(..)) 10 | import Effect (Effect) 11 | import Effect.Aff (Aff) 12 | import Foreign.Object as Object 13 | import Halogen.Aff as HA 14 | import Halogen.HTML as HH 15 | import Halogen.Storybook (Stories, runStorybook, proxy) 16 | 17 | stories :: Stories Aff 18 | stories = Object.fromFoldable 19 | [ Tuple "" $ proxy Button.component 20 | , Tuple "button" $ proxy Button.component 21 | , Tuple "kitchen sink" $ proxy KitchenSink.component 22 | , Tuple "compat" $ proxy Compat.component 23 | ] 24 | 25 | main :: Effect Unit 26 | main = HA.runHalogenAff do 27 | HA.awaitBody >>= 28 | runStorybook 29 | { stories 30 | , logo: Just (HH.div [] [HH.text "halogen ihooks"]) 31 | } 32 | -------------------------------------------------------------------------------- /example/src/index.js: -------------------------------------------------------------------------------- 1 | import "./style.css"; 2 | var main = require("../output/Main/index.js"); 3 | main.main(); 4 | -------------------------------------------------------------------------------- /example/src/style.css: -------------------------------------------------------------------------------- 1 | @tailwind base; 2 | @tailwind components; 3 | @tailwind utilities; -------------------------------------------------------------------------------- /example/tailwind.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | purge: ["./dist/*.html"], 3 | darkMode: false, // or 'media' or 'class' 4 | theme: { 5 | extend: {}, 6 | }, 7 | variants: { 8 | extend: {}, 9 | }, 10 | plugins: [], 11 | }; -------------------------------------------------------------------------------- /example/webpack.config.js: -------------------------------------------------------------------------------- 1 | const path = require("path"); 2 | module.exports = { 3 | mode: "production", 4 | entry: "./src/index.js", 5 | output: { 6 | path: path.resolve(__dirname, "dist"), 7 | filename: "bundle.js", 8 | }, 9 | module: { 10 | rules: [ 11 | { 12 | test: /\.js$/i, 13 | include: path.resolve(__dirname, "src"), 14 | use: { 15 | loader: "babel-loader", 16 | options: { 17 | presets: ["@babel/preset-env"], 18 | }, 19 | }, 20 | }, 21 | { 22 | test: /\.css$/i, 23 | include: path.resolve(__dirname, "src"), 24 | use: ["style-loader", "css-loader", "postcss-loader"], 25 | }, 26 | ], 27 | }, 28 | devServer: { 29 | contentBase: path.resolve(__dirname, "dist"), 30 | watchContentBase: true, 31 | }, 32 | }; 33 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-halogen-ihooks", 3 | "version": "1.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "scripts": { 7 | "postinstall": "node node_modules/puppeteer/install.js", 8 | "clean": "rm -rf .spago output node_modules *.lock", 9 | "build": "spago build", 10 | "snapshot": "npm run bundle:performance && spago -x test/test.dhall run --main Performance.Snapshot.Write", 11 | "test:performance": "spago -x test/test.dhall run --main Performance.Main", 12 | "bundle:performance": "spago -x test/test.dhall bundle-app --main Performance.Test.App --to test/test.js --no-build", 13 | "build:performance": "spago -x test/test.dhall build" 14 | }, 15 | "keywords": [], 16 | "author": "", 17 | "license": "ISC", 18 | "devDependencies": { 19 | "purescript": "^0.14.4", 20 | "purs-tidy": "^0.4.6", 21 | "spago": "^0.20.3", 22 | "filter-console": "^0.1.1", 23 | "headless-devtools": "^2.0.1", 24 | "puppeteer": "^5.2.0", 25 | "tracealyzer": "^0.10.3" 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = 102 | https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20210826/packages.dhall sha256:eee0765aa98e0da8fc414768870ad588e7cada060f9f7c23c37385c169f74d9f 103 | 104 | 105 | let overrides = {=} 106 | 107 | let additions = 108 | { event = 109 | { dependencies = 110 | [ "console" 111 | , "effect" 112 | , "filterable" 113 | , "nullable" 114 | , "unsafe-reference" 115 | , "js-timers" 116 | , "now" 117 | ] 118 | , repo = "https://github.com/mikesol/purescript-event.git" 119 | , version = "v1.4.1" 120 | } 121 | } 122 | 123 | in upstream // overrides // additions 124 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | 5 | Need help? See the following resources: 6 | - Spago documentation: https://github.com/purescript/spago 7 | - Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html 8 | 9 | When creating a new Spago project, you can use 10 | `spago init --no-comments` or `spago init -C` 11 | to generate this file without the comments in this block. 12 | -} 13 | { name = "halogen-ihooks" 14 | , dependencies = 15 | [ "control" 16 | , "effect" 17 | , "foldable-traversable" 18 | , "halogen" 19 | , "indexed-monad" 20 | , "maybe" 21 | , "newtype" 22 | , "prelude" 23 | , "profunctor-lenses" 24 | , "psci-support" 25 | , "refs" 26 | , "tuples" 27 | , "unsafe-coerce" 28 | ] 29 | , packages = ./packages.dhall 30 | , sources = [ "src/**/*.purs" ] 31 | } 32 | -------------------------------------------------------------------------------- /src/Halogen/IHooks.js: -------------------------------------------------------------------------------- 1 | exports.getHookConsFFI = function(nothing) { 2 | return function(just) { 3 | return function(key) { 4 | return function(hooks) { 5 | return hooks.hasOwnProperty(key) ? just(hooks[key]) : nothing; 6 | } 7 | } 8 | } 9 | } 10 | 11 | 12 | exports.setHookUnionFFI = function(toSet) { 13 | return function(hooks) { 14 | var o = Object.assign(Object.assign({}, hooks), toSet); 15 | return o; 16 | } 17 | } 18 | 19 | exports.setHookConsFFI = function(key) { 20 | return function(val) { 21 | return function(hooks) { 22 | var o = Object.assign({}, hooks); 23 | o[key] = val; 24 | return o; 25 | } 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /src/Halogen/IHooks.purs: -------------------------------------------------------------------------------- 1 | module Halogen.IHooks 2 | ( IndexedHookM 3 | , hookCons 4 | , component 5 | , getHooksM 6 | , lift 7 | , HookAction 8 | , HookState 9 | , HookM 10 | , HookArg 11 | , doThis 12 | , asHooks 13 | , setHookMCons 14 | , setHookMUnion 15 | , getHookCons 16 | , setHookCons 17 | , setHookUnion 18 | , Hooks 19 | , defaultOptions 20 | , Options 21 | , ReadOnly(..) 22 | , class NotReadOnly 23 | , class NotReadOnlyRL 24 | , HookHTML 25 | ) where 26 | 27 | import Prelude 28 | 29 | import Control.Applicative.Indexed (class IxApplicative, iapply, ipure) 30 | import Control.Apply (applySecond) 31 | import Control.Apply.Indexed (class IxApply) 32 | import Control.Bind.Indexed (class IxBind, ibind) 33 | import Control.Monad.Indexed (class IxMonad, iap) 34 | import Data.Foldable (for_) 35 | import Data.Functor.Indexed (class IxFunctor) 36 | import Data.Lens (over, set) 37 | import Data.Lens.Record (prop) 38 | import Data.Maybe (Maybe(..), maybe) 39 | import Data.Newtype (class Newtype) 40 | import Data.Symbol (class IsSymbol, reflectSymbol) 41 | import Halogen as H 42 | import Halogen.HTML as HH 43 | import Halogen.HTML.Core as HC 44 | import Prim.Row (class Cons, class Lacks, class Union) 45 | import Prim.RowList as RL 46 | import Prim.TypeError (class Fail, Text) 47 | import Type.Proxy (Proxy(..)) 48 | import Unsafe.Coerce (unsafeCoerce) 49 | 50 | type HookState hooks input slots output m = 51 | { hooks :: Hooks hooks 52 | , input :: input 53 | , html :: HookHTML hooks input slots output m 54 | } 55 | 56 | type HookM hooks input slots output m a 57 | = H.HalogenM 58 | (HookState hooks input slots output m) 59 | (HookAction hooks input slots output m) 60 | slots 61 | output 62 | m 63 | a 64 | 65 | p_ :: { hooks :: Proxy "hooks", input :: Proxy "input", html :: Proxy "html" } 66 | p_ = { hooks: Proxy, input: Proxy, html: Proxy } 67 | 68 | newtype ReadOnly a 69 | = ReadOnly a 70 | 71 | derive instance newtypeReadOnly :: Newtype (ReadOnly a) _ 72 | 73 | derive instance functorReadOnly :: Functor ReadOnly 74 | 75 | data Hooks (r :: Row Type) 76 | 77 | foreign import getHookConsFFI :: forall a r. Maybe a -> (a -> Maybe a) -> String -> Hooks r -> Maybe a 78 | 79 | getHookCons 80 | :: forall proxy sym a r1 hooks 81 | . IsSymbol sym 82 | => Cons sym a r1 hooks 83 | => proxy sym 84 | -> Hooks hooks 85 | -> Maybe a 86 | getHookCons = getHookConsFFI Nothing Just <<< reflectSymbol 87 | 88 | foreign import setHookConsFFI :: forall a r. String -> a -> Hooks r -> Hooks r 89 | 90 | setHookCons 91 | :: forall proxy sym a r1 hooks 92 | . IsSymbol sym 93 | => Cons sym a r1 hooks 94 | => proxy sym 95 | -> a 96 | -> Hooks hooks 97 | -> Hooks hooks 98 | setHookCons = setHookConsFFI <<< reflectSymbol 99 | 100 | data SetHookUnion 101 | 102 | foreign import setHookUnionFFI :: forall r. SetHookUnion -> Hooks r -> Hooks r 103 | 104 | setHookUnion 105 | :: forall r1 r2 hooks 106 | . Union r1 r2 hooks 107 | => { | r1 } 108 | -> Hooks hooks 109 | -> Hooks hooks 110 | setHookUnion = setHookUnionFFI <<< unsafeCoerce 111 | 112 | setHookMCons 113 | :: forall proxy output input slots m sym a r1 hooks 114 | . NotReadOnly a 115 | => Cons sym a r1 hooks 116 | => IsSymbol sym 117 | => proxy sym 118 | -> a 119 | -> HookM hooks input slots output m Unit 120 | setHookMCons px = H.modify_ <<< over (prop p_.hooks) <<< setHookCons px 121 | 122 | class NotReadOnlyRL (rl :: RL.RowList Type) 123 | 124 | instance notReadOnlyRLNil :: NotReadOnlyRL RL.Nil 125 | 126 | instance notReadOnlyRLCons :: (NotReadOnly b, NotReadOnlyRL c) => NotReadOnlyRL (RL.Cons a b c) 127 | 128 | setHookMUnion 129 | :: forall output input slots m r1 rl r2 hooks 130 | . RL.RowToList r1 rl 131 | => NotReadOnlyRL rl 132 | => Union r1 r2 hooks 133 | => { | r1 } 134 | -> HookM hooks input slots output m Unit 135 | setHookMUnion = H.modify_ <<< over (prop p_.hooks) <<< setHookUnion 136 | 137 | asHooks :: forall r. { | r } -> Hooks r 138 | asHooks = unsafeCoerce 139 | 140 | getHooksM 141 | :: forall hooks input slots output m 142 | . HookM hooks input slots output m (Hooks hooks) 143 | getHooksM = H.gets _.hooks 144 | 145 | class NotReadOnly (a :: Type) 146 | 147 | instance readOnlyFail :: Fail (Text "This value is read only") => NotReadOnly (ReadOnly a) 148 | else instance readOnlySucceed :: NotReadOnly a 149 | 150 | type HookHTML hooks input slots output m 151 | = HC.HTML (H.ComponentSlot slots m (HookAction hooks input slots output m)) (HookAction hooks input slots output m) 152 | 153 | type HookArg hooks input slots output m 154 | = 155 | input 156 | -> IndexedHookM hooks input slots output m () hooks (HookHTML hooks input slots output m) 157 | 158 | doThis 159 | :: forall hooks input slots output m 160 | . HookM hooks input slots output m Unit 161 | -> HookAction hooks input slots output m 162 | doThis = DoThis 163 | 164 | handleHookAction 165 | :: forall hooks input slots output m rest 166 | . { finalize :: HookM hooks input slots output m Unit 167 | | rest 168 | } 169 | -> HookArg hooks input slots output m 170 | -> HookAction hooks input slots output m 171 | -> H.HalogenM 172 | (HookState hooks input slots output m) 173 | (HookAction hooks input slots output m) 174 | slots 175 | output 176 | m 177 | Unit 178 | handleHookAction { finalize } f = case _ of 179 | DoThis m -> m *> render Nothing 180 | Initialize -> render Nothing 181 | Receive i -> i <$> H.gets _.input >>= flip for_ (render <<< Just) 182 | Finalize -> finalize 183 | where 184 | render = maybe H.get (H.modify <<< set (prop p_.input)) 185 | >=> unIx <<< f <<< _.input 186 | >=> H.modify_ <<< set (prop p_.html) 187 | 188 | type Options query hooks input slots output m 189 | = 190 | { receiveInput :: input -> input -> Maybe input 191 | , handleQuery :: forall a. query a -> HookM hooks input slots output m (Maybe a) 192 | , finalize :: HookM hooks input slots output m Unit 193 | , initialHTML :: HookHTML hooks input slots output m 194 | } 195 | 196 | defaultOptions 197 | :: forall query hooks input slots output m 198 | . Options query hooks input slots output m 199 | defaultOptions = 200 | { receiveInput: const Just 201 | , handleQuery: const (pure Nothing) 202 | , finalize: pure unit 203 | , initialHTML: HH.div [] [] 204 | } 205 | 206 | component 207 | :: forall slots hooks query input output m 208 | . Options query hooks input slots output m 209 | -> HookArg hooks input slots output m 210 | -> H.Component query input output m 211 | component options f = 212 | H.mkComponent 213 | { initialState: { input: _, hooks: unsafeCoerce {}, html: options.initialHTML } 214 | , render: _.html 215 | , eval: 216 | H.mkEval 217 | { initialize: Just Initialize 218 | , finalize: Just Finalize 219 | , receive: Just <<< Receive <<< options.receiveInput 220 | , handleAction: handleHookAction options f 221 | , handleQuery: options.handleQuery 222 | } 223 | } 224 | 225 | newtype IndexedHookM (hooks :: Row Type) (input :: Type) (slots :: Row Type) (output :: Type) (m :: Type -> Type) (i :: Row Type) (o :: Row Type) a 226 | = IndexedHookM (HookM hooks input slots output m a) 227 | 228 | unIx :: forall hooks input slots output m i o a. IndexedHookM hooks input slots output m i o a -> HookM hooks input slots output m a 229 | unIx (IndexedHookM m) = m 230 | 231 | derive instance indexedHookMFunctor :: Functor (IndexedHookM hooks input slots output m i i) 232 | 233 | derive newtype instance indexedHookMSemigroup :: Semigroup a => Semigroup (IndexedHookM hooks input slots output m i i a) 234 | derive newtype instance indexedHookMMonoid :: Monoid a => Monoid (IndexedHookM hooks input slots output m i i a) 235 | 236 | instance indexedHookMApply :: Apply (IndexedHookM hooks input slots output m i i) where 237 | apply = iapply 238 | 239 | instance indexedHookMBind :: Bind (IndexedHookM hooks input slots output m i i) where 240 | bind = ibind 241 | 242 | instance indexedHookMApplicative :: Applicative (IndexedHookM hooks input slots output m i i) where 243 | pure = ipure 244 | 245 | instance indexedHookMMonad :: Monad (IndexedHookM hooks input slots output m i i) 246 | 247 | instance indexedHookMIxFunctor :: IxFunctor (IndexedHookM hooks input slots output m) where 248 | imap f = IndexedHookM <<< map f <<< unIx 249 | 250 | instance indexedHookMIxApply :: IxApply (IndexedHookM hooks input slots output m) where 251 | iapply = iap 252 | 253 | instance indexedHookMIxApplicative :: IxApplicative (IndexedHookM hooks input slots output m) where 254 | ipure = IndexedHookM <<< pure 255 | 256 | instance indexedHookMIxBind :: IxBind (IndexedHookM hooks input slots output m) where 257 | ibind (IndexedHookM fmonad) = IndexedHookM <<< bind fmonad <<< compose unIx 258 | 259 | instance indexedHookMIxMonad :: IxMonad (IndexedHookM hooks input slots output m) 260 | 261 | data HookAction hooks input slots output m 262 | = Initialize 263 | | DoThis (HookM hooks input slots output m Unit) 264 | | Receive (input -> Maybe input) 265 | | Finalize 266 | 267 | lift 268 | :: forall hooks input slots output m v i 269 | . HookM hooks input slots output m v 270 | -> IndexedHookM hooks input slots output m i i v 271 | lift = IndexedHookM 272 | 273 | hookCons 274 | :: forall hooks' hooks input slots output proxy sym m v i o 275 | . IsSymbol sym 276 | => Lacks sym i 277 | => Cons sym v i o 278 | => Lacks sym hooks' 279 | => Cons sym v hooks' hooks 280 | => proxy sym 281 | -> HookM hooks input slots output m v 282 | -> IndexedHookM hooks input slots output m i o v 283 | hookCons px m = IndexedHookM (map (getHookCons px) getHooksM >>= maybe (m >>= (applySecond <$> setHookMCons px <*> pure)) pure) 284 | -------------------------------------------------------------------------------- /src/Halogen/IHooks/Compat.purs: -------------------------------------------------------------------------------- 1 | module Halogen.IHooks.Compat 2 | ( useState 3 | , useQuery 4 | , useTickEffect 5 | , useLifecycleEffect 6 | , useMemo 7 | , useRef 8 | , component 9 | , capture 10 | , modify_ 11 | , QueryToken 12 | , SlotsToken 13 | , OutputToken 14 | , Q 15 | , F 16 | , class GetLexicalLast 17 | , pure 18 | , bind 19 | , discard 20 | ) where 21 | 22 | import Prelude 23 | 24 | import Halogen.IHooks as Hooks 25 | import Halogen.IHooks.Sugar as Sugar 26 | import Control.Applicative.Indexed (class IxApplicative, ipure, (:*>)) 27 | import Control.Bind.Indexed (class IxBind, class IxDiscard, ibind, idiscard, imap) 28 | import Control.Monad.Indexed.Qualified as Ix 29 | import Data.Maybe (Maybe(..), fromMaybe) 30 | import Data.Symbol (class IsSymbol) 31 | import Data.Traversable (fold, sequence) 32 | import Data.Tuple.Nested (type (/\), (/\)) 33 | import Effect.Class (class MonadEffect) 34 | import Effect.Ref as Ref 35 | import Halogen as H 36 | import Prelude as Applicative 37 | import Prelude as Bind 38 | import Prim.Row as Row 39 | import Prim.RowList as RL 40 | import Prim.Symbol as Symbol 41 | import Type.Proxy (Proxy(..)) 42 | 43 | data QueryToken (query :: Type -> Type) 44 | = QueryToken 45 | 46 | data SlotsToken (slots :: Row Type) 47 | = SlotsToken 48 | 49 | data OutputToken (output :: Type) 50 | = OutputToken 51 | 52 | type ComponentTokens :: (Type -> Type) -> Row Type -> Type -> Type 53 | type ComponentTokens q s o 54 | = 55 | { queryToken :: QueryToken q 56 | , slotsToken :: SlotsToken s 57 | , outputToken :: OutputToken o 58 | } 59 | 60 | newtype Q query hooks' input slots output m 61 | = Q 62 | ( forall a 63 | . query a 64 | -> Hooks.HookM 65 | ( "" :: Q query hooks' input slots output m 66 | , "_" :: F query hooks' input slots output m 67 | | hooks' 68 | ) 69 | input 70 | slots 71 | output 72 | m 73 | (Maybe a) 74 | ) 75 | 76 | unQ 77 | :: forall query hooks' input slots output m 78 | . Q query hooks' input slots output m 79 | -> ( forall a 80 | . query a 81 | -> Hooks.HookM 82 | ( "" :: Q query hooks' input slots output m 83 | , "_" :: F query hooks' input slots output m 84 | | hooks' 85 | ) 86 | input 87 | slots 88 | output 89 | m 90 | (Maybe a) 91 | ) 92 | unQ (Q q) = q 93 | 94 | newtype F query hooks' input slots output m 95 | = F 96 | ( Array 97 | ( Hooks.HookM 98 | ( "" :: Q query hooks' input slots output m 99 | , "_" :: F query hooks' input slots output m 100 | | hooks' 101 | ) 102 | input 103 | slots 104 | output 105 | m 106 | Unit 107 | ) 108 | ) 109 | 110 | unF 111 | :: forall query hooks' input slots output m 112 | . F query hooks' input slots output m 113 | -> Array 114 | ( Hooks.HookM 115 | ( "" :: Q query hooks' input slots output m 116 | , "_" :: F query hooks' input slots output m 117 | | hooks' 118 | ) 119 | input 120 | slots 121 | output 122 | m 123 | Unit 124 | ) 125 | unF (F q) = q 126 | 127 | class GetLexicalLast (default :: Symbol) (i :: RL.RowList Type) (s :: Symbol) | default i -> s 128 | 129 | instance getLexicalLastNil :: GetLexicalLast sym RL.Nil sym 130 | 131 | instance getLexicalLastCons :: GetLexicalLast sym rest o => GetLexicalLast prev (RL.Cons sym val rest) o 132 | 133 | useRef 134 | :: forall i iRL o t267 hooks input slots output sym' sym m v 135 | . IsSymbol sym 136 | => RL.RowToList i iRL 137 | => GetLexicalLast "" iRL sym' 138 | => Symbol.Append sym' "_" sym 139 | => Row.Lacks sym i 140 | => Row.Cons sym (Ref.Ref v) i o 141 | => Row.Lacks sym t267 142 | => Row.Cons sym (Ref.Ref v) t267 hooks 143 | => MonadEffect m 144 | => v 145 | -> Hooks.IndexedHookM hooks input slots output m i o (v /\ (Ref.Ref v)) 146 | useRef v = Ix.do 147 | ref <- Hooks.hookCons (Proxy :: _ sym) (H.liftEffect (Ref.new v)) 148 | val <- Hooks.lift (H.liftEffect (Ref.read ref)) 149 | ipure (val /\ ref) 150 | 151 | component 152 | :: forall (query :: Type -> Type) (hooks' :: Row Type) (input :: Type) (slots :: Row Type) (output :: Type) (m :: Type -> Type) 153 | . Row.Lacks "" hooks' 154 | => Row.Lacks "_" hooks' 155 | => ( ComponentTokens query slots output 156 | -> input 157 | -> Hooks.IndexedHookM 158 | ( "" :: Q query hooks' input slots output m 159 | , "_" :: F query hooks' input slots output m 160 | | hooks' 161 | ) 162 | input 163 | slots 164 | output 165 | m 166 | ( "" :: Q query hooks' input slots output m 167 | , "_" :: F query hooks' input slots output m 168 | ) 169 | ( "" :: Q query hooks' input slots output m 170 | , "_" :: F query hooks' input slots output m 171 | | hooks' 172 | ) 173 | ( Hooks.HookHTML 174 | ( "" :: Q query hooks' input slots output m 175 | , "_" :: F query hooks' input slots output m 176 | | hooks' 177 | ) 178 | input 179 | slots 180 | output 181 | m 182 | ) 183 | ) 184 | -> H.Component query input output m 185 | component f = 186 | Hooks.component 187 | ( Hooks.defaultOptions 188 | { handleQuery = 189 | \q -> 190 | Hooks.getHooksM 191 | >>= \hooks -> case Hooks.getHookCons (Proxy :: _ "") hooks of 192 | Nothing -> Applicative.pure Nothing 193 | Just fun -> (unQ fun) q 194 | , finalize = 195 | Hooks.getHooksM 196 | >>= \hooks -> case Hooks.getHookCons (Proxy :: _ "_") hooks of 197 | Nothing -> Applicative.pure unit 198 | Just arr -> fold <$> sequence (unF arr) 199 | } 200 | ) 201 | go 202 | where 203 | start = 204 | Hooks.hookCons (Proxy :: _ "") 205 | (Applicative.pure (Q (const $ Applicative.pure Nothing))) 206 | :*> Hooks.hookCons (Proxy :: _ "_") 207 | (Applicative.pure (F [])) 208 | 209 | go = 210 | ( \i -> Ix.do 211 | _ <- start 212 | f 213 | { queryToken: QueryToken 214 | , slotsToken: SlotsToken 215 | , outputToken: OutputToken 216 | } 217 | i 218 | ) 219 | 220 | useLifecycleEffect 221 | :: forall i o hooks'' input slots output m query hooks' iRL sym' sym 222 | . IsSymbol sym 223 | => RL.RowToList i iRL 224 | => GetLexicalLast "" iRL sym' 225 | => Symbol.Append sym' "_" sym 226 | => Row.Lacks sym i 227 | => Row.Cons sym Unit i o 228 | => Row.Lacks sym hooks'' 229 | => Row.Cons 230 | sym 231 | Unit 232 | hooks'' 233 | ( "" :: Q query hooks' input slots output m 234 | , "_" :: F query hooks' input slots output m 235 | | hooks' 236 | ) 237 | => Hooks.HookM 238 | ( "" :: Q query hooks' input slots output m 239 | , "_" :: F query hooks' input slots output m 240 | | hooks' 241 | ) 242 | input 243 | slots 244 | output 245 | m 246 | ( Maybe 247 | ( Hooks.HookM 248 | ( "" :: Q query hooks' input slots output m 249 | , "_" :: F query hooks' input slots output m 250 | | hooks' 251 | ) 252 | input 253 | slots 254 | output 255 | m 256 | Unit 257 | ) 258 | ) 259 | -> Hooks.IndexedHookM 260 | ( "" :: Q query hooks' input slots output m 261 | , "_" :: F query hooks' input slots output m 262 | | hooks' 263 | ) 264 | input 265 | slots 266 | output 267 | m 268 | i 269 | o 270 | Unit 271 | useLifecycleEffect m = Hooks.hookCons (Proxy :: _ sym) (Applicative.pure unit) :*> useTickEffect m 272 | 273 | useTickEffect 274 | :: forall query hooks' input slots output m i 275 | . Hooks.HookM 276 | ( "" :: Q query hooks' input slots output m 277 | , "_" :: F query hooks' input slots output m 278 | | hooks' 279 | ) 280 | input 281 | slots 282 | output 283 | m 284 | ( Maybe 285 | ( Hooks.HookM 286 | ( "" :: Q query hooks' input slots output m 287 | , "_" :: F query hooks' input slots output m 288 | | hooks' 289 | ) 290 | input 291 | slots 292 | output 293 | m 294 | Unit 295 | ) 296 | ) 297 | -> Hooks.IndexedHookM 298 | ( "" :: Q query hooks' input slots output m 299 | , "_" :: F query hooks' input slots output m 300 | | hooks' 301 | ) 302 | input 303 | slots 304 | output 305 | m 306 | i 307 | i 308 | Unit 309 | useTickEffect i = 310 | Hooks.lift 311 | ( Bind.bind i \iRes -> 312 | Bind.bind 313 | ( map 314 | ( fromMaybe (F []) 315 | <<< Hooks.getHookCons (Proxy :: _ "_") 316 | ) 317 | Hooks.getHooksM 318 | ) 319 | \(F arr) -> 320 | void 321 | $ Hooks.setHookMCons (Proxy :: _ "_") 322 | $ F 323 | $ case iRes of 324 | Nothing -> arr 325 | Just iRes' -> [ iRes' ] <> arr 326 | ) 327 | 328 | useMemo 329 | :: forall query hooks' input slots output m i a 330 | . (Unit -> a) 331 | -> Hooks.IndexedHookM 332 | ( "" :: Q query hooks' input slots output m 333 | , "_" :: F query hooks' input slots output m 334 | | hooks' 335 | ) 336 | input 337 | slots 338 | output 339 | m 340 | i 341 | i 342 | a 343 | useMemo fun = 344 | Hooks.lift 345 | ( Bind.bind (Applicative.pure unit) \ut -> 346 | Applicative.pure (fun ut) 347 | ) 348 | 349 | useQuery 350 | :: forall query hooks' input slots output m i 351 | . QueryToken query 352 | -> ( forall a 353 | . query a 354 | -> Hooks.HookM 355 | ( "" :: Q query hooks' input slots output m 356 | , "_" :: F query hooks' input slots output m 357 | | hooks' 358 | ) 359 | input 360 | slots 361 | output 362 | m 363 | (Maybe a) 364 | ) 365 | -> Hooks.IndexedHookM 366 | ( "" :: Q query hooks' input slots output m 367 | , "_" :: F query hooks' input slots output m 368 | | hooks' 369 | ) 370 | input 371 | slots 372 | output 373 | m 374 | i 375 | i 376 | Unit 377 | useQuery _ fun = Hooks.lift (Hooks.setHookMCons (Proxy :: _ "") (Q fun)) 378 | 379 | useState 380 | :: forall hooks' hooks input slots output sym sym' m v i iRL o 381 | . RL.RowToList i iRL 382 | => GetLexicalLast "" iRL sym' 383 | => Symbol.Append sym' "_" sym 384 | => IsSymbol sym 385 | => Row.Lacks sym i 386 | => Row.Cons sym v i o 387 | => Row.Lacks sym hooks' 388 | => Row.Cons sym v hooks' hooks 389 | => v 390 | -> Hooks.IndexedHookM hooks input slots output m i o (v /\ Proxy sym) 391 | useState = imap (flip (/\) (Proxy :: _ sym)) <<< Hooks.hookCons (Proxy :: _ sym) <<< Applicative.pure 392 | 393 | pure :: ∀ m a x. IxApplicative m ⇒ a → m x x a 394 | pure = ipure 395 | 396 | bind :: ∀ a b m x y z. IxBind m ⇒ m x y a → (a → m y z b) → m x z b 397 | bind = ibind 398 | 399 | discard ∷ ∀ a k f b (x :: k) (y :: k) (z :: k). IxDiscard a ⇒ IxBind f ⇒ f x y a → (a → f y z b) → f x z b 400 | discard = idiscard 401 | 402 | modify_ 403 | :: forall proxy output input slots m sym a r1 hooks 404 | . Hooks.NotReadOnly a 405 | => Row.Cons sym a r1 hooks 406 | => IsSymbol sym 407 | => proxy sym 408 | -> (a -> a) 409 | -> Hooks.HookAction hooks input slots output m 410 | modify_ = Sugar.doModify_ 411 | 412 | capture 413 | :: forall iRL sym' hooks' hooks input slots output m sym v i o 414 | . RL.RowToList i iRL 415 | => GetLexicalLast "" iRL sym' 416 | => Symbol.Append sym' "_" sym 417 | => IsSymbol sym 418 | => Row.Lacks sym i 419 | => Row.Cons sym v i o 420 | => Row.Lacks sym hooks' 421 | => Row.Cons sym v hooks' hooks 422 | => Eq v 423 | => v 424 | -> Hooks.HookM hooks input slots output m Unit 425 | -> Hooks.IndexedHookM hooks input slots output m i o Unit 426 | capture = Sugar.capture (Proxy :: _ sym) 427 | -------------------------------------------------------------------------------- /src/Halogen/IHooks/Sugar.purs: -------------------------------------------------------------------------------- 1 | module Halogen.IHooks.Sugar where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Indexed (iapplySecond, ivoid, iwhen) 6 | import Control.Apply (applySecond) 7 | import Control.Bind.Indexed (ibind) 8 | import Control.Plus (empty) 9 | import Data.Foldable (fold, for_) 10 | import Data.Symbol (class IsSymbol) 11 | import Halogen as H 12 | import Halogen.IHooks (class NotReadOnly, HookAction, HookHTML, HookM, IndexedHookM, Options, HookArg, component, doThis, getHookCons, getHooksM, hookCons, lift, setHookMCons) 13 | import Prim.Row as Row 14 | import Type.Proxy (Proxy(..)) 15 | 16 | newtype F hooks' input slots output m 17 | = F 18 | ( HookM 19 | ( "_finalize" :: F hooks' input slots output m 20 | | hooks' 21 | ) 22 | input 23 | slots 24 | output 25 | m 26 | Unit 27 | ) 28 | 29 | unF 30 | :: forall hooks' input slots output m 31 | . F hooks' input slots output m 32 | -> HookM 33 | ( "_finalize" :: F hooks' input slots output m 34 | | hooks' 35 | ) 36 | input 37 | slots 38 | output 39 | m 40 | Unit 41 | 42 | unF (F q) = q 43 | 44 | finalize :: Proxy "_finalize" 45 | finalize = Proxy 46 | 47 | withFinalize 48 | :: forall hooks' input slots output m i 49 | . Row.Lacks "_finalize" i 50 | => Row.Lacks "_finalize" hooks' 51 | => IndexedHookM ("_finalize" :: F hooks' input slots output m | hooks') input slots output m i ("_finalize" :: F hooks' input slots output m | i) Unit 52 | withFinalize = ivoid $ hookCons (Proxy :: _ "_finalize") (pure $ F $ pure unit) 53 | 54 | addToFinalize 55 | :: forall hooks' input slots output m 56 | . Row.Lacks "_finalize" hooks' 57 | => HookM ("_finalize" :: F hooks' input slots output m | hooks') input slots output m Unit 58 | -> HookM ("_finalize" :: F hooks' input slots output m | hooks') input slots output m Unit 59 | addToFinalize m = bind (map (getHookCons finalize) getHooksM) (setHookMCons finalize <<< F <<< applySecond m <<< fold <<< map unF) 60 | 61 | runFinalize 62 | :: forall hooks' input slots output m 63 | . Row.Lacks "_finalize" hooks' 64 | => HookM ("_finalize" :: F hooks' input slots output m | hooks') input slots output m Unit 65 | runFinalize = bind (map (getHookCons finalize) getHooksM) (fold <<< map unF) 66 | 67 | capture 68 | :: forall proxy hooks' hooks input slots output m sym v i o 69 | . IsSymbol sym 70 | => Row.Lacks sym i 71 | => Row.Cons sym v i o 72 | => Row.Lacks sym hooks' 73 | => Row.Cons sym v hooks' hooks 74 | => Eq v 75 | => proxy sym 76 | -> v 77 | -> HookM hooks input slots output m Unit 78 | -> IndexedHookM hooks input slots output m i o Unit 79 | capture px v m = ibind (hookCons px (pure v)) (flip iwhen (lift (setHookMCons px v *> m)) <<< notEq v) 80 | 81 | hookConsPure 82 | :: forall hooks' hooks input slots output proxy sym m v i o 83 | . IsSymbol sym 84 | => Row.Lacks sym i 85 | => Row.Cons sym v i o 86 | => Row.Lacks sym hooks' 87 | => Row.Cons sym v hooks' hooks 88 | => proxy sym 89 | -> v 90 | -> IndexedHookM hooks input slots output m i o v 91 | hookConsPure px = hookCons px <<< pure 92 | 93 | setM 94 | :: forall proxy output input slots m sym a r1 hooks 95 | . NotReadOnly a 96 | => Row.Cons sym a r1 hooks 97 | => IsSymbol sym 98 | => proxy sym 99 | -> HookM hooks input slots output m a 100 | -> HookM hooks input slots output m Unit 101 | setM px v = bind v (setHookMCons px) 102 | 103 | set 104 | :: forall proxy output input slots m sym a r1 hooks 105 | . NotReadOnly a 106 | => Row.Cons sym a r1 hooks 107 | => IsSymbol sym 108 | => proxy sym 109 | -> a 110 | -> HookM hooks input slots output m Unit 111 | set px = setM px <<< pure 112 | 113 | modify_ 114 | :: forall proxy output input slots m sym a r1 hooks 115 | . NotReadOnly a 116 | => Row.Cons sym a r1 hooks 117 | => IsSymbol sym 118 | => proxy sym 119 | -> (a -> a) 120 | -> HookM hooks input slots output m Unit 121 | modify_ px f = bind (map (getHookCons px) getHooksM) (flip for_ (setHookMCons px <<< f)) 122 | 123 | doSetM 124 | :: forall proxy output input slots m sym a r1 hooks 125 | . NotReadOnly a 126 | => Row.Cons sym a r1 hooks 127 | => IsSymbol sym 128 | => proxy sym 129 | -> HookM hooks input slots output m a 130 | -> HookAction hooks input slots output m 131 | doSetM px v = doThis $ setM px v 132 | 133 | doSet 134 | :: forall proxy output input slots m sym a r1 hooks 135 | . NotReadOnly a 136 | => Row.Cons sym a r1 hooks 137 | => IsSymbol sym 138 | => proxy sym 139 | -> a 140 | -> HookAction hooks input slots output m 141 | doSet px v = doThis $ set px v 142 | 143 | doModify_ 144 | :: forall proxy output input slots m sym a r1 hooks 145 | . NotReadOnly a 146 | => Row.Cons sym a r1 hooks 147 | => IsSymbol sym 148 | => proxy sym 149 | -> (a -> a) 150 | -> HookAction hooks input slots output m 151 | doModify_ px v = doThis $ modify_ px v 152 | 153 | withHook 154 | :: forall proxy hooks' hooks input slots output m sym v 155 | . IsSymbol sym 156 | => Row.Lacks sym hooks' 157 | => Row.Cons sym v hooks' hooks 158 | => proxy sym 159 | -> (v -> HookM hooks input slots output m Unit) 160 | -> HookM hooks input slots output m Unit 161 | withHook px = bind (map (getHookCons px) getHooksM) <<< flip for_ 162 | 163 | -- | A component with a finalizer bolted on 164 | -- | The same as manually calling `withFinalizer` and `runFinalizer` 165 | componentF 166 | :: forall slots hooks' query output m input 167 | . Row.Lacks "_finalize" hooks' 168 | => Options query ("_finalize" :: F hooks' input slots output m | hooks') input slots output m 169 | -> ( input 170 | -> IndexedHookM ("_finalize" :: F hooks' input slots output m | hooks') input slots output m ("_finalize" :: F hooks' input slots output m) ("_finalize" :: F hooks' input slots output m | hooks') (HookHTML ("_finalize" :: F hooks' input slots output m | hooks') input slots output m) 171 | ) 172 | -> H.Component query input output m 173 | componentF options f = component (options { finalize = options.finalize *> runFinalize }) (iapplySecond (withFinalize) <<< f) 174 | 175 | withConstInput 176 | :: forall slots hooks query input output m 177 | . Options query hooks input slots output m 178 | -> HookArg hooks input slots output m 179 | -> H.Component query input output m 180 | withConstInput options = component (options { receiveInput = const $ const empty }) 181 | -------------------------------------------------------------------------------- /test/Performance/Main.purs: -------------------------------------------------------------------------------- 1 | module Performance.Main where 2 | 3 | import Prelude hiding (compare) 4 | 5 | import Data.Argonaut.Core (stringifyWithIndent) 6 | import Data.Argonaut.Encode (encodeJson) 7 | import Data.Maybe (Maybe(..)) 8 | import Effect (Effect) 9 | import Effect.Aff (Milliseconds(..), launchAff_) 10 | import Effect.Class (liftEffect) 11 | import Effect.Class.Console as Console 12 | import Effect.Exception (catchException) 13 | import Node.Encoding (Encoding(..)) 14 | import Node.FS.Sync (mkdir, writeTextFile) 15 | import Performance.Setup.Measure (ComparisonSummary, TestType(..), compare, testTypeToString, withBrowser) 16 | import Performance.Setup.Puppeteer as Puppeteer 17 | import Performance.Snapshot (percentChange, snapshots) 18 | import Test.Spec (Spec, around, describe, it) 19 | import Test.Spec.Reporter (consoleReporter) 20 | import Test.Spec.Runner (defaultConfig, runSpec') 21 | 22 | main :: Effect Unit 23 | main = launchAff_ do 24 | runSpec' (defaultConfig { timeout = Just (Milliseconds 30_000.0) }) [ consoleReporter ] do 25 | describe "Peformance" spec 26 | 27 | -- These tests have wide acceptance ranges because of the variability of banchmarks 28 | -- via Puppeteer in general. But they do have some light boundaries and should 29 | -- be manually reviewed in any pull request which touches library internals. 30 | spec :: Spec Unit 31 | spec = around withBrowser do 32 | it "Should satisfy state benchmark" \browser -> do 33 | -- We can safely disregard 'Failed to parse CPU profile' log messages. This 34 | -- disables those logs from this point onwards in the program execution (all 35 | -- following benchmarks). 36 | liftEffect do 37 | Puppeteer.filterConsole 38 | catchException mempty (mkdir "test-results") 39 | 40 | let test = StateTest 41 | result <- compare browser 3 test 42 | liftEffect do 43 | writeResult test result 44 | Console.log "Wrote state test results to test-results (including snapshot change)." 45 | 46 | it "Should satisfy todo benchmark" \browser -> do 47 | let test = TodoTest 48 | result <- compare browser 3 test 49 | liftEffect do 50 | writeResult test result 51 | Console.log "Wrote todo test results to test-results (including snapshot change)." 52 | 53 | writeResult :: TestType -> ComparisonSummary -> Effect Unit 54 | writeResult test { componentAverage, hookAverage, componentResults, hookResults } = do 55 | writePath "summary" $ encodeJson 56 | { componentAverage, hookAverage } 57 | 58 | writePath "results" $ encodeJson 59 | { componentResults, hookResults } 60 | 61 | writePath "change" $ encodeJson $ case test of 62 | StateTest -> 63 | { componentChange: 64 | percentChange snapshots.state.componentAverage componentAverage 65 | , hookChange: 66 | percentChange snapshots.state.hookAverage hookAverage 67 | } 68 | TodoTest -> 69 | { componentChange: 70 | percentChange snapshots.todo.componentAverage componentAverage 71 | , hookChange: 72 | percentChange snapshots.todo.hookAverage hookAverage 73 | } 74 | where 75 | writePath label = 76 | stringifyWithIndent 2 >>> writeTextFile UTF8 (mkPath label) 77 | 78 | mkPath label = 79 | "test-results/" <> testTypeToString test <> "-" <> label <> ".json" 80 | -------------------------------------------------------------------------------- /test/Performance/Setup/Measure.purs: -------------------------------------------------------------------------------- 1 | module Performance.Setup.Measure where 2 | 3 | import Prelude hiding (compare) 4 | 5 | import Control.Monad.Rec.Class (forever) 6 | import Data.Array (fold, replicate) 7 | import Data.Array as Array 8 | import Data.Foldable (foldl, for_, maximum, sum) 9 | import Data.Maybe (fromJust, fromMaybe) 10 | import Data.Traversable (for) 11 | import Effect.Aff (Aff, bracket, delay, error, forkAff, killFiber, throwError) 12 | import Effect.Aff as Aff 13 | import Effect.Aff.AVar as AVar 14 | import Effect.Class (liftEffect) 15 | import Node.Path (resolve) 16 | import Partial.Unsafe (unsafePartial) 17 | import Performance.Setup.Puppeteer (Browser, FilePath(..), Kilobytes(..), Milliseconds(..), Page) 18 | import Performance.Setup.Puppeteer as Puppeteer 19 | import Performance.Test.Todo.Shared (addNewId, checkId, editId, saveId) 20 | import Performance.Test.Types (Test(..), completedSuffix, startSuffix, testToString) 21 | 22 | type PerformanceSummary = 23 | { averageFPS :: Int 24 | , peakHeap :: Kilobytes 25 | , averageHeap :: Kilobytes 26 | , scriptTime :: Milliseconds 27 | , totalTime :: Milliseconds 28 | } 29 | 30 | type ComparisonSummary = 31 | { hookResults :: Array PerformanceSummary 32 | , hookAverage :: PerformanceSummary 33 | , componentResults :: Array PerformanceSummary 34 | , componentAverage :: PerformanceSummary 35 | } 36 | 37 | -- | Bracket test runs by supplying a new browser to each one 38 | withBrowser :: (Browser -> Aff Unit) -> Aff Unit 39 | withBrowser = bracket (Puppeteer.launch { headless: true }) Puppeteer.closeBrowser 40 | 41 | data TestType = StateTest | TodoTest 42 | 43 | testTypeToString :: TestType -> String 44 | testTypeToString = case _ of 45 | StateTest -> "state-test" 46 | TodoTest -> "todo-test" 47 | 48 | compare :: Browser -> Int -> TestType -> Aff ComparisonSummary 49 | compare browser n testType = do 50 | let runs = replicate n (compareOnce browser testType) 51 | results <- for runs (delay (Aff.Milliseconds 100.0) *> _) 52 | 53 | let 54 | hookResults = map _.hook results 55 | componentResults = map _.component results 56 | hookAverage = average hookResults 57 | componentAverage = average componentResults 58 | 59 | pure { hookResults, hookAverage, componentResults, componentAverage } 60 | 61 | compareOnce 62 | :: Browser 63 | -> TestType 64 | -> Aff { hook :: PerformanceSummary, component :: PerformanceSummary } 65 | compareOnce browser = case _ of 66 | StateTest -> do 67 | hook <- measure browser StateHook 68 | component <- measure browser StateComponent 69 | pure { hook, component } 70 | 71 | TodoTest -> do 72 | hook <- measure browser TodoHook 73 | component <- measure browser TodoComponent 74 | pure { hook, component } 75 | 76 | measure :: Browser -> Test -> Aff PerformanceSummary 77 | measure browser test = do 78 | page <- Puppeteer.newPage browser 79 | 80 | path <- liftEffect $ resolve [] "test/test.html" 81 | Puppeteer.goto page ("file://" <> path) 82 | 83 | -- Prepare by selecting the test to mount 84 | let selector = prependHash (testToString test) 85 | mbTestElem <- Puppeteer.waitForSelector page selector 86 | 87 | -- Prepare for the test by collecting garbage (for more accurate heap usage 88 | -- metrics) and starting metrics collection 89 | let tracePath = FilePath $ fold [ "test-results/", testToString test, "-trace.json" ] 90 | 91 | -- Initialize data for capturing heap measurements 92 | var <- AVar.new { captures: [], count: 0 } 93 | 94 | -- Collect garbage in preparation for heap measurements 95 | Puppeteer.enableHeapProfiler page 96 | Puppeteer.collectGarbage page 97 | 98 | -- Start recording the performance trace, depositing the resulting trace file 99 | -- to `tracePath` so it can be manually analyzed 100 | Puppeteer.startTrace page tracePath 101 | 102 | -- Collect initial timestamp and heap usage 103 | initialPageMetrics <- Puppeteer.pageMetrics page 104 | 105 | -- Start collecting heap measurements every 10 milliseconds 106 | -- 107 | -- TODO: It may be better to ditch the dependencies and just use this strategy 108 | -- with `requestAnimationFrame` to measure the FPS as well. 109 | heapFiber <- forkAff $ forever do 110 | { heapUsed } <- Puppeteer.pageMetrics page 111 | { captures, count } <- AVar.take var 112 | AVar.put { captures: Array.snoc captures heapUsed, count: count + 1 } var 113 | delay $ Aff.Milliseconds 10.0 114 | 115 | -- Run the test to completion 116 | for_ mbTestElem Puppeteer.click 117 | runScriptForTest page test 118 | 119 | -- Retrieve heap captures 120 | { captures, count } <- AVar.take var 121 | 122 | -- Collect final timestamp and heap usage 123 | finalPageMetrics <- Puppeteer.pageMetrics page 124 | 125 | -- Stop recording the trace and write it to disk 126 | trace <- Puppeteer.stopTrace page 127 | killFiber (error "time's up!") heapFiber 128 | Puppeteer.closePage page 129 | 130 | -- Use the trace to get the average FPS during the execution 131 | mbModel <- Puppeteer.getPerformanceModel trace 132 | let averageFPS = Puppeteer.getAverageFPS $ unsafePartial $ fromJust mbModel 133 | 134 | -- Use the trace to retrieve time spent executing scripts (JS execution) 135 | scriptTime <- liftEffect (Puppeteer.readScriptingTime tracePath) 136 | 137 | -- Use the initial and final metrics to record the total time spent recording 138 | -- the trace 139 | let totalTime = finalPageMetrics.timestamp - initialPageMetrics.timestamp 140 | 141 | -- Use the heap usage captures to record the average heap usage during 142 | -- execution, minus the heap that existed when the trace began. 143 | let 144 | peakHeap = fromMaybe (Kilobytes 0) $ map (_ - initialPageMetrics.heapUsed) $ maximum captures 145 | averageHeap = (sum captures / Kilobytes count) - initialPageMetrics.heapUsed 146 | 147 | pure { averageFPS, averageHeap, peakHeap, scriptTime, totalTime } 148 | 149 | -- TODO: Replace query selectors 150 | -- 151 | -- Currently tests use query selectors to start tests and understand when a test 152 | -- has completed. But it would be better to expose an interface via the window 153 | -- object that can be used to query the Halogen application and run tests. This 154 | -- would allow tests to: 155 | -- 156 | -- 1. Query the application and await the result; when the result is received 157 | -- then the test is complete and the timer can stop. 158 | -- 159 | -- 2. Alternately, query the application and subscribe to output messages which 160 | -- will record when a test has completed. 161 | -- 162 | -- The Halogen application can register functions onto the window object at app 163 | -- startup (in the `main` function). The `Puppeteer.evaluate` function enables 164 | -- calling functions within Puppeteer, and the `Puppeteer.exposeFunction` function 165 | -- enables a function which evaluates within Puppeteer to be called from outside. 166 | -- 167 | -- Until then, though, we'll just rely on query selectors. 168 | runScriptForTest :: Page -> Test -> Aff Unit 169 | runScriptForTest page test = let selector = prependHash (testToString test) in case test of 170 | _ | test == StateHook || test == StateComponent -> do 171 | n <- Puppeteer.waitForSelector page (selector <> startSuffix) 172 | for_ n Puppeteer.click 173 | void $ Puppeteer.waitForSelector page (selector <> completedSuffix) 174 | 175 | | test == TodoHook || test == TodoComponent -> do 176 | addNew <- Puppeteer.waitForSelector page (prependHash addNewId) 177 | for_ addNew Puppeteer.click 178 | 179 | check0 <- Puppeteer.waitForSelector page (prependHash $ checkId 0) 180 | for_ check0 Puppeteer.click 181 | check1 <- Puppeteer.waitForSelector page (prependHash $ checkId 1) 182 | for_ check1 Puppeteer.click 183 | 184 | Puppeteer.focus page (prependHash $ editId 5) 185 | Puppeteer.typeWithKeyboard page "is so fun" 186 | save5 <- Puppeteer.waitForSelector page (prependHash $ saveId 5) 187 | for_ save5 Puppeteer.click 188 | 189 | for_ check0 Puppeteer.click 190 | for_ check1 Puppeteer.click 191 | 192 | _ -> 193 | throwError $ error "Impossible!!!" 194 | 195 | prependHash :: String -> String 196 | prependHash str = "#" <> str 197 | 198 | average :: Array PerformanceSummary -> PerformanceSummary 199 | average summaries = do 200 | let 201 | summary = foldl (+) zero summaries 202 | total = Array.length summaries 203 | 204 | { averageFPS: summary.averageFPS / total 205 | , averageHeap: summary.averageHeap / Kilobytes total 206 | , peakHeap: summary.peakHeap / Kilobytes total 207 | , scriptTime: summary.scriptTime / Milliseconds total 208 | , totalTime: summary.totalTime / Milliseconds total 209 | } 210 | -------------------------------------------------------------------------------- /test/Performance/Setup/Puppeteer.js: -------------------------------------------------------------------------------- 1 | const puppeteer = require("puppeteer"); 2 | const filterConsole = require("filter-console"); 3 | const tracealyzer = require("tracealyzer"); 4 | const { getPerformanceModel } = require("headless-devtools"); 5 | 6 | exports.filterConsole = function () { 7 | filterConsole(["Failed to parse CPU profile."]); 8 | }; 9 | 10 | exports.launchImpl = function (args) { 11 | return function() { 12 | return puppeteer.launch(args); 13 | } 14 | }; 15 | 16 | exports.newPageImpl = function (browser) { 17 | return browser.newPage(); 18 | }; 19 | 20 | exports.debugImpl = function (page) { 21 | page.on("console", (msg) => console.log("PAGE LOG:", msg.text())); 22 | page.on("pageerror", (err) => console.log("ERROR LOG:", err.message)); 23 | }; 24 | 25 | exports.clickImpl = function (elem) { 26 | return elem.click(); 27 | }; 28 | 29 | exports.waitForSelectorImpl = function (page, selector) { 30 | return page.waitForSelector(selector); 31 | }; 32 | 33 | exports.focusImpl = function (page, selector) { 34 | return page.focus(selector); 35 | }; 36 | 37 | exports.typeWithKeybordImpl = function (page, string) { 38 | return page.keyboard.type(string); 39 | }; 40 | 41 | exports.gotoImpl = function (page, path) { 42 | return page.goto(path); 43 | }; 44 | 45 | exports.closePageImpl = function (page) { 46 | return page.close(); 47 | }; 48 | 49 | exports.closeBrowserImpl = function (browser) { 50 | return browser.close(); 51 | }; 52 | 53 | exports.enableHeapProfilerImpl = function (page) { 54 | return page._client.send("HeapProfiler.enable"); 55 | }; 56 | 57 | exports.collectGarbageImpl = function (page) { 58 | return page._client.send("HeapProfiler.collectGarbage"); 59 | }; 60 | 61 | exports.startTraceImpl = function (page, path) { 62 | return page.tracing.start({ path }); 63 | }; 64 | 65 | exports.stopTraceImpl = function (page) { 66 | return page.tracing.stop(); 67 | }; 68 | 69 | // Should be used on the trace produced by `page.tracing.stop()` 70 | exports.getPerformanceModelImpl = function (trace) { 71 | try { 72 | const traceJSON = JSON.parse(trace.toString()); 73 | return getPerformanceModel(traceJSON); 74 | } catch (e) { 75 | return null; 76 | } 77 | }; 78 | 79 | // Should be used on the model returned by `getPeformanceModel` 80 | exports.getAverageFPS = function (model) { 81 | const frames = model.frames(); 82 | const durations = frames.map((x) => x.duration); 83 | const avg = durations.reduce((acc, item) => acc + item, 0) / durations.length; 84 | return Math.round(1000 / avg); 85 | }; 86 | 87 | exports.pageMetricsImpl = function (page) { 88 | return page.metrics(); 89 | }; 90 | 91 | exports.tracealyzer = function (filename) { 92 | return function () { 93 | return tracealyzer(filename); 94 | }; 95 | }; 96 | -------------------------------------------------------------------------------- /test/Performance/Setup/Puppeteer.purs: -------------------------------------------------------------------------------- 1 | module Performance.Setup.Puppeteer 2 | ( filterConsole 3 | , Browser 4 | , launch 5 | , Page 6 | , newPage 7 | , debug 8 | , click 9 | , waitForSelector 10 | , focus 11 | , typeWithKeyboard 12 | , goto 13 | , closePage 14 | , closeBrowser 15 | , enableHeapProfiler 16 | , collectGarbage 17 | , FilePath(..) 18 | , startTrace 19 | , Trace 20 | , stopTrace 21 | , PerformanceModel 22 | , getPerformanceModel 23 | , getAverageFPS 24 | , Kilobytes(..) 25 | , Milliseconds(..) 26 | , PageMetrics 27 | , pageMetrics 28 | , readScriptingTime 29 | ) where 30 | 31 | import Prelude 32 | 33 | import Control.Promise (Promise, toAffE) 34 | import Data.Argonaut.Core (Json) 35 | import Data.Argonaut.Decode (class DecodeJson, decodeJson, printJsonDecodeError, (.:), (.:?)) 36 | import Data.Argonaut.Encode (class EncodeJson, encodeJson) 37 | import Data.Either (Either(..)) 38 | import Data.Int (round) 39 | import Data.Int as Int 40 | import Data.Maybe (Maybe, fromJust, fromMaybe) 41 | import Data.Newtype (class Newtype) 42 | import Data.Nullable (Nullable, toMaybe) 43 | import Data.String.CodeUnits as String 44 | import Effect (Effect) 45 | import Effect.Aff (Aff) 46 | import Effect.Class (liftEffect) 47 | import Effect.Exception (throw) 48 | import Effect.Uncurried (EffectFn1, EffectFn2, runEffectFn1, runEffectFn2) 49 | import Node.Path as Path 50 | import Partial.Unsafe (unsafePartial) 51 | import Web.HTML (HTMLElement) 52 | 53 | -- | Turn off noisy messages from the Puppeteer tests 54 | foreign import filterConsole :: Effect Unit 55 | 56 | -- | An instance of a Puppeteer browser, which should be created at 57 | -- | the start of any Puppeteer session and closed at the end. 58 | foreign import data Browser :: Type 59 | 60 | -- | The headless :: Boolean argument specifies whether or not to run the browser in headless mode. 61 | -- | To debug/test visually, set headless to false 62 | type LaunchArgs = 63 | { headless :: Boolean 64 | } 65 | 66 | foreign import launchImpl :: LaunchArgs -> Effect (Promise Browser) 67 | 68 | launch :: LaunchArgs -> Aff Browser 69 | launch config = toAffE (launchImpl config) 70 | 71 | -- | An instance of a Puppeteer page, which is necessary to run page-level 72 | -- | functions like collecting metrics and starting and stopping traces. 73 | foreign import data Page :: Type 74 | 75 | foreign import newPageImpl :: EffectFn1 Browser (Promise Page) 76 | 77 | -- | Create a running instance of a `Page` 78 | newPage :: Browser -> Aff Page 79 | newPage = toAffE1 newPageImpl 80 | 81 | foreign import debugImpl :: EffectFn1 Page Unit 82 | 83 | -- | Enable logs from the Puppeteer instance 84 | debug :: Page -> Aff Unit 85 | debug = liftEffect <<< runEffectFn1 debugImpl 86 | 87 | foreign import clickImpl :: EffectFn1 HTMLElement (Promise Unit) 88 | 89 | click :: HTMLElement -> Aff Unit 90 | click = toAffE1 clickImpl 91 | 92 | foreign import waitForSelectorImpl :: EffectFn2 Page String (Promise (Nullable HTMLElement)) 93 | 94 | waitForSelector :: Page -> String -> Aff (Maybe HTMLElement) 95 | waitForSelector page selector = map toMaybe (toAffE2 waitForSelectorImpl page selector) 96 | 97 | foreign import focusImpl :: EffectFn2 Page String (Promise Unit) 98 | 99 | focus :: Page -> String -> Aff Unit 100 | focus = toAffE2 focusImpl 101 | 102 | foreign import typeWithKeybordImpl :: EffectFn2 Page String (Promise Unit) 103 | 104 | typeWithKeyboard :: Page -> String -> Aff Unit 105 | typeWithKeyboard = toAffE2 typeWithKeybordImpl 106 | 107 | foreign import gotoImpl :: EffectFn2 Page Path.FilePath (Promise Unit) 108 | 109 | goto :: Page -> Path.FilePath -> Aff Unit 110 | goto = toAffE2 gotoImpl 111 | 112 | foreign import closePageImpl :: EffectFn1 Page (Promise Unit) 113 | 114 | -- | Terminate the running Puppeteer page 115 | closePage :: Page -> Aff Unit 116 | closePage = toAffE1 closePageImpl 117 | 118 | foreign import closeBrowserImpl :: EffectFn1 Browser (Promise Unit) 119 | 120 | -- | Terminate the running Puppeteer browser, ending the session 121 | closeBrowser :: Browser -> Aff Unit 122 | closeBrowser = toAffE1 closeBrowserImpl 123 | 124 | foreign import enableHeapProfilerImpl :: EffectFn1 Page (Promise Unit) 125 | 126 | -- | Turn on the heap profiler, enabling JS heap measurements and manual garbage 127 | -- | collection for more reliable benchmarking 128 | enableHeapProfiler :: Page -> Aff Unit 129 | enableHeapProfiler = toAffE1 enableHeapProfilerImpl 130 | 131 | foreign import collectGarbageImpl :: EffectFn1 Page (Promise Unit) 132 | 133 | -- | Manually trigger garbage collection, which can be used to ensure more 134 | -- | accurate heap usage 135 | collectGarbage :: Page -> Aff Unit 136 | collectGarbage = toAffE1 collectGarbageImpl 137 | 138 | newtype FilePath = FilePath String 139 | derive instance newtypeFilePath :: Newtype FilePath _ 140 | 141 | foreign import startTraceImpl :: EffectFn2 Page FilePath (Promise Unit) 142 | 143 | -- | Begin measuring a performance trace. Use `stopTrace` to complete the 144 | -- | measurement and write it to the specified file path. This trace can then 145 | -- | be loaded up in the Chrome Dev Tools. 146 | startTrace :: Page -> FilePath -> Aff Unit 147 | startTrace = toAffE2 startTraceImpl 148 | 149 | -- | The opaque blob returned by a performance trace, which can be analyzed to 150 | -- | retrieve performance measurements like FPS. 151 | foreign import data Trace :: Type 152 | 153 | foreign import stopTraceImpl :: EffectFn1 Page (Promise Trace) 154 | 155 | -- | Begin measuring a performance trace. Use `stopTrace` to complete the 156 | -- | measurement. 157 | stopTrace :: Page -> Aff Trace 158 | stopTrace = toAffE1 stopTraceImpl 159 | 160 | -- | The opaque blob returned by the `getPerformanceModel` function, which can 161 | -- | be used to retrieve the average frames per second over the measured duration 162 | foreign import data PerformanceModel :: Type 163 | 164 | foreign import getPerformanceModelImpl :: EffectFn1 Trace (Promise (Nullable PerformanceModel)) 165 | 166 | getPerformanceModel :: Trace -> Aff (Maybe PerformanceModel) 167 | getPerformanceModel = map toMaybe <<< toAffE1 getPerformanceModelImpl 168 | 169 | -- | Retrieve the average frames per second over the course of the performance trace 170 | foreign import getAverageFPS :: PerformanceModel -> Int 171 | 172 | type JSPageMetrics = 173 | { "JSHeapUsedSize" :: Number -- megabytes 174 | , "Timestamp" :: Number -- microseconds 175 | } 176 | 177 | foreign import pageMetricsImpl :: EffectFn1 Page (Promise JSPageMetrics) 178 | 179 | newtype Kilobytes = Kilobytes Int 180 | 181 | derive instance newtypeKilobytes :: Newtype Kilobytes _ 182 | derive newtype instance eqKilobytes :: Eq Kilobytes 183 | derive newtype instance ordKilobytes :: Ord Kilobytes 184 | derive newtype instance semiringKilobytes :: Semiring Kilobytes 185 | derive newtype instance ringKilobytes :: Ring Kilobytes 186 | derive newtype instance commutativeRingKilobytes :: CommutativeRing Kilobytes 187 | derive newtype instance euclidianRingKilobytes :: EuclideanRing Kilobytes 188 | 189 | instance encodeJsonKilobytes :: EncodeJson Kilobytes where 190 | encodeJson = encodeJson <<< show 191 | 192 | instance decodeJsonKilobytes :: DecodeJson Kilobytes where 193 | decodeJson json = decodeJson json >>= \str -> do 194 | pure (Kilobytes (unsafePartial (fromJust (Int.fromString (String.dropRight 2 str))))) 195 | 196 | instance showKilobytes :: Show Kilobytes where 197 | show (Kilobytes kb) = show kb <> "kb" 198 | 199 | newtype Milliseconds = Milliseconds Int 200 | 201 | derive instance newtypeMilliseconds :: Newtype Milliseconds _ 202 | derive newtype instance eqMilliseconds :: Eq Milliseconds 203 | derive newtype instance ordMilliseconds :: Ord Milliseconds 204 | derive newtype instance semiringMilliseconds :: Semiring Milliseconds 205 | derive newtype instance ringMilliseconds :: Ring Milliseconds 206 | derive newtype instance commutativeRingMilliseconds :: CommutativeRing Milliseconds 207 | derive newtype instance euclidianRingMilliseconds :: EuclideanRing Milliseconds 208 | 209 | instance encodeJsonMilliseconds :: EncodeJson Milliseconds where 210 | encodeJson = encodeJson <<< show 211 | 212 | instance showMilliseconds :: Show Milliseconds where 213 | show (Milliseconds ms) = show ms <> "ms" 214 | 215 | instance decodeJsonMilliseconds :: DecodeJson Milliseconds where 216 | decodeJson json = decodeJson json >>= \str -> do 217 | pure (Milliseconds (unsafePartial (fromJust (Int.fromString (String.dropRight 2 str))))) 218 | 219 | -- | A snapshot of current page data 220 | type PageMetrics = 221 | { heapUsed :: Kilobytes 222 | , timestamp :: Milliseconds 223 | } 224 | 225 | -- | Retrieve a snapshot of the current page metrics, which can be used to see 226 | -- | current heap usage and execution times 227 | pageMetrics :: Page -> Aff PageMetrics 228 | pageMetrics = toAffE1 pageMetricsImpl >>> map \{ "JSHeapUsedSize": heap, "Timestamp": ts } -> 229 | { heapUsed: Kilobytes (round (heap / 1000.0)) 230 | , timestamp: Milliseconds (round (ts * 1000.0)) 231 | } 232 | 233 | -- | Retrieve the time spent in scripting during the execution 234 | readScriptingTime :: FilePath -> Effect Milliseconds 235 | readScriptingTime fp = do 236 | json <- tracealyzer fp 237 | 238 | let 239 | decoded = do 240 | obj <- decodeJson json 241 | (_ .:? "scripting") =<< (_ .: "categories") =<< obj .: "profiling" 242 | 243 | case decoded of 244 | Left err -> throw $ printJsonDecodeError err 245 | Right val -> pure $ Milliseconds $ round $ fromMaybe 0.0 val 246 | 247 | foreign import tracealyzer :: FilePath -> Effect Json 248 | 249 | toAffE1 :: forall a b. EffectFn1 a (Promise b) -> a -> Aff b 250 | toAffE1 fn = toAffE <<< runEffectFn1 fn 251 | 252 | toAffE2 :: forall a b c. EffectFn2 a b (Promise c) -> a -> b -> Aff c 253 | toAffE2 fn a b = toAffE (runEffectFn2 fn a b) 254 | -------------------------------------------------------------------------------- /test/Performance/Snapshot.purs: -------------------------------------------------------------------------------- 1 | module Performance.Snapshot where 2 | 3 | import Prelude 4 | 5 | import Data.Argonaut.Core (Json) 6 | import Data.Argonaut.Decode (JsonDecodeError, decodeJson) 7 | import Data.Either (Either, fromRight') 8 | import Data.Int (toNumber) 9 | import Data.Int as Int 10 | import Data.Newtype (unwrap) 11 | import Effect.Exception.Unsafe (unsafeThrow) 12 | import Performance.Setup.Measure (PerformanceSummary) 13 | import Performance.Snapshot.StateTest as StateTest 14 | import Performance.Snapshot.TodoTest as TodoTest 15 | 16 | -- A subset of the `ComparisonSummary` type in `Performance.Setup.Measure` 17 | type Snapshot = 18 | { componentAverage :: PerformanceSummary 19 | , hookAverage :: PerformanceSummary 20 | } 21 | 22 | decodeSnapshot :: Json -> Either JsonDecodeError Snapshot 23 | decodeSnapshot = decodeJson 24 | 25 | snapshots :: { state :: Snapshot, todo :: Snapshot } 26 | snapshots = fromRight' (\_ -> unsafeThrow "expected Right") do 27 | state <- decodeJson StateTest.result 28 | todo <- decodeJson TodoTest.result 29 | pure { state, todo } 30 | 31 | type Percent = String 32 | 33 | formatPercent :: Int -> String 34 | formatPercent percent = show percent <> "%" 35 | 36 | percentChange 37 | :: PerformanceSummary 38 | -> PerformanceSummary 39 | -> { averageFPS :: Percent 40 | , averageHeap :: Percent 41 | , peakHeap :: Percent 42 | , scriptTime :: Percent 43 | } 44 | percentChange value1 value2 = do 45 | let 46 | change new old = do 47 | let 48 | newN = toNumber new 49 | oldN = toNumber old 50 | formatPercent $ Int.round (((newN - oldN) / oldN) * 100.0) 51 | { averageFPS: 52 | change value1.averageFPS value2.averageFPS 53 | , averageHeap: 54 | change (unwrap value1.averageHeap) (unwrap value2.averageHeap) 55 | , peakHeap: 56 | change (unwrap value1.peakHeap) (unwrap value2.peakHeap) 57 | , scriptTime: 58 | change (unwrap value1.scriptTime) (unwrap value2.scriptTime) 59 | } 60 | -------------------------------------------------------------------------------- /test/Performance/Snapshot/StateTest.js: -------------------------------------------------------------------------------- 1 | exports.result = { 2 | "hookAverage": { 3 | "totalTime": "143ms", 4 | "scriptTime": "102ms", 5 | "peakHeap": "1894kb", 6 | "averageHeap": "746kb", 7 | "averageFPS": 18 8 | }, 9 | "componentAverage": { 10 | "totalTime": "101ms", 11 | "scriptTime": "52ms", 12 | "peakHeap": "993kb", 13 | "averageHeap": "429kb", 14 | "averageFPS": 36 15 | } 16 | } -------------------------------------------------------------------------------- /test/Performance/Snapshot/StateTest.purs: -------------------------------------------------------------------------------- 1 | {- AUTOMATICALLY GENERATED, DO NOT EDIT -} 2 | 3 | module Performance.Snapshot.StateTest where 4 | 5 | import Data.Argonaut.Core (Json) 6 | 7 | foreign import result :: Json 8 | -------------------------------------------------------------------------------- /test/Performance/Snapshot/TodoTest.js: -------------------------------------------------------------------------------- 1 | exports.result = { 2 | "hookAverage": { 3 | "totalTime": "478ms", 4 | "scriptTime": "333ms", 5 | "peakHeap": "13948kb", 6 | "averageHeap": "6594kb", 7 | "averageFPS": 20 8 | }, 9 | "componentAverage": { 10 | "totalTime": "358ms", 11 | "scriptTime": "200ms", 12 | "peakHeap": "7045kb", 13 | "averageHeap": "3490kb", 14 | "averageFPS": 26 15 | } 16 | } -------------------------------------------------------------------------------- /test/Performance/Snapshot/TodoTest.purs: -------------------------------------------------------------------------------- 1 | {- AUTOMATICALLY GENERATED, DO NOT EDIT -} 2 | 3 | module Performance.Snapshot.TodoTest where 4 | 5 | import Data.Argonaut.Core (Json) 6 | 7 | foreign import result :: Json 8 | -------------------------------------------------------------------------------- /test/Performance/Snapshot/Write.purs: -------------------------------------------------------------------------------- 1 | module Performance.Snapshot.Write where 2 | 3 | import Prelude hiding (compare) 4 | 5 | import Data.Argonaut.Core (stringifyWithIndent) 6 | import Data.Argonaut.Encode (encodeJson) 7 | import Data.Foldable (fold) 8 | import Effect (Effect) 9 | import Effect.Aff (bracket, launchAff_) 10 | import Effect.Class (liftEffect) 11 | import Effect.Class.Console as Console 12 | import Effect.Exception (catchException) 13 | import Node.Encoding (Encoding(..)) 14 | import Node.FS.Sync (mkdir, writeTextFile) 15 | import Performance.Setup.Measure (TestType(..), compare) 16 | import Performance.Setup.Puppeteer as Puppeteer 17 | import Performance.Snapshot (Snapshot) 18 | 19 | main :: Effect Unit 20 | main = launchAff_ do 21 | bracket (Puppeteer.launch { headless: true }) Puppeteer.closeBrowser \browser -> do 22 | liftEffect do 23 | Puppeteer.filterConsole 24 | catchException mempty (mkdir "test-results") 25 | 26 | Console.log "Running state tests..." 27 | state <- compare browser 6 StateTest 28 | liftEffect do 29 | writeSnapshot StateTest 30 | { componentAverage: state.componentAverage 31 | , hookAverage: state.hookAverage 32 | } 33 | 34 | Console.log "Running todo tests..." 35 | todo <- compare browser 6 TodoTest 36 | liftEffect do 37 | writeSnapshot TodoTest 38 | { componentAverage: todo.componentAverage 39 | , hookAverage: todo.hookAverage 40 | } 41 | 42 | Console.log "Done with snapshots!" 43 | where 44 | writeSnapshot :: TestType -> Snapshot -> Effect Unit 45 | writeSnapshot test snapshot = do 46 | writeTextFile UTF8 snapshotPath.js (snapshotTemplate snapshot) 47 | writeTextFile UTF8 snapshotPath.purs snapshotPursTemplate 48 | 49 | where 50 | moduleName = testTypeToModule test 51 | 52 | snapshotPath = do 53 | let path = "test/Performance/Snapshot/" <> moduleName 54 | { purs: path <> ".purs", js: path <> ".js" } 55 | 56 | snapshotPursTemplate = 57 | fold 58 | [ "{- AUTOMATICALLY GENERATED, DO NOT EDIT -}\n" 59 | , "\n" 60 | , "module Performance.Snapshot." <> moduleName <> " where\n" 61 | , "\n" 62 | , "import Data.Argonaut.Core (Json)\n" 63 | , "\n" 64 | , "foreign import result :: Json\n" 65 | ] 66 | 67 | snapshotTemplate results = 68 | "exports.result = " <> stringifyWithIndent 2 (encodeJson results) 69 | 70 | testTypeToModule :: TestType -> String 71 | testTypeToModule = case _ of 72 | StateTest -> "StateTest" 73 | TodoTest -> "TodoTest" 74 | -------------------------------------------------------------------------------- /test/Performance/Test/App.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.App where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Aff (launchAff_) 7 | import Effect.Aff.Class (class MonadAff) 8 | import Halogen as H 9 | import Halogen.Aff.Util as HA 10 | import Halogen.HTML as HH 11 | import Halogen.HTML.Events as HE 12 | import Halogen.HTML.Properties as HP 13 | import Halogen.VDom.Driver (runUI) 14 | import Performance.Test.State.Component as State.Component 15 | import Performance.Test.State.Hook as State.Hook 16 | import Performance.Test.Types (Test(..), completedSuffix, testToString) 17 | import Performance.Test.Todo.Component as Todo.Component 18 | import Performance.Test.Todo.Hook as Todo.Hook 19 | 20 | main :: Effect Unit 21 | main = launchAff_ do 22 | body <- HA.awaitBody 23 | runUI container unit body 24 | 25 | data TestState 26 | = NotStarted 27 | | Running Test 28 | | Completed Test 29 | 30 | derive instance eqTestState :: Eq TestState 31 | 32 | data Action = HandleStartTest Test | HandleTestComplete Test 33 | 34 | container :: forall q i o m. MonadAff m => H.Component q i o m 35 | container = H.mkComponent 36 | { initialState: \_ -> NotStarted 37 | , render 38 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } 39 | } 40 | where 41 | -- Used by Puppeteer to mount a test into the page so that it can be started 42 | testAction test = do 43 | let test' = testToString test 44 | HH.button [ HP.id test', HE.onClick \_ -> HandleStartTest test ] [ HH.text test' ] 45 | 46 | handleComplete test = 47 | const (HandleTestComplete test) 48 | 49 | render state = do 50 | HH.div_ 51 | [ HH.div_ 52 | [ -- Used by Puppeteer to trigger a test to be mounted into the page 53 | testAction StateHook 54 | , testAction StateComponent 55 | , testAction TodoHook 56 | , testAction TodoComponent 57 | 58 | , case state of 59 | NotStarted -> 60 | HH.text "" 61 | 62 | Running StateHook -> 63 | HH.slot State.Hook._stateHook unit State.Hook.component unit (handleComplete StateHook) 64 | 65 | Running StateComponent -> 66 | HH.slot State.Component._stateComponent unit State.Component.component unit (handleComplete StateComponent) 67 | 68 | Running TodoHook -> 69 | HH.slot Todo.Hook._todoHook unit Todo.Hook.container unit (handleComplete TodoHook) 70 | 71 | Running TodoComponent -> 72 | HH.slot Todo.Component._todoComponent unit Todo.Component.container unit (handleComplete TodoComponent) 73 | 74 | Completed test -> 75 | HH.div [ HP.id (testToString test <> completedSuffix) ] [ ] 76 | ] 77 | ] 78 | 79 | handleAction = case _ of 80 | HandleStartTest test -> 81 | H.put (Running test) 82 | 83 | HandleTestComplete test -> 84 | H.put (Completed test) 85 | -------------------------------------------------------------------------------- /test/Performance/Test/State/Component.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.State.Component where 2 | 3 | import Prelude 4 | 5 | import Data.Array.NonEmpty (replicate) 6 | import Data.Foldable (sequence_) 7 | 8 | import Halogen as H 9 | import Halogen.HTML as HH 10 | import Halogen.HTML.Events as HE 11 | import Halogen.HTML.Properties as HP 12 | import Performance.Test.State.Shared (Output(..), stateUpdates) 13 | import Performance.Test.Types (Test(..), startSuffix, testToString) 14 | import Type.Proxy (Proxy(..)) 15 | 16 | _stateComponent = Proxy :: Proxy "stateComponent" 17 | 18 | data Action = RunState 19 | 20 | component :: forall q i m. H.Component q i Output m 21 | component = 22 | H.mkComponent 23 | { initialState: \_ -> { n: 0, n1: 0, n2: 0, n3: 0, n4: 0 } 24 | , render 25 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } 26 | } 27 | where 28 | render state = 29 | HH.div_ 30 | [ HH.button 31 | [ HP.id (testToString StateComponent <> startSuffix) 32 | , HE.onClick \_ -> RunState 33 | ] 34 | [ HH.text "Start Test" ] 35 | , HH.text $ show state 36 | ] 37 | 38 | handleAction RunState = do 39 | sequence_ $ replicate stateUpdates $ H.modify_ \s -> s { n = s.n + 1 } 40 | sequence_ $ replicate stateUpdates $ H.modify_ \s -> s { n1 = s.n1 + 1 } 41 | sequence_ $ replicate stateUpdates $ H.modify_ \s -> s { n2 = s.n2 + 1 } 42 | sequence_ $ replicate stateUpdates $ H.modify_ \s -> s { n3 = s.n3 + 1 } 43 | sequence_ $ replicate stateUpdates $ H.modify_ \s -> s { n4 = s.n4 + 1 } 44 | H.raise Done 45 | -------------------------------------------------------------------------------- /test/Performance/Test/State/Hook.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.State.Hook where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Indexed (ipure) 6 | import Control.Monad.Indexed.Qualified as Ix 7 | import Data.Array (replicate) 8 | import Data.Foldable (sequence_) 9 | import Data.Tuple.Nested ((/\)) 10 | import Effect.Aff.Class (class MonadAff) 11 | import Halogen as H 12 | import Halogen.HTML as HH 13 | import Halogen.HTML.Events as HE 14 | import Halogen.HTML.Properties as HP 15 | import Halogen.IHooks (doThis) 16 | import Halogen.IHooks as Hooks 17 | import Halogen.IHooks.Compat as Compat 18 | import Halogen.IHooks.Sugar as Sugar 19 | import Performance.Test.State.Shared (Output(..), stateUpdates) 20 | import Performance.Test.Types (Test(..), startSuffix, testToString) 21 | import Type.Proxy (Proxy(..)) 22 | 23 | _stateHook = Proxy :: Proxy "stateHook" 24 | 25 | component :: forall q i m. MonadAff m => H.Component q i Output m 26 | component = Hooks.component Hooks.defaultOptions \_ -> Ix.do 27 | n /\ nId <- Compat.useState { n: 0, n1: 0, n2: 0, n3: 0, n4: 0 } 28 | 29 | let 30 | runState = doThis do 31 | sequence_ $ replicate stateUpdates $ Sugar.modify_ nId \s -> s { n = s.n + 1 } 32 | sequence_ $ replicate stateUpdates $ Sugar.modify_ nId \s -> s { n1 = s.n1 + 1 } 33 | sequence_ $ replicate stateUpdates $ Sugar.modify_ nId \s -> s { n2 = s.n2 + 1 } 34 | sequence_ $ replicate stateUpdates $ Sugar.modify_ nId \s -> s { n3 = s.n3 + 1 } 35 | sequence_ $ replicate stateUpdates $ Sugar.modify_ nId \s -> s { n4 = s.n4 + 1 } 36 | H.raise Done 37 | 38 | ipure do 39 | HH.div_ 40 | [ HH.button 41 | [ HP.id (testToString StateHook <> startSuffix) 42 | , HE.onClick \_ -> runState 43 | ] 44 | [ HH.text "Start Test" ] 45 | , HH.text $ show n 46 | ] 47 | -------------------------------------------------------------------------------- /test/Performance/Test/State/README.md: -------------------------------------------------------------------------------- 1 | # Performance Test: State 2 | 3 | This test measures Hooks overhead by comparing a component and a Hooks-based component which update state several hundred times in response to a click. This test isn't particularly useful on its own; if Hooks add a half millisecond per render + Hooks evaluation, then several hundred updates in a row will add significantly to its execution time. Of course, you would never ever do this in the real world. 4 | 5 | It's still useful as a small sanity check when testing changes -- the Hooks version should not be much slower than the regular component version, though it may use more heap as it stores slightly more state. 6 | -------------------------------------------------------------------------------- /test/Performance/Test/State/Shared.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.State.Shared where 2 | 3 | import Prelude 4 | 5 | import Halogen as H 6 | 7 | type Slot id = forall q. H.Slot q Void id 8 | 9 | data Output = Done 10 | 11 | stateUpdates = 50 :: Int 12 | -------------------------------------------------------------------------------- /test/Performance/Test/Todo/Component.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.Todo.Component where 2 | 3 | import Prelude 4 | 5 | import Data.Foldable (for_) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Set as Set 8 | import Effect.Aff.Class (class MonadAff) 9 | import Halogen (liftEffect) 10 | import Halogen as H 11 | import Halogen.HTML as HH 12 | import Halogen.HTML.Events as HE 13 | import Halogen.HTML.Properties as HP 14 | import Performance.Test.Todo.Shared (CheckboxInput, CheckboxOutput(..), TodoInput, TodoOutput(..)) 15 | import Performance.Test.Todo.Shared as Shared 16 | import Type.Proxy (Proxy(..)) 17 | 18 | _todoComponent = Proxy :: Proxy "todoComponent" 19 | 20 | data ContainerAction 21 | = Initialize 22 | | HandleTodo TodoOutput 23 | | AddNew 24 | 25 | container :: forall q i o m. MonadAff m => H.Component q i o m 26 | container = 27 | H.mkComponent 28 | { initialState: \_ -> Shared.initialContainerState 29 | , render 30 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction, initialize = Just Initialize } 31 | } 32 | where 33 | handleAction = case _ of 34 | Initialize -> do 35 | state <- H.get 36 | filled <- liftEffect $ Shared.fillContainerState state 37 | H.put filled 38 | 39 | HandleTodo msg -> case msg of 40 | Save t -> do 41 | state <- H.get 42 | for_ (Shared.updateTodo t state.todos) \todos -> 43 | H.modify_ _ { todos = todos } 44 | 45 | SetCompleted id complete -> do 46 | if complete then 47 | H.modify_ \state -> state { completed = Set.insert id state.completed } 48 | else 49 | H.modify_ \state -> state { completed = Set.delete id state.completed } 50 | 51 | AddNew -> do 52 | state <- H.get 53 | newState <- liftEffect $ Shared.createTodo state 54 | H.put newState 55 | 56 | render state = do 57 | let 58 | todos = state.todos <#> \t -> 59 | HH.slot Shared._todo t.id todo { todo: t, completed: state.completed } HandleTodo 60 | 61 | HH.div_ 62 | [ HH.button 63 | [ HP.id Shared.addNewId 64 | , HE.onClick \_ -> AddNew 65 | ] 66 | [ HH.text "Add New" ] 67 | , HH.div 68 | [ HP.id Shared.todosId ] 69 | todos 70 | ] 71 | 72 | data TodoAction 73 | = ReceiveTodoInput TodoInput 74 | | UpdateDescription String 75 | | SaveUpdate 76 | | HandleCheckbox CheckboxOutput 77 | 78 | todo :: forall q m. MonadAff m => H.Component q TodoInput TodoOutput m 79 | todo = H.mkComponent 80 | { initialState: identity 81 | , render 82 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction, receive = Just <<< ReceiveTodoInput } 83 | } 84 | where 85 | handleAction = case _ of 86 | ReceiveTodoInput input -> do 87 | state <- H.get 88 | unless (state.todo.id == input.todo.id && state.completed == input.completed) do 89 | H.modify_ \st -> st { todo { id = input.todo.id }, completed = input.completed } 90 | 91 | UpdateDescription str -> do 92 | H.modify_ \state -> state { todo { description = str } } 93 | 94 | SaveUpdate -> do 95 | state <- H.get 96 | H.raise $ Save { id: state.todo.id, description: state.todo.description } 97 | 98 | HandleCheckbox (Check checked) -> do 99 | state <- H.get 100 | H.raise $ SetCompleted state.todo.id checked 101 | 102 | render state = 103 | HH.div_ 104 | [ HH.input 105 | [ HP.id (Shared.editId state.todo.id) 106 | , HE.onValueInput UpdateDescription 107 | , HP.value state.todo.description 108 | ] 109 | , HH.slot Shared._checkbox unit checkbox { id: state.todo.id, completed: state.completed } HandleCheckbox 110 | , HH.button 111 | [ HP.id (Shared.saveId state.todo.id) 112 | , HE.onClick \_ -> SaveUpdate 113 | ] 114 | [ HH.text "Save Changes" ] 115 | ] 116 | 117 | data CheckboxAction = ReceiveCheckboxInput CheckboxInput | HandleCheck Boolean 118 | 119 | checkbox :: forall q m. MonadAff m => H.Component q CheckboxInput CheckboxOutput m 120 | checkbox = H.mkComponent 121 | { initialState: identity 122 | , render 123 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } 124 | } 125 | where 126 | handleAction = case _ of 127 | ReceiveCheckboxInput input -> 128 | H.put input 129 | 130 | HandleCheck checked -> 131 | H.raise $ Check checked 132 | 133 | render state = 134 | HH.input 135 | [ HP.id (Shared.checkId state.id) 136 | , HP.checked $ Set.member state.id state.completed 137 | , HP.type_ HP.InputCheckbox 138 | , HE.onChecked HandleCheck 139 | ] 140 | -------------------------------------------------------------------------------- /test/Performance/Test/Todo/Hook.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.Todo.Hook where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Indexed (ipure) 6 | import Control.Monad.Indexed.Qualified as Ix 7 | import Data.Foldable (for_) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Set as Set 10 | import Effect.Aff.Class (class MonadAff) 11 | import Halogen (liftEffect) 12 | import Halogen as H 13 | import Halogen.HTML as HH 14 | import Halogen.HTML.Events as HE 15 | import Halogen.HTML.Properties as HP 16 | import Halogen.IHooks as Hooks 17 | import Halogen.IHooks.Sugar as Sugar 18 | import Performance.Test.Todo.Shared (CheckboxInput, CheckboxOutput(..), TodoInput, TodoOutput(..)) 19 | import Performance.Test.Todo.Shared as Shared 20 | import Type.Proxy (Proxy(..)) 21 | 22 | _todoHook = Proxy :: Proxy "todoHook" 23 | _containerState = Proxy :: Proxy "containerState" 24 | _description = Proxy :: Proxy "description" 25 | 26 | container :: forall q i o m. MonadAff m => H.Component q i o m 27 | container = Sugar.withConstInput Hooks.defaultOptions \_ -> Ix.do 28 | state <- Hooks.hookCons _containerState (liftEffect $ Shared.fillContainerState Shared.initialContainerState) 29 | 30 | let 31 | handleTodo = Hooks.doThis <<< case _ of 32 | Save t -> do 33 | for_ (Shared.updateTodo t state.todos) \todos -> 34 | Sugar.modify_ _containerState _ { todos = todos } 35 | 36 | SetCompleted id complete -> do 37 | if complete then 38 | Sugar.modify_ _containerState _ { completed = Set.insert id state.completed } 39 | else 40 | Sugar.modify_ _containerState _ { completed = Set.delete id state.completed } 41 | 42 | ipure do 43 | let 44 | todos = state.todos <#> \t -> 45 | HH.slot Shared._todo t.id todo { todo: t, completed: state.completed } handleTodo 46 | 47 | HH.div_ 48 | [ HH.button 49 | [ HP.id Shared.addNewId 50 | , HE.onClick \_ -> Hooks.doThis do 51 | newState <- liftEffect $ Shared.createTodo state 52 | Hooks.setHookMCons _containerState newState 53 | ] 54 | [ HH.text "Add New" ] 55 | , HH.div 56 | [ HP.id Shared.todosId ] 57 | todos 58 | ] 59 | 60 | todo :: forall q m. MonadAff m => H.Component q TodoInput TodoOutput m 61 | todo = Hooks.component 62 | ( Hooks.defaultOptions 63 | { receiveInput = \cur prev -> 64 | if prev.todo.id == cur.todo.id && prev.completed == cur.completed then Nothing 65 | else Just cur 66 | } 67 | ) 68 | \input -> Ix.do 69 | description <- Sugar.hookConsPure _description input.todo.description 70 | 71 | let 72 | handleCheckbox (Check bool) = Hooks.doThis do 73 | H.raise $ SetCompleted input.todo.id bool 74 | 75 | ipure $ 76 | HH.div_ 77 | [ HH.input 78 | [ HP.id (Shared.editId input.todo.id) 79 | , HE.onValueInput (Sugar.doSet _description) 80 | , HP.value description 81 | ] 82 | , HH.slot Shared._checkbox unit checkbox { id: input.todo.id, completed: input.completed } handleCheckbox 83 | , HH.button 84 | [ HP.id (Shared.saveId input.todo.id) 85 | , HE.onClick \_ -> Hooks.doThis do 86 | H.raise $ Save { id: input.todo.id, description } 87 | ] 88 | [ HH.text "Save Changes" ] 89 | ] 90 | 91 | checkbox :: forall q m. MonadAff m => H.Component q CheckboxInput CheckboxOutput m 92 | checkbox = Sugar.withConstInput Hooks.defaultOptions \input -> ipure $ HH.input 93 | [ HP.id (Shared.checkId input.id) 94 | , HP.checked $ Set.member input.id input.completed 95 | , HP.type_ HP.InputCheckbox 96 | , HE.onChecked \checked -> Hooks.doThis $ H.raise (Check checked) 97 | ] 98 | -------------------------------------------------------------------------------- /test/Performance/Test/Todo/README.md: -------------------------------------------------------------------------------- 1 | # Performance Test: Todo 2 | 3 | This test measures performance when nesting components several layers deep and updating from the root. It's intended to catch performance issues that would be relevant in the real world. 4 | 5 | Actions: 6 | 7 | - Add a new TODO 8 | - Check and un-check a TODO 9 | - Edit a TODO and save it 10 | -------------------------------------------------------------------------------- /test/Performance/Test/Todo/Shared.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.Todo.Shared where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Data.Maybe (Maybe) 7 | import Data.Set (Set) 8 | import Data.Set as Set 9 | import Effect (Effect) 10 | import Effect.Random (randomInt) 11 | import Halogen as H 12 | import Partial.Unsafe (unsafePartial) 13 | import Type.Proxy (Proxy(..)) 14 | 15 | data Query a = Run (Unit -> a) 16 | 17 | data TodoOutput = Save Todo | SetCompleted Int Boolean 18 | 19 | _todo = Proxy :: Proxy "todo" 20 | 21 | data CheckboxOutput = Check Boolean 22 | 23 | _checkbox = Proxy :: Proxy "checkbox" 24 | 25 | type Slot = H.Slot Query Void 26 | 27 | type ContainerState = 28 | { todos :: Array Todo 29 | , lastIndex :: Int 30 | , completed :: Set Int 31 | } 32 | 33 | initialContainerState :: ContainerState 34 | initialContainerState = 35 | { todos: [] 36 | , lastIndex: 0 37 | , completed: Set.empty 38 | } 39 | 40 | fillContainerState :: ContainerState -> Effect ContainerState 41 | fillContainerState state = do 42 | let lastIndex' = state.lastIndex + 100 43 | todos <- go state.lastIndex lastIndex' state.todos 44 | pure $ state { todos = todos, lastIndex = lastIndex' } 45 | where 46 | go :: Int -> Int -> Array Todo -> Effect (Array Todo) 47 | go n limit arr 48 | | n == limit = pure arr 49 | | otherwise = do 50 | todo <- mkTodo n 51 | go (n + 1) limit (Array.snoc arr todo) 52 | 53 | createTodo :: ContainerState -> Effect ContainerState 54 | createTodo state = do 55 | todo <- mkTodo (state.lastIndex + 1) 56 | pure $ state { todos = Array.snoc state.todos todo, lastIndex = todo.id } 57 | 58 | type TodoInput = 59 | { todo :: Todo 60 | , completed :: Set Int 61 | } 62 | 63 | type Todo = 64 | { description :: String 65 | , id :: Int 66 | } 67 | 68 | mkTodo :: Int -> Effect Todo 69 | mkTodo id = do 70 | ix <- randomInt 0 9 71 | let description = unsafePartial (Array.unsafeIndex descriptions ix) 72 | pure { description, id } 73 | 74 | updateTodo :: Todo -> Array Todo -> Maybe (Array Todo) 75 | updateTodo todo todos = do 76 | ix <- Array.findIndex (_.id >>> eq todo.id) todos 77 | Array.updateAt ix todo todos 78 | 79 | descriptions :: Array String 80 | descriptions = [ "eat", "drink", "sleep", "party", "walk", "run", "hike", "play the drums", "cook", "chill" ] 81 | 82 | addNewId :: String 83 | addNewId = "add-new" 84 | 85 | todosId :: String 86 | todosId = "todos" 87 | 88 | editId :: Int -> String 89 | editId id = "edit-" <> show id 90 | 91 | saveId :: Int -> String 92 | saveId id = "save-" <> show id 93 | 94 | checkId :: Int -> String 95 | checkId id = "check-" <> show id 96 | 97 | type CheckboxInput = 98 | { id :: Int 99 | , completed :: Set Int 100 | } 101 | -------------------------------------------------------------------------------- /test/Performance/Test/Types.purs: -------------------------------------------------------------------------------- 1 | module Performance.Test.Types where 2 | 3 | import Prelude 4 | 5 | data Test 6 | = StateHook 7 | | StateComponent 8 | | TodoHook 9 | | TodoComponent 10 | 11 | derive instance eqTest :: Eq Test 12 | derive instance ordTest :: Ord Test 13 | 14 | testToString :: Test -> String 15 | testToString = case _ of 16 | StateHook -> "state-hook" 17 | StateComponent -> "state-component" 18 | TodoHook -> "todo-hook" 19 | TodoComponent -> "todo-component" 20 | 21 | -- Used by a test along with its string id to control test start / stop 22 | startSuffix = "-start" :: String 23 | completedSuffix = "-complete" :: String 24 | -------------------------------------------------------------------------------- /test/test.dhall: -------------------------------------------------------------------------------- 1 | let conf = ../spago.dhall 2 | 3 | in conf 4 | // { dependencies = 5 | conf.dependencies 6 | # [ "aff-promise" 7 | , "argonaut-codecs" 8 | , "argonaut-core" 9 | , "node-fs" 10 | , "spec" 11 | , "random" 12 | , "debug" 13 | , "aff" 14 | , "arrays" 15 | , "avar" 16 | , "console" 17 | , "either" 18 | , "exceptions" 19 | , "integers" 20 | , "node-buffer" 21 | , "node-path" 22 | , "nullable" 23 | , "ordered-collections" 24 | , "partial" 25 | , "strings" 26 | , "tailrec" 27 | , "web-html" 28 | ] 29 | , sources = conf.sources # [ "test/**/*.purs"] 30 | } 31 | -------------------------------------------------------------------------------- /test/test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Test Halogen Hooks 7 | 8 | 9 | 10 | 11 | 12 | 13 | --------------------------------------------------------------------------------