├── .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 | 
28 |
29 | This allows you to inspect the type in the IDE as you're putting together the hooks.
30 |
31 | 
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 |
--------------------------------------------------------------------------------