packages feed

hyperbole 0.3.6 → 0.4.2

raw patch · 52 files changed

+3535/−2995 lines, 52 filesdep +Diffdep +data-defaultdep +skeletestdep −sydtestdep −wai-middleware-staticdep ~effectfuldep ~web-view

Dependencies added: Diff, data-default, skeletest, time

Dependencies removed: sydtest, wai-middleware-static

Dependency ranges changed: effectful, web-view

Files

CHANGELOG.md view
@@ -1,5 +1,25 @@ # Revision history for hyperbole -## 0.1.0 -- YYYY-mm-dd+## 0.4.2 -- 2024-01-21++* Cleaner HyperView class [(@cgeorgii)](https://github.com/cgeorgii)+  * data family Action+  * update+* Type-safe resolution of HyperViews+* Record-based Forms+  * textarea [(@tusharad)](https://github.com/tusharad)+* High-level sessions and query params+* Events: onLoad, onClick onInput, onSubmit, onDblClick, onKeyDown, onKeyUp+* Major refactoring+* Nix build and CI [(@Skyfold)](https://github.com/Skyfold)+* New Examples Live: https://docs.hyperbole.live+* New Examples Added:+  * TodoMVC+  * Forms - Simple+  * DataTable+  * Search - Filters+  * Search - Autocomplete++## 0.3.6 -- 2024-05-21  * First version. Released on an unsuspecting world.
README.md view
@@ -1,9 +1,8 @@-Hyperbole-=========+![Hyperbole](example/static/logo-robot.png) -[![Hackage](https://img.shields.io/hackage/v/hyperbole.svg)](https://hackage.haskell.org/package/hyperbole) +[![Hackage](https://img.shields.io/hackage/v/hyperbole.svg?color=success)](https://hackage.haskell.org/package/hyperbole) -Create fully interactive HTML applications with type-safe serverside Haskell. Inspired by [HTMX](https://htmx.org/), [Elm](https://elm-lang.org/), and [Phoenix LiveView](https://www.phoenixframework.org/)+Create interactive HTML applications with type-safe serverside Haskell. Inspired by [HTMX](https://htmx.org/), [Elm](https://elm-lang.org/), and [Phoenix LiveView](https://www.phoenixframework.org/)  [Learn more about Hyperbole on Hackage](https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html) @@ -11,65 +10,90 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+module Main where +import Data.Text (Text) import Web.Hyperbole +main :: IO () main = do   run 3000 $ do-    liveApp (basicDocument "Example") (page mainPage)+    liveApp (basicDocument "Example") (runPage page)  -mainPage = do-  handle message-  load $ do-    pure $ do-      el bold "My Page"-      hyper (Message 1) $ messageView "Hello"-      hyper (Message 2) $ messageView "World!"+page :: (Hyperbole :> es) => Eff es (Page '[Message])+page = do+  pure $ col id $ do+    hyper Message1 $ messageView "Hello"+    hyper Message2 $ messageView "World!"  -data Message = Message Int-  deriving (Generic, Param)+data Message = Message1 | Message2+  deriving (Show, Read, ViewId) -data MessageAction = Louder Text-  deriving (Generic, Param) -instance HyperView Message where-  type Action Message = MessageAction+instance HyperView Message es where+  data Action Message = Louder Text+    deriving (Show, Read, ViewAction) +  update (Louder msg) = do+    let new = msg <> "!"+    pure $ messageView new -message :: Message -> MessageAction -> Eff es (View Message ())-message _ (Louder m) = do-  let new = m <> "!"-  pure $ messageView new +messageView :: Text -> View Message ()+messageView msg = do+  row id $ do+    button (Louder msg) id "Louder"+    el_ $ text msg+``` -messageView m = do-  el_ $ text m-  button (Louder m) id "Louder"+Getting Started with Cabal+--------------------------++Create a new application:++    $ mkdir myapp+    $ cd myapp+    $ cabal init++Add hyperbole and text to your build-depends:+ ```+    build-depends:+        base+      , hyperbole+      , text+``` +Paste the above example into Main.hs, and run++    $ cabal run++Visit http://localhost:3000 to view the application++ Examples --------- -The [example directory](https://github.com/seanhess/hyperbole/blob/main/example/README.md) contains an app with pages demonstrating various features+The example directory contains an app demonstrating various features. See it in action at https://docs.hyperbole.live -Run the examples in this repo using cabal. Then visit http://localhost:3000/ in your browser+<a href="https://docs.hyperbole.live">+  <img alt="Hyperbole Examples" src="example/static/examples.png"/>+</a> -```-cabal run-```-* [Main](https://github.com/seanhess/hyperbole/blob/main/example/Main.hs)-* [Simple](https://github.com/seanhess/hyperbole/blob/main/example/Example/Simple.hs)-* [Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs)-* [CSS Transitions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Transitions.hs)-* [Forms](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)-* [Sessions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)-* [Redirects](https://github.com/seanhess/hyperbole/blob/main/example/Example/Redirects.hs)-* [Lazy Loading and Polling](https://github.com/seanhess/hyperbole/blob/main/example/Example/LazyLoading.hs)-* [Errors](https://github.com/seanhess/hyperbole/blob/main/example/Example/Errors.hs)-* [Contacts (Advanced)](https://github.com/seanhess/hyperbole/blob/main/example/Example/Contacts.hs)+### Try Example Project Locally +These will run the examples webserver++#### With Nix++`nix run github:seanhess/hyperbole`++#### With Docker++`docker run -it -p 3000:3000 ghcr.io/seanhess/hyperbole:latest`+ Learn More ---------- @@ -79,9 +103,136 @@ View on Github * https://github.com/seanhess/hyperbole -In Production-------------- +Full Production Example+-----------------------+ <a href="https://nso.edu">   <img alt="National Solar Observatory" src="https://nso1.b-cdn.net/wp-content/uploads/2020/03/NSO-logo-orange-text.png" width="400"/> </a>++The NSO uses Hyperbole for the Level 2 Data creation tool for the [DKIST telescope](https://nso.edu/telescopes/dki-solar-telescope/). It is completely [open source](https://github.com/DKISTDC/level2/). This production application contains complex interfaces, workers, databases, and more.+++Local Development+-----------------++### Recommended ghcid command++If you want to work on both the hyperbole library and example code, this `ghcid` command will run (and hot reload) the examples server as you change any non-testing code.++```+ghcid --setup=Main.update --command="cabal repl exe:examples lib:hyperbole" --run=Main.update --warnings --reload=./client/dist/hyperbole.js+```++If you want to work on the test suite, this will run the tests each time any library code is changed.++```+ghcid --command="cabal repl test lib:hyperbole" --run=Main.main --warnings --reload=./client/dist/hyperbole.js+```++### Nix++Prepend targets with ghc982 or ghc966 to use GHC 9.8.2 or GHC 9.6.6++- `nix run` or `nix run .#ghc966-hyperbole-examples` to start the example project with GHC 9.8.2+- `nix develop` or `nix develop .#ghc982-shell` to get a shell with all dependencies installed for GHC 9.8.2. ++You can import this flake's overlay to add `hyperbole` to all package sets and override ghc966 and ghc982 with the packages to satisfy `hyperbole`'s dependencies.++```nix+{+  inputs = {+    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";+    hyperbole.url = "github:seanhess/hyperbole"; # or "path:/path/to/cloned/hyperbole";+    flake-utils.url = "github:numtide/flake-utils";+  };++  outputs = { self, nixpkgs, hyperbole, flake-utils, ... }:+    flake-utils.lib.eachDefaultSystem (+      system:+      let+        pkgs = import nixpkgs {+          inherit system;+          overlays = [ hyperbole.overlays.default ];+        };+        haskellPackagesOverride = pkgs.haskell.packages.ghc966.override (old: {+          overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: { })) (hfinal: hprev: {+            # your overrides here+          });+        });+      in+      {+        devShells.default = haskellPackagesOverride.shellFor {+          packages = p: [ p.hyperbole ];+        };+      }+    );+}+```++Note: You can always run `cachix use hyperbole` to use the GitHub CI populated cache if you didn't allow adding 'extra-substituters' when first using this flake.++### Manual dependency installation+++Download and install [NPM](https://nodejs.org/en/download). On a mac, can be installed via homebrew:++```+brew install npm+```++Install client dependencies++```+cd client+npm install+```++Recommended: Use `direnv` to automatically load environment from .env++```+brew install direnv+direnv allow+```+++### Building++Build JavaScript client++```+cd client+npx webpack+```++Run examples++```+cd example+cabal run+```++### Tests++```+cabal test+```++### File watching++Run tests, then recompile everything on file change and restart examples++```+bin/dev+```+++Contributors+------------++* [Sean Hess](seanhess)+* [Kamil Figiela](https://github.com/kfigiela)+* [Christian Georgii](https://github.com/cgeorgii)+* [Pfalzgraf Martin](https://github.com/Skyfold)+* [Tushar Adhatrao](https://github.com/tusharad)
client/dist/hyperbole.js view
@@ -1,136 +1,3 @@-/*- * ATTENTION: The "eval" devtool has been used (maybe by default in mode: "development").- * This devtool is neither made for production nor for readable output files.- * It uses "eval()" calls to create a separate source file in the browser devtools.- * If you are trying to read the output file, select a different devtool (https://webpack.js.org/configuration/devtool/)- * or disable the default devtool with "devtool: false".- * If you are looking for production-ready output files, see mode: "production" (https://webpack.js.org/configuration/mode/).- */-/******/ (() => { // webpackBootstrap-/******/ 	"use strict";-/******/ 	var __webpack_modules__ = ({--/***/ "./src/action.ts":-/*!***********************!*\-  !*** ./src/action.ts ***!-  \***********************/-/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */   actionMessage: () => (/* binding */ actionMessage),\n/* harmony export */   actionUrl: () => (/* binding */ actionUrl),\n/* harmony export */   toSearch: () => (/* binding */ toSearch)\n/* harmony export */ });\nfunction actionUrl(id, action) {\n    var url = new URL(window.location.href);\n    url.searchParams.append(\"id\", id);\n    url.searchParams.append(\"action\", action);\n    return url;\n}\nfunction toSearch(form) {\n    if (!form)\n        return undefined;\n    var params = new URLSearchParams();\n    form.forEach(function (value, key) {\n        params.append(key, value);\n    });\n    return params;\n}\nfunction actionMessage(id, action, form) {\n    var url = actionUrl(id, action);\n    return { url: url, form: toSearch(form) };\n}\n\n\n//# sourceURL=webpack://web-ui/./src/action.ts?");--/***/ }),--/***/ "./src/events.ts":-/*!***********************!*\-  !*** ./src/events.ts ***!-  \***********************/-/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */   listenChange: () => (/* binding */ listenChange),\n/* harmony export */   listenClick: () => (/* binding */ listenClick),\n/* harmony export */   listenFormSubmit: () => (/* binding */ listenFormSubmit),\n/* harmony export */   listenLoad: () => (/* binding */ listenLoad),\n/* harmony export */   listenLoadDocument: () => (/* binding */ listenLoadDocument)\n/* harmony export */ });\nfunction listenClick(cb) {\n    document.addEventListener(\"click\", function (e) {\n        var el = e.target;\n        // clicks can fire on internal elements. Find the parent with a click handler\n        var source = el.closest(\"[data-on-click]\");\n        // console.log(\"CLICK\", source?.dataset.onClick)\n        // they should all have an action and target\n        if ((source === null || source === void 0 ? void 0 : source.dataset.onClick) && (source === null || source === void 0 ? void 0 : source.dataset.target)) {\n            e.preventDefault();\n            var target = document.getElementById(source.dataset.target);\n            if (!target) {\n                console.error(\"Missing target: \", source.dataset.target);\n                return;\n            }\n            cb(target, source.dataset.onClick);\n        }\n    });\n}\nfunction listenLoadDocument(cb) {\n    document.addEventListener(\"hyp-load\", function (e) {\n        var load = e.target;\n        var action = load.dataset.onLoad;\n        var target = document.getElementById(load.dataset.target);\n        if (!target) {\n            console.error(\"Missing load target: \", target);\n            return;\n        }\n        cb(target, action);\n    });\n}\nfunction listenLoad(node) {\n    // it doesn't really matter WHO runs this except that it should have target\n    node.querySelectorAll(\"[data-on-load]\").forEach(function (load) {\n        var delay = parseInt(load.dataset.delay) || 0;\n        setTimeout(function () {\n            var event = new Event(\"hyp-load\", { bubbles: true });\n            load.dispatchEvent(event);\n        }, delay);\n    });\n}\nfunction listenChange(cb) {\n    document.addEventListener(\"change\", function (e) {\n        var el = e.target;\n        // clicks can fire on internal elements. Find the parent with a click handler\n        var source = el.closest(\"[data-on-change]\");\n        // console.log(\"CHANGE!\", source.value)\n        // they should all have an action and target\n        if ((source === null || source === void 0 ? void 0 : source.dataset.target) && source.value) {\n            e.preventDefault();\n            var target = document.getElementById(source.dataset.target);\n            if (!target) {\n                console.error(\"Missing target: \", source.dataset.target);\n                return;\n            }\n            cb(target, source.value);\n        }\n    });\n}\nfunction listenFormSubmit(cb) {\n    document.addEventListener(\"submit\", function (e) {\n        var form = e.target;\n        // they should all have an action and target\n        if ((form === null || form === void 0 ? void 0 : form.dataset.onSubmit) && (form === null || form === void 0 ? void 0 : form.dataset.target)) {\n            e.preventDefault();\n            var target = document.getElementById(form.dataset.target);\n            if (!target) {\n                console.error(\"Missing target: \", form.dataset.target);\n                return;\n            }\n            var formData = new FormData(form);\n            cb(target, form.dataset.onSubmit, formData);\n        }\n    });\n}\n\n\n//# sourceURL=webpack://web-ui/./src/events.ts?");--/***/ }),--/***/ "./src/index.ts":-/*!**********************!*\-  !*** ./src/index.ts ***!-  \**********************/-/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony import */ var omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__ = __webpack_require__(/*! omdomdom/lib/omdomdom.es.js */ \"./node_modules/omdomdom/lib/omdomdom.es.js\");\n/* harmony import */ var _sockets__WEBPACK_IMPORTED_MODULE_1__ = __webpack_require__(/*! ./sockets */ \"./src/sockets.ts\");\n/* harmony import */ var _events__WEBPACK_IMPORTED_MODULE_2__ = __webpack_require__(/*! ./events */ \"./src/events.ts\");\n/* harmony import */ var _action__WEBPACK_IMPORTED_MODULE_3__ = __webpack_require__(/*! ./action */ \"./src/action.ts\");\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n    function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n    return new (P || (P = Promise))(function (resolve, reject) {\n        function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n        function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n        function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n        step((generator = generator.apply(thisArg, _arguments || [])).next());\n    });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n    var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n    return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n    function verb(n) { return function (v) { return step([n, v]); }; }\n    function step(op) {\n        if (f) throw new TypeError(\"Generator is already executing.\");\n        while (g && (g = 0, op[0] && (_ = 0)), _) try {\n            if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n            if (y = 0, t) op = [op[0] & 2, t.value];\n            switch (op[0]) {\n                case 0: case 1: t = op; break;\n                case 4: _.label++; return { value: op[1], done: false };\n                case 5: _.label++; y = op[1]; op = [0]; continue;\n                case 7: op = _.ops.pop(); _.trys.pop(); continue;\n                default:\n                    if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n                    if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n                    if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n                    if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n                    if (t[2]) _.ops.pop();\n                    _.trys.pop(); continue;\n            }\n            op = body.call(thisArg, _);\n        } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n        if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n    }\n};\n\n\n\n\n// import { listenEvents } from './events';\n// import { WEBSOCKET_ADDRESS, Messages } from './Messages'\n// import { INIT_PAGE, INIT_STATE, State, Class } from './types';\n// import { fromVDOM, VDOM } from './vdom'\n// const CONTENT_ID = \"yeti-root-content\"\n// console.log(\"VERSION 2\", INIT_PAGE, INIT_STATE)\nconsole.log(\"Hyperbole 0.3.3a\");\nvar rootStyles;\nfunction sendAction(msg) {\n    return __awaiter(this, void 0, void 0, function () {\n        function sendActionHttp(msg) {\n            return __awaiter(this, void 0, void 0, function () {\n                var res, error, body;\n                return __generator(this, function (_a) {\n                    switch (_a.label) {\n                        case 0:\n                            console.log(\"HTTP sendAction\", msg.url.toString());\n                            return [4 /*yield*/, fetch(msg.url, {\n                                    method: \"POST\",\n                                    headers: { 'Accept': 'text/html', 'Content-Type': 'application/x-www-form-urlencoded' },\n                                    body: msg.form,\n                                    // we never want this to be redirected\n                                    redirect: \"manual\"\n                                })];\n                        case 1:\n                            res = _a.sent();\n                            if (res.headers.get('location')) {\n                                // manual redirect with status 200\n                                console.log(\"Found Redirect\", res.headers.get('location'));\n                                window.location.href = res.headers.get('location');\n                                return [2 /*return*/];\n                            }\n                            console.log(\"RES\", res.headers.get(\"location\"));\n                            if (res.headers.get(\"location\")) {\n                                window.location.href = res.headers.get(\"location\");\n                                return [2 /*return*/];\n                            }\n                            if (!!res.ok) return [3 /*break*/, 3];\n                            error = new Error();\n                            error.name = \"Fetch Error \" + res.status;\n                            return [4 /*yield*/, res.text()];\n                        case 2:\n                            body = _a.sent();\n                            error.message = body;\n                            throw error;\n                        case 3: return [2 /*return*/, res.text()];\n                    }\n                });\n            });\n        }\n        return __generator(this, function (_a) {\n            if (sock.isConnected) {\n                return [2 /*return*/, sock.sendAction(msg)];\n            }\n            else {\n                return [2 /*return*/, sendActionHttp(msg)];\n            }\n            return [2 /*return*/];\n        });\n    });\n}\nfunction fetchAction(msg) {\n    return __awaiter(this, void 0, void 0, function () {\n        var ret, err_1;\n        return __generator(this, function (_a) {\n            switch (_a.label) {\n                case 0:\n                    _a.trys.push([0, 2, , 3]);\n                    return [4 /*yield*/, sendAction(msg)];\n                case 1:\n                    ret = _a.sent();\n                    return [2 /*return*/, ret];\n                case 2:\n                    err_1 = _a.sent();\n                    // handle error here\n                    document.body.innerHTML = errorHTML(err_1);\n                    throw err_1;\n                case 3: return [2 /*return*/];\n            }\n        });\n    });\n}\nfunction runAction(target, action, form) {\n    return __awaiter(this, void 0, void 0, function () {\n        var timeout, msg, ret, res, next, old, newTarget;\n        return __generator(this, function (_a) {\n            switch (_a.label) {\n                case 0:\n                    timeout = setTimeout(function () {\n                        // add loading after 200ms, not right away\n                        target.classList.add(\"hyp-loading\");\n                    }, 200);\n                    msg = (0,_action__WEBPACK_IMPORTED_MODULE_3__.actionMessage)(target.id, action, form);\n                    return [4 /*yield*/, fetchAction(msg)];\n                case 1:\n                    ret = _a.sent();\n                    res = parseResponse(ret);\n                    if (!res.css || !res.content) {\n                        console.error(\"Empty Response\", res);\n                        return [2 /*return*/];\n                    }\n                    // First, update the stylesheet\n                    addCSS(res.css.textContent);\n                    next = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(res.content);\n                    old = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(target);\n                    (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.patch)(next, old);\n                    newTarget = document.getElementById(target.id);\n                    // let event = new Event(\"content\", {bubbles:true})\n                    // newTarget.dispatchEvent(event)\n                    // load doesn't bubble\n                    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoad)(newTarget);\n                    // Remove loading and clear add timeout\n                    clearTimeout(timeout);\n                    target.classList.remove(\"hyp-loading\");\n                    return [2 /*return*/];\n            }\n        });\n    });\n}\nfunction addCSS(text) {\n    var rules = text.split(\"\\n\");\n    rules.forEach(function (rule) {\n        rootStyles.sheet.insertRule(rule);\n    });\n}\nfunction parseResponse(vw) {\n    var parser = new DOMParser();\n    var doc = parser.parseFromString(vw, 'text/html');\n    var css = doc.querySelector(\"style\");\n    var content = doc.querySelector(\"div\");\n    return {\n        content: content,\n        css: css\n    };\n}\nfunction init() {\n    rootStyles = document.querySelector('style');\n    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoadDocument)(function (target, action) {\n        return __awaiter(this, void 0, void 0, function () {\n            return __generator(this, function (_a) {\n                console.log(\"INIT LOAD\", target.id, action);\n                runAction(target, action);\n                return [2 /*return*/];\n            });\n        });\n    });\n    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoad)(document.body);\n    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenClick)(function (target, action) {\n        return __awaiter(this, void 0, void 0, function () {\n            return __generator(this, function (_a) {\n                console.log(\"CLICK\", target.id, action);\n                runAction(target, action);\n                return [2 /*return*/];\n            });\n        });\n    });\n    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenFormSubmit)(function (target, action, form) {\n        return __awaiter(this, void 0, void 0, function () {\n            return __generator(this, function (_a) {\n                console.log(\"FORM\", target.id, action, form);\n                runAction(target, action, form);\n                return [2 /*return*/];\n            });\n        });\n    });\n    (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenChange)(function (target, action) {\n        return __awaiter(this, void 0, void 0, function () {\n            return __generator(this, function (_a) {\n                console.log(\"CHANGE\", target.id, action);\n                runAction(target, action);\n                return [2 /*return*/];\n            });\n        });\n    });\n}\ndocument.addEventListener(\"DOMContentLoaded\", init);\n// Should we connect to the socket or not?\nvar sock = new _sockets__WEBPACK_IMPORTED_MODULE_1__.SocketConnection();\nsock.connect();\n// no it should take over the whole page...\nfunction errorHTML(error) {\n    // TODO: match on error.name and handle it differently\n    var style = [\n        \".hyp-error {background-color:#DB3524; color:white; padding: 10px}\",\n        \".hyp-details {padding: 10px}\"\n    ];\n    var content = \"<div class='hyp-error'>\".concat(error.name, \"</div>\");\n    var details = \"<div class='hyp-details'>\".concat(error.message, \"</div>\");\n    return [\"<style>\" + style.join(\"\\n\") + \"</style>\", content, details].join(\"\\n\");\n}\n\n\n//# sourceURL=webpack://web-ui/./src/index.ts?");--/***/ }),--/***/ "./src/lib.ts":-/*!********************!*\-  !*** ./src/lib.ts ***!-  \********************/-/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */   dropWhile: () => (/* binding */ dropWhile),\n/* harmony export */   takeWhileMap: () => (/* binding */ takeWhileMap)\n/* harmony export */ });\nfunction takeWhileMap(pred, lines) {\n    var output = [];\n    for (var _i = 0, lines_1 = lines; _i < lines_1.length; _i++) {\n        var line = lines_1[_i];\n        var a = pred(line);\n        if (a)\n            output.push(a);\n        else\n            break;\n    }\n    return output;\n}\nfunction dropWhile(pred, lines) {\n    var index = 0;\n    while (index < lines.length && pred(lines[index])) {\n        index++;\n    }\n    return lines.slice(index);\n}\n\n\n//# sourceURL=webpack://web-ui/./src/lib.ts?");--/***/ }),--/***/ "./src/sockets.ts":-/*!************************!*\-  !*** ./src/sockets.ts ***!-  \************************/-/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */   SocketConnection: () => (/* binding */ SocketConnection)\n/* harmony export */ });\n/* harmony import */ var _lib__WEBPACK_IMPORTED_MODULE_0__ = __webpack_require__(/*! ./lib */ \"./src/lib.ts\");\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n    function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n    return new (P || (P = Promise))(function (resolve, reject) {\n        function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n        function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n        function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n        step((generator = generator.apply(thisArg, _arguments || [])).next());\n    });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n    var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n    return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n    function verb(n) { return function (v) { return step([n, v]); }; }\n    function step(op) {\n        if (f) throw new TypeError(\"Generator is already executing.\");\n        while (g && (g = 0, op[0] && (_ = 0)), _) try {\n            if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n            if (y = 0, t) op = [op[0] & 2, t.value];\n            switch (op[0]) {\n                case 0: case 1: t = op; break;\n                case 4: _.label++; return { value: op[1], done: false };\n                case 5: _.label++; y = op[1]; op = [0]; continue;\n                case 7: op = _.ops.pop(); _.trys.pop(); continue;\n                default:\n                    if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n                    if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n                    if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n                    if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n                    if (t[2]) _.ops.pop();\n                    _.trys.pop(); continue;\n            }\n            op = body.call(thisArg, _);\n        } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n        if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n    }\n};\n\nvar protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:';\nvar defaultAddress = \"\".concat(protocol, \"//\").concat(window.location.host).concat(window.location.pathname);\nvar SocketConnection = /** @class */ (function () {\n    function SocketConnection() {\n        this.reconnectDelay = 0;\n    }\n    // we need to faithfully transmit the \n    SocketConnection.prototype.connect = function (addr) {\n        var _this = this;\n        if (addr === void 0) { addr = defaultAddress; }\n        var sock = new WebSocket(addr);\n        this.socket = sock;\n        function onConnectError(ev) {\n            console.log(\"Connection Error\", ev);\n        }\n        sock.addEventListener('error', onConnectError);\n        sock.addEventListener('open', function (event) {\n            console.log(\"Opened\", event);\n            _this.isConnected = true;\n            _this.hasEverConnected = true;\n            _this.reconnectDelay = 0;\n            _this.socket.removeEventListener('error', onConnectError);\n        });\n        // TODO: Don't reconnet if the socket server is OFF, only if we've successfully connected once\n        sock.addEventListener('close', function (_) {\n            _this.isConnected = false;\n            console.log(\"Closed\");\n            // attempt to reconnect in 1s\n            if (_this.hasEverConnected) {\n                _this.reconnectDelay += 1000;\n                console.log(\"Reconnecting in \" + (_this.reconnectDelay / 1000) + \"s\");\n                setTimeout(function () { return _this.connect(addr); }, _this.reconnectDelay);\n            }\n        });\n    };\n    SocketConnection.prototype.sendAction = function (action) {\n        return __awaiter(this, void 0, void 0, function () {\n            var msg, ret, _a, metadata, rest;\n            return __generator(this, function (_b) {\n                switch (_b.label) {\n                    case 0:\n                        msg = [action.url.pathname + action.url.search,\n                            \"Host: \" + window.location.host,\n                            \"Cookie: \" + document.cookie,\n                            action.form\n                        ].join(\"\\n\");\n                        return [4 /*yield*/, this.fetch(msg)];\n                    case 1:\n                        ret = _b.sent();\n                        _a = parseMetadataResponse(ret), metadata = _a.metadata, rest = _a.rest;\n                        if (metadata.error) {\n                            throw socketError(metadata.error);\n                        }\n                        if (metadata.session) {\n                            // console.log(\"setting cookie\", metadata.session)\n                            document.cookie = metadata.session;\n                        }\n                        if (metadata.redirect) {\n                            window.location.href = metadata.redirect;\n                        }\n                        return [2 /*return*/, rest];\n                }\n            });\n        });\n    };\n    SocketConnection.prototype.fetch = function (msg) {\n        return __awaiter(this, void 0, void 0, function () {\n            var res;\n            return __generator(this, function (_a) {\n                switch (_a.label) {\n                    case 0:\n                        this.sendMessage(msg);\n                        return [4 /*yield*/, this.waitMessage()];\n                    case 1:\n                        res = _a.sent();\n                        return [2 /*return*/, res];\n                }\n            });\n        });\n    };\n    SocketConnection.prototype.sendMessage = function (msg) {\n        this.socket.send(msg);\n    };\n    SocketConnection.prototype.waitMessage = function () {\n        return __awaiter(this, void 0, void 0, function () {\n            var _this = this;\n            return __generator(this, function (_a) {\n                return [2 /*return*/, new Promise(function (resolve, reject) {\n                        var onMessage = function (event) {\n                            var data = event.data;\n                            resolve(data);\n                            _this.socket.removeEventListener('message', onMessage);\n                        };\n                        _this.socket.addEventListener('message', onMessage);\n                        _this.socket.addEventListener('error', reject);\n                    })];\n            });\n        });\n    };\n    SocketConnection.prototype.disconnect = function () {\n        this.socket.close();\n    };\n    return SocketConnection;\n}());\n\nfunction socketError(inp) {\n    var error = new Error();\n    error.name = inp.substring(0, inp.indexOf(' '));\n    error.message = inp.substring(inp.indexOf(' ') + 1);\n    return error;\n}\nconsole.log(\"CONNECTING\", window.location);\nfunction parseMetadataResponse(ret) {\n    var lines = ret.split(\"\\n\");\n    var metas = parseMetas((0,_lib__WEBPACK_IMPORTED_MODULE_0__.takeWhileMap)(parseMeta, lines));\n    var rest = (0,_lib__WEBPACK_IMPORTED_MODULE_0__.dropWhile)(parseMeta, lines).join(\"\\n\");\n    return {\n        metadata: metas,\n        rest: rest\n    };\n    function parseMeta(line) {\n        var match = line.match(/^\\|(\\w+)\\|(.*)$/);\n        if (match) {\n            return {\n                key: match[1],\n                value: match[2]\n            };\n        }\n    }\n}\nfunction parseMetas(meta) {\n    var _a, _b, _c;\n    return {\n        session: (_a = meta.find(function (m) { return m.key == \"SESSION\"; })) === null || _a === void 0 ? void 0 : _a.value,\n        redirect: (_b = meta.find(function (m) { return m.key == \"REDIRECT\"; })) === null || _b === void 0 ? void 0 : _b.value,\n        error: (_c = meta.find(function (m) { return m.key == \"ERROR\"; })) === null || _c === void 0 ? void 0 : _c.value\n    };\n}\n\n\n//# sourceURL=webpack://web-ui/./src/sockets.ts?");--/***/ }),--/***/ "./node_modules/omdomdom/lib/omdomdom.es.js":-/*!**************************************************!*\-  !*** ./node_modules/omdomdom/lib/omdomdom.es.js ***!-  \**************************************************/-/***/ ((__unused_webpack___webpack_module__, __webpack_exports__, __webpack_require__) => {--eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */   create: () => (/* binding */ create),\n/* harmony export */   patch: () => (/* binding */ patch),\n/* harmony export */   render: () => (/* binding */ render)\n/* harmony export */ });\n/*!\n  * @license MIT (https://github.com/geotrev/omdomdom/blob/master/LICENSE)\n  * Omdomdom v0.3.2 (https://github.com/geotrev/omdomdom)\n  * Copyright 2023 George Treviranus <geowtrev@gmail.com>\n  */\nvar DATA_KEY_ATTRIBUTE$1 = \"data-key\";\nvar hasProperty = function hasProperty(obj, prop) {\n  return Object.prototype.hasOwnProperty.call(obj, prop);\n};\nvar keyIsValid = function keyIsValid(map, key) {\n  if (!key) return false;\n  if (hasProperty(map, key)) {\n    console.warn(\"[OmDomDom]: Children with duplicate keys detected. Children with duplicate keys will be skipped, resulting in dropped node references. Keys must be unique and non-indexed.\");\n    return false;\n  }\n  return true;\n};\nvar forEach = function forEach(items, fn) {\n  var length = items.length;\n  var idx = -1;\n  if (!length) return;\n  while (++idx < length) {\n    if (fn(items[idx], idx) === false) break;\n  }\n};\nvar createKeyMap = function createKeyMap(children) {\n  var map = {};\n  forEach(children, function (child) {\n    var key = child.attributes[DATA_KEY_ATTRIBUTE$1];\n    if (keyIsValid(map, key)) {\n      map[key] = child;\n    }\n  });\n  for (var _ in map) {\n    return map;\n  }\n};\nvar insertBefore = function insertBefore(parent, child, refNode) {\n  return parent.node.insertBefore(child.node, refNode);\n};\nvar assignVNode = function assignVNode(template, vNode) {\n  for (var property in template) {\n    vNode[property] = template[property];\n  }\n};\n\nvar toHTML = function toHTML(htmlString) {\n  var processedDOMString = htmlString.trim().replace(/\\s+</g, \"<\").replace(/>\\s+/g, \">\");\n  var parser = new DOMParser();\n  var context = parser.parseFromString(processedDOMString, \"text/html\");\n  return context.body;\n};\n\nfunction _iterableToArrayLimit(arr, i) {\n  var _i = null == arr ? null : \"undefined\" != typeof Symbol && arr[Symbol.iterator] || arr[\"@@iterator\"];\n  if (null != _i) {\n    var _s,\n      _e,\n      _x,\n      _r,\n      _arr = [],\n      _n = !0,\n      _d = !1;\n    try {\n      if (_x = (_i = _i.call(arr)).next, 0 === i) {\n        if (Object(_i) !== _i) return;\n        _n = !1;\n      } else for (; !(_n = (_s = _x.call(_i)).done) && (_arr.push(_s.value), _arr.length !== i); _n = !0);\n    } catch (err) {\n      _d = !0, _e = err;\n    } finally {\n      try {\n        if (!_n && null != _i.return && (_r = _i.return(), Object(_r) !== _r)) return;\n      } finally {\n        if (_d) throw _e;\n      }\n    }\n    return _arr;\n  }\n}\nfunction _slicedToArray(arr, i) {\n  return _arrayWithHoles(arr) || _iterableToArrayLimit(arr, i) || _unsupportedIterableToArray(arr, i) || _nonIterableRest();\n}\nfunction _arrayWithHoles(arr) {\n  if (Array.isArray(arr)) return arr;\n}\nfunction _unsupportedIterableToArray(o, minLen) {\n  if (!o) return;\n  if (typeof o === \"string\") return _arrayLikeToArray(o, minLen);\n  var n = Object.prototype.toString.call(o).slice(8, -1);\n  if (n === \"Object\" && o.constructor) n = o.constructor.name;\n  if (n === \"Map\" || n === \"Set\") return Array.from(o);\n  if (n === \"Arguments\" || /^(?:Ui|I)nt(?:8|16|32)(?:Clamped)?Array$/.test(n)) return _arrayLikeToArray(o, minLen);\n}\nfunction _arrayLikeToArray(arr, len) {\n  if (len == null || len > arr.length) len = arr.length;\n  for (var i = 0, arr2 = new Array(len); i < len; i++) arr2[i] = arr[i];\n  return arr2;\n}\nfunction _nonIterableRest() {\n  throw new TypeError(\"Invalid attempt to destructure non-iterable instance.\\nIn order to be iterable, non-array objects must have a [Symbol.iterator]() method.\");\n}\n\nvar Types = {\n  STRING: \"string\",\n  INT: \"number\",\n  BOOL: \"boolean\"\n};\nvar DomProperties = {};\nvar createRecord = function createRecord(attrName, propName, type) {\n  return {\n    attrName: attrName,\n    propName: propName,\n    type: type\n  };\n};\nvar stringProps = [[\"style\", \"cssText\"], [\"class\", \"className\"]];\nforEach(stringProps, function (_ref) {\n  var _ref2 = _slicedToArray(_ref, 2),\n    attr = _ref2[0],\n    property = _ref2[1];\n  DomProperties[attr] = createRecord(attr, property || attr, Types.STRING);\n});\nvar booleanProps = [\"autofocus\", \"draggable\", \"hidden\", \"checked\", \"multiple\", \"muted\", \"selected\"];\nforEach(booleanProps, function (attr) {\n  DomProperties[attr] = createRecord(attr, attr, Types.BOOL);\n});\nvar integerProps = [[\"tabindex\", \"tabIndex\"]];\nforEach(integerProps, function (_ref3) {\n  var _ref4 = _slicedToArray(_ref3, 2),\n    attr = _ref4[0],\n    property = _ref4[1];\n  DomProperties[attr] = createRecord(attr, property, Types.INT);\n});\nvar Namespace = {\n  xlink: {\n    prefix: \"xlink:\",\n    resource: \"http://www.w3.org/1999/xlink\"\n  },\n  xml: {\n    prefix: \"xml:\",\n    resource: \"http://www.w3.org/XML/1998/namespace\"\n  }\n};\n\nvar setProperty = function setProperty(element, type, prop, value) {\n  switch (type) {\n    case Types.STRING:\n      {\n        if (prop === DomProperties.style.propName) {\n          if (value === null) {\n            element.style[prop] = \"\";\n          } else {\n            element.style[prop] = value;\n          }\n        } else if (value === null) {\n          element[prop] = \"\";\n        } else {\n          element[prop] = value;\n        }\n        break;\n      }\n    case Types.INT:\n      {\n        if (value === null) {\n          var attr = prop.toLowerCase();\n          element.removeAttribute(attr);\n        } else if (value === \"0\") {\n          element[prop] = 0;\n        } else if (value === \"-1\") {\n          element[prop] = -1;\n        } else {\n          var parsed = parseInt(value, 10);\n          if (!isNaN(parsed)) {\n            element[prop] = parsed;\n          }\n        }\n        break;\n      }\n    case Types.BOOL:\n      {\n        if ([\"\", \"true\"].indexOf(value) < 0) {\n          element[prop] = false;\n        } else {\n          element[prop] = true;\n        }\n        break;\n      }\n  }\n};\n\nvar removeAttributes = function removeAttributes(vNode, attributes) {\n  forEach(attributes, function (attrName) {\n    if (hasProperty(DomProperties, attrName)) {\n      var propertyRecord = DomProperties[attrName];\n      setProperty(vNode.node, propertyRecord.type, propertyRecord.propName, null);\n    } else {\n      if (attrName in vNode.node) {\n        setProperty(vNode.node, Types.STRING, attrName, null);\n      }\n      vNode.node.removeAttribute(attrName);\n    }\n    delete vNode.attributes[attrName];\n  });\n};\nvar setAttributes = function setAttributes(vNode, attributes) {\n  for (var attrName in attributes) {\n    var value = attributes[attrName];\n    vNode.attributes[attrName] = value;\n    if (hasProperty(DomProperties, attrName)) {\n      var propertyRecord = DomProperties[attrName];\n      setProperty(vNode.node, propertyRecord.type, propertyRecord.propName, value);\n      continue;\n    }\n    if (attrName.startsWith(Namespace.xlink.prefix)) {\n      vNode.node.setAttributeNS(Namespace.xlink.resource, attrName, value);\n      continue;\n    }\n    if (attrName.startsWith(Namespace.xml.prefix)) {\n      vNode.node.setAttributeNS(Namespace.xml.resource, attrName, value);\n      continue;\n    }\n    if (attrName in vNode.node) {\n      setProperty(vNode.node, Types.STRING, attrName, value);\n    }\n    vNode.node.setAttribute(attrName, value || \"\");\n  }\n};\nvar getPropertyValues = function getPropertyValues(element, attributes) {\n  for (var attrName in DomProperties) {\n    var propertyRecord = DomProperties[attrName];\n    var propName = propertyRecord.propName;\n    var attrValue = element.getAttribute(attrName);\n    if (attrName === DomProperties.style.attrName) {\n      attributes[attrName] = element.style[propName];\n    } else if (typeof attrValue === \"string\") {\n      attributes[attrName] = attrValue;\n    }\n  }\n};\nvar getBaseAttributes = function getBaseAttributes(element) {\n  return Array.prototype.reduce.call(element.attributes, function (attributes, attrName) {\n    if (!hasProperty(DomProperties, attrName.name)) {\n      attributes[attrName.name] = attrName.value;\n    }\n    return attributes;\n  }, {});\n};\nvar getAttributes = function getAttributes(element) {\n  var attributes = getBaseAttributes(element);\n  getPropertyValues(element, attributes);\n  return attributes;\n};\nvar updateAttributes = function updateAttributes(template, vNode) {\n  var removedAttributes = [];\n  var changedAttributes = {};\n  for (var attrName in vNode.attributes) {\n    var oldValue = vNode.attributes[attrName];\n    var nextValue = template.attributes[attrName];\n    if (oldValue === nextValue) continue;\n    if (typeof nextValue === \"undefined\") {\n      removedAttributes.push(attrName);\n    }\n  }\n  for (var _attrName in template.attributes) {\n    var _oldValue = vNode.attributes[_attrName];\n    var _nextValue = template.attributes[_attrName];\n    if (_oldValue === _nextValue) continue;\n    if (typeof _nextValue !== \"undefined\") {\n      changedAttributes[_attrName] = _nextValue;\n    }\n  }\n  removeAttributes(vNode, removedAttributes);\n  setAttributes(vNode, changedAttributes);\n};\n\nvar DATA_KEY_ATTRIBUTE = \"data-key\";\nfunction patchChildren(template, vNode, patch) {\n  var templateChildrenLength = template.children.length;\n  var vNodeChildrenLength = vNode.children.length;\n  if (!templateChildrenLength && !vNodeChildrenLength) return;\n  var vNodeKeyMap = createKeyMap(vNode.children);\n  var nextChildren = Array(templateChildrenLength);\n  if (vNodeKeyMap !== undefined) {\n    forEach(template.children, function (templateChild, idx) {\n      var childNodes = vNode.node.childNodes;\n      var key = templateChild.attributes[DATA_KEY_ATTRIBUTE];\n      if (Object.prototype.hasOwnProperty.call(vNodeKeyMap, key)) {\n        var keyedChild = vNodeKeyMap[key];\n        if (Array.prototype.indexOf.call(childNodes, keyedChild.node) !== idx) {\n          insertBefore(vNode, keyedChild, childNodes[idx]);\n        }\n        nextChildren[idx] = keyedChild;\n        delete vNodeKeyMap[key];\n        patch(templateChild, nextChildren[idx]);\n      } else {\n        insertBefore(vNode, templateChild, childNodes[idx]);\n        nextChildren[idx] = templateChild;\n      }\n    });\n  } else {\n    forEach(template.children, function (templateChild, idx) {\n      var vNodeChild = vNode.children[idx];\n      if (typeof vNodeChild !== \"undefined\") {\n        patch(templateChild, vNodeChild);\n        nextChildren[idx] = vNodeChild;\n      } else {\n        vNode.node.appendChild(templateChild.node);\n        nextChildren[idx] = templateChild;\n      }\n    });\n  }\n  vNode.children = nextChildren;\n  var childNodesLength = vNode.node.childNodes.length;\n  var delta = childNodesLength - templateChildrenLength;\n  if (delta > 0) {\n    while (delta > 0) {\n      vNode.node.removeChild(vNode.node.childNodes[childNodesLength - 1]);\n      childNodesLength--;\n      delta--;\n    }\n  }\n}\n\nvar patch = function patch(template, vNode, rootNode) {\n  if (!template || !vNode) return;\n  rootNode = rootNode || vNode.node.parentNode;\n  var contentChanged = template.content && template.content !== vNode.content;\n  if (template.type !== vNode.type || contentChanged) {\n    rootNode.replaceChild(template.node, vNode.node);\n    return assignVNode(template, vNode);\n  }\n  updateAttributes(template, vNode);\n  patchChildren(template, vNode, patch);\n};\nvar render = function render(vNode, root) {\n  root.appendChild(vNode.node);\n};\nvar create = function create(node) {\n  var isSVGContext = arguments.length > 1 && arguments[1] !== undefined ? arguments[1] : false;\n  if (typeof node === \"string\") {\n    node = toHTML(node);\n  }\n  var isRoot = node.tagName === \"BODY\";\n  var childNodes = node.childNodes;\n  var numChildNodes = childNodes ? childNodes.length : 0;\n  if (isRoot) {\n    if (numChildNodes > 1) {\n      throw new Error(\"[OmDomDom]: Your element should not have more than one root node.\");\n    } else if (numChildNodes === 0) {\n      throw new Error(\"[OmDomDom]: Your element should have at least one root node.\");\n    } else {\n      return create(childNodes[0]);\n    }\n  }\n  var type = node.nodeType === 3 ? \"text\" : node.nodeType === 8 ? \"comment\" : node.tagName.toLowerCase();\n  var isSVG = isSVGContext || type === \"svg\";\n  var attributes = node.nodeType === 1 ? getAttributes(node) : {};\n  var content = numChildNodes > 0 ? null : node.textContent;\n  var children = Array(numChildNodes);\n  forEach(childNodes, function (child, idx) {\n    children[idx] = create(child, isSVG);\n  });\n  return {\n    type: type,\n    attributes: attributes,\n    children: children,\n    content: content,\n    node: node,\n    isSVGContext: isSVG\n  };\n};\n\n\n//# sourceMappingURL=omdomdom.es.js.map\n\n\n//# sourceURL=webpack://web-ui/./node_modules/omdomdom/lib/omdomdom.es.js?");--/***/ })--/******/ 	});-/************************************************************************/-/******/ 	// The module cache-/******/ 	var __webpack_module_cache__ = {};-/******/ 	-/******/ 	// The require function-/******/ 	function __webpack_require__(moduleId) {-/******/ 		// Check if module is in cache-/******/ 		var cachedModule = __webpack_module_cache__[moduleId];-/******/ 		if (cachedModule !== undefined) {-/******/ 			return cachedModule.exports;-/******/ 		}-/******/ 		// Create a new module (and put it into the cache)-/******/ 		var module = __webpack_module_cache__[moduleId] = {-/******/ 			// no module.id needed-/******/ 			// no module.loaded needed-/******/ 			exports: {}-/******/ 		};-/******/ 	-/******/ 		// Execute the module function-/******/ 		__webpack_modules__[moduleId](module, module.exports, __webpack_require__);-/******/ 	-/******/ 		// Return the exports of the module-/******/ 		return module.exports;-/******/ 	}-/******/ 	-/************************************************************************/-/******/ 	/* webpack/runtime/define property getters */-/******/ 	(() => {-/******/ 		// define getter functions for harmony exports-/******/ 		__webpack_require__.d = (exports, definition) => {-/******/ 			for(var key in definition) {-/******/ 				if(__webpack_require__.o(definition, key) && !__webpack_require__.o(exports, key)) {-/******/ 					Object.defineProperty(exports, key, { enumerable: true, get: definition[key] });-/******/ 				}-/******/ 			}-/******/ 		};-/******/ 	})();-/******/ 	-/******/ 	/* webpack/runtime/hasOwnProperty shorthand */-/******/ 	(() => {-/******/ 		__webpack_require__.o = (obj, prop) => (Object.prototype.hasOwnProperty.call(obj, prop))-/******/ 	})();-/******/ 	-/******/ 	/* webpack/runtime/make namespace object */-/******/ 	(() => {-/******/ 		// define __esModule on exports-/******/ 		__webpack_require__.r = (exports) => {-/******/ 			if(typeof Symbol !== 'undefined' && Symbol.toStringTag) {-/******/ 				Object.defineProperty(exports, Symbol.toStringTag, { value: 'Module' });-/******/ 			}-/******/ 			Object.defineProperty(exports, '__esModule', { value: true });-/******/ 		};-/******/ 	})();-/******/ 	-/************************************************************************/-/******/ 	-/******/ 	// startup-/******/ 	// Load entry module and return exports-/******/ 	// This entry module can't be inlined because the eval devtool is used.-/******/ 	var __webpack_exports__ = __webpack_require__("./src/index.ts");-/******/ 	-/******/ })()-;+/*! For license information please see hyperbole.js.LICENSE.txt */+(()=>{var e={296:e=>{function t(e,t=100,n={}){if("function"!=typeof e)throw new TypeError(`Expected the first parameter to be a function, got \`${typeof e}\`.`);if(t<0)throw new RangeError("`wait` must not be negative.");const{immediate:r}="boolean"==typeof n?{immediate:n}:n;let o,i,a,c,u;function s(){const t=o,n=i;return o=void 0,i=void 0,u=e.apply(t,n),u}function l(){const e=Date.now()-c;e<t&&e>=0?a=setTimeout(l,t-e):(a=void 0,r||(u=s()))}const d=function(...e){if(o&&this!==o&&Object.getPrototypeOf(this)===Object.getPrototypeOf(o))throw new Error("Debounced method called with different contexts of the same prototype.");o=this,i=e,c=Date.now();const n=r&&!a;return a||(a=setTimeout(l,t)),n&&(u=s()),u};return Object.defineProperty(d,"isPending",{get:()=>void 0!==a}),d.clear=()=>{a&&(clearTimeout(a),a=void 0)},d.flush=()=>{a&&d.trigger()},d.trigger=()=>{u=s(),d.clear()},d}e.exports.debounce=t,e.exports=t}},t={};function n(r){var o=t[r];if(void 0!==o)return o.exports;var i=t[r]={exports:{}};return e[r](i,i.exports,n),i.exports}(()=>{"use strict";var e=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},t=function(e,t){var n=e.length,r=-1;if(n)for(;++r<n&&!1!==t(e[r],r););},r=function(e,t,n){return e.node.insertBefore(t.node,n)};function o(e,t){return function(e){if(Array.isArray(e))return e}(e)||function(e,t){var n=null==e?null:"undefined"!=typeof Symbol&&e[Symbol.iterator]||e["@@iterator"];if(null!=n){var r,o,i,a,c=[],u=!0,s=!1;try{if(i=(n=n.call(e)).next,0===t){if(Object(n)!==n)return;u=!1}else for(;!(u=(r=i.call(n)).done)&&(c.push(r.value),c.length!==t);u=!0);}catch(e){s=!0,o=e}finally{try{if(!u&&null!=n.return&&(a=n.return(),Object(a)!==a))return}finally{if(s)throw o}}return c}}(e,t)||function(e,t){if(e){if("string"==typeof e)return i(e,t);var n=Object.prototype.toString.call(e).slice(8,-1);return"Object"===n&&e.constructor&&(n=e.constructor.name),"Map"===n||"Set"===n?Array.from(e):"Arguments"===n||/^(?:Ui|I)nt(?:8|16|32)(?:Clamped)?Array$/.test(n)?i(e,t):void 0}}(e,t)||function(){throw new TypeError("Invalid attempt to destructure non-iterable instance.\nIn order to be iterable, non-array objects must have a [Symbol.iterator]() method.")}()}function i(e,t){(null==t||t>e.length)&&(t=e.length);for(var n=0,r=new Array(t);n<t;n++)r[n]=e[n];return r}var a="string",c="number",u="boolean",s={},l=function(e,t,n){return{attrName:e,propName:t,type:n}};t([["style","cssText"],["class","className"]],(function(e){var t=o(e,2),n=t[0],r=t[1];s[n]=l(n,r||n,a)})),t(["autofocus","draggable","hidden","checked","multiple","muted","selected"],(function(e){s[e]=l(e,e,u)})),t([["tabindex","tabIndex"]],(function(e){var t=o(e,2),n=t[0],r=t[1];s[n]=l(n,r,c)}));var d="xlink:",f="http://www.w3.org/1999/xlink",v="xml:",h="http://www.w3.org/XML/1998/namespace",p=function(e,t,n,r){switch(t){case a:n===s.style.propName?e.style[n]=null===r?"":r:e[n]=null===r?"":r;break;case c:if(null===r){var o=n.toLowerCase();e.removeAttribute(o)}else if("0"===r)e[n]=0;else if("-1"===r)e[n]=-1;else{var i=parseInt(r,10);isNaN(i)||(e[n]=i)}break;case u:["","true"].indexOf(r)<0?e[n]=!1:e[n]=!0}},y=function n(o,i,c){if(o&&i){c=c||i.node.parentNode;var u=o.content&&o.content!==i.content;if(o.type!==i.type||u)return c.replaceChild(o.node,i.node),function(e,t){for(var n in e)t[n]=e[n]}(o,i);(function(n,r){var o=[],i={};for(var c in r.attributes){var u=r.attributes[c],l=n.attributes[c];u!==l&&void 0===l&&o.push(c)}for(var y in n.attributes){var m=r.attributes[y],b=n.attributes[y];m!==b&&void 0!==b&&(i[y]=b)}!function(n,r){t(r,(function(t){if(e(s,t)){var r=s[t];p(n.node,r.type,r.propName,null)}else t in n.node&&p(n.node,a,t,null),n.node.removeAttribute(t);delete n.attributes[t]}))}(r,o),function(t,n){for(var r in n){var o=n[r];if(t.attributes[r]=o,e(s,r)){var i=s[r];p(t.node,i.type,i.propName,o)}else r.startsWith(d)?t.node.setAttributeNS(f,r,o):r.startsWith(v)?t.node.setAttributeNS(h,r,o):(r in t.node&&p(t.node,a,r,o),t.node.setAttribute(r,o||""))}}(r,i)})(o,i),function(n,o,i){var a=n.children.length,c=o.children.length;if(a||c){var u=function(n){var r={};for(var o in t(n,(function(t){var n=t.attributes["data-key"];(function(t,n){return!(!n||e(t,n)&&(console.warn("[OmDomDom]: Children with duplicate keys detected. Children with duplicate keys will be skipped, resulting in dropped node references. Keys must be unique and non-indexed."),1))})(r,n)&&(r[n]=t)})),r)return r}(o.children),s=Array(a);t(n.children,void 0!==u?function(e,t){var n=o.node.childNodes,a=e.attributes["data-key"];if(Object.prototype.hasOwnProperty.call(u,a)){var c=u[a];Array.prototype.indexOf.call(n,c.node)!==t&&r(o,c,n[t]),s[t]=c,delete u[a],i(e,s[t])}else r(o,e,n[t]),s[t]=e}:function(e,t){var n=o.children[t];void 0!==n?(i(e,n),s[t]=n):(o.node.appendChild(e.node),s[t]=e)}),o.children=s;var l=o.node.childNodes.length,d=l-a;if(d>0)for(;d>0;)o.node.removeChild(o.node.childNodes[l-1]),l--,d--}}(o,i,n)}},m=function n(r){var o,i=arguments.length>1&&void 0!==arguments[1]&&arguments[1];"string"==typeof r&&(o=r.trim().replace(/\s+</g,"<").replace(/>\s+/g,">"),r=(new DOMParser).parseFromString(o,"text/html").body);var a="BODY"===r.tagName,c=r.childNodes,u=c?c.length:0;if(a){if(u>1)throw new Error("[OmDomDom]: Your element should not have more than one root node.");if(0===u)throw new Error("[OmDomDom]: Your element should have at least one root node.");return n(c[0])}var l=3===r.nodeType?"text":8===r.nodeType?"comment":r.tagName.toLowerCase(),d=i||"svg"===l,f=1===r.nodeType?function(t){var n=function(t){return Array.prototype.reduce.call(t.attributes,(function(t,n){return e(s,n.name)||(t[n.name]=n.value),t}),{})}(t);return function(e,t){for(var n in s){var r=s[n].propName,o=e.getAttribute(n);n===s.style.attrName?t[n]=e.style[r]:"string"==typeof o&&(t[n]=o)}}(t,n),n}(r):{},v=u>0?null:r.textContent,h=Array(u);return t(c,(function(e,t){h[t]=n(e,d)})),{type:l,attributes:f,children:h,content:v,node:r,isSVGContext:d}};function b(e){if(void 0===e&&(e=""),location.search!=e){""!=e&&(e="?"+e);var t=location.pathname+e;console.log("history.replaceState(",t,")"),window.history.replaceState({},"",t)}}var w=function(e,t,n,r){return new(n||(n=Promise))((function(o,i){function a(e){try{u(r.next(e))}catch(e){i(e)}}function c(e){try{u(r.throw(e))}catch(e){i(e)}}function u(e){var t;e.done?o(e.value):(t=e.value,t instanceof n?t:new n((function(e){e(t)}))).then(a,c)}u((r=r.apply(e,t||[])).next())}))},g=function(e,t){var n,r,o,i,a={label:0,sent:function(){if(1&o[0])throw o[1];return o[1]},trys:[],ops:[]};return i={next:c(0),throw:c(1),return:c(2)},"function"==typeof Symbol&&(i[Symbol.iterator]=function(){return this}),i;function c(c){return function(u){return function(c){if(n)throw new TypeError("Generator is already executing.");for(;i&&(i=0,c[0]&&(a=0)),a;)try{if(n=1,r&&(o=2&c[0]?r.return:c[0]?r.throw||((o=r.return)&&o.call(r),0):r.next)&&!(o=o.call(r,c[1])).done)return o;switch(r=0,o&&(c=[2&c[0],o.value]),c[0]){case 0:case 1:o=c;break;case 4:return a.label++,{value:c[1],done:!1};case 5:a.label++,r=c[1],c=[0];continue;case 7:c=a.ops.pop(),a.trys.pop();continue;default:if(!((o=(o=a.trys).length>0&&o[o.length-1])||6!==c[0]&&2!==c[0])){a=0;continue}if(3===c[0]&&(!o||c[1]>o[0]&&c[1]<o[3])){a.label=c[1];break}if(6===c[0]&&a.label<o[1]){a.label=o[1],o=c;break}if(o&&a.label<o[2]){a.label=o[2],a.ops.push(c);break}o[2]&&a.ops.pop(),a.trys.pop();continue}c=t.call(e,a)}catch(e){c=[6,e],r=0}finally{n=o=0}if(5&c[0])throw c[1];return{value:c[0]?c[1]:void 0,done:!0}}([c,u])}}},k="https:"===window.location.protocol?"wss:":"ws:",x="".concat(k,"//").concat(window.location.host).concat(window.location.pathname),E=function(){function e(){this.reconnectDelay=0}return e.prototype.connect=function(e){var t=this;void 0===e&&(e=x);var n=new WebSocket(e);function r(e){console.log("Connection Error",e)}this.socket=n,n.addEventListener("error",r),n.addEventListener("open",(function(e){console.log("Opened",e),t.isConnected=!0,t.hasEverConnected=!0,t.reconnectDelay=0,t.socket.removeEventListener("error",r)})),n.addEventListener("close",(function(n){t.isConnected=!1,console.log("Closed"),t.hasEverConnected&&(t.reconnectDelay+=1e3,console.log("Reconnecting in "+t.reconnectDelay/1e3+"s"),setTimeout((function(){return t.connect(e)}),t.reconnectDelay))}))},e.prototype.sendAction=function(e){return w(this,void 0,void 0,(function(){var t,n;return g(this,(function(r){switch(r.label){case 0:return t=[e.url.pathname+e.url.search,"Host: "+window.location.host,"Cookie: "+document.cookie,e.form].join("\n"),[4,this.fetch(e.id,t)];case 1:return(n=r.sent()).metadata,[2,n.rest]}}))}))},e.prototype.fetch=function(e,t){return w(this,void 0,void 0,(function(){return g(this,(function(n){switch(n.label){case 0:return this.sendMessage(t),[4,this.waitMessage(e)];case 1:return[2,n.sent()]}}))}))},e.prototype.sendMessage=function(e){this.socket.send(e)},e.prototype.waitMessage=function(e){return w(this,void 0,void 0,(function(){var t=this;return g(this,(function(n){return[2,new Promise((function(n,r){var o=function(r){var i,a,c=function(e){var t=e.split("\n"),n=function(e,t){for(var n=[],r=0,o=t;r<o.length;r++){var i=e(o[r]);if(!i)break;n.push(i)}return n}(o,t),r=function(e,t){for(var n=0;n<t.length&&e(t[n]);)n++;return t.slice(n)}(o,t).join("\n");return{metadata:C(n),rest:r};function o(e){var t=e.match(/^\|([A-Z\-]+)\|(.*)$/);if(t)return{key:t[1],value:t[2]}}}(r.data),u=c.metadata,s=c.rest;if(u.error)throw i=u.error,(a=new Error).name=i.substring(0,i.indexOf(" ")),a.message=i.substring(i.indexOf(" ")+1),a;u.cookies.forEach((function(e){document.cookie=e})),u.redirect?window.location.href=u.redirect:(b(u.query),u.viewId==e&&(n({metadata:u,rest:s}),t.socket.removeEventListener("message",o)))};t.socket.addEventListener("message",o),t.socket.addEventListener("error",r)}))]}))}))},e.prototype.disconnect=function(){this.socket.close()},e}();function C(e){var t,n,r,o;return{cookies:e.filter((function(e){return"COOKIE"==e.key})).map((function(e){return e.value})),redirect:null===(t=e.find((function(e){return"REDIRECT"==e.key})))||void 0===t?void 0:t.value,error:null===(n=e.find((function(e){return"ERROR"==e.key})))||void 0===n?void 0:n.value,viewId:null===(r=e.find((function(e){return"VIEW-ID"==e.key})))||void 0===r?void 0:r.value,query:null===(o=e.find((function(e){return"QUERY"==e.key})))||void 0===o?void 0:o.value}}var D=n(296);function O(e,t){document.addEventListener(e.toLowerCase(),(function(n){var r=n.target,o="on"+e+n.key,i=r.dataset[o];i&&(n.preventDefault(),t(L(r),i))}))}function S(e){e.querySelectorAll("[data-on-load]").forEach((function(e){var t=parseInt(e.dataset.delay)||0;setTimeout((function(){var t=new CustomEvent("hyp-load",{bubbles:!0,detail:{target:L(e)}});e.dispatchEvent(t)}),t)}))}function L(e){var t=function(e){var t,n=e.closest("[data-target]");return(null==n?void 0:n.dataset.target)||(null===(t=e.closest("[id]"))||void 0===t?void 0:t.id)}(e),n=document.getElementById(t);if(n)return n;console.error("Cannot find target: ",e)}function T(e){if(e){var t=new URLSearchParams;return e.forEach((function(e,n){t.append(n,e)})),t}}function A(e,t,n){var r=function(e,t){var n=new URL(window.location.href);return n.searchParams.append("hyp-id",e),n.searchParams.append("hyp-action",t),n}(e,t);return{id:e,url:r,form:T(n)}}var I,N=function(e,t,n,r){return new(n||(n=Promise))((function(o,i){function a(e){try{u(r.next(e))}catch(e){i(e)}}function c(e){try{u(r.throw(e))}catch(e){i(e)}}function u(e){var t;e.done?o(e.value):(t=e.value,t instanceof n?t:new n((function(e){e(t)}))).then(a,c)}u((r=r.apply(e,t||[])).next())}))},P=function(e,t){var n,r,o,i,a={label:0,sent:function(){if(1&o[0])throw o[1];return o[1]},trys:[],ops:[]};return i={next:c(0),throw:c(1),return:c(2)},"function"==typeof Symbol&&(i[Symbol.iterator]=function(){return this}),i;function c(c){return function(u){return function(c){if(n)throw new TypeError("Generator is already executing.");for(;i&&(i=0,c[0]&&(a=0)),a;)try{if(n=1,r&&(o=2&c[0]?r.return:c[0]?r.throw||((o=r.return)&&o.call(r),0):r.next)&&!(o=o.call(r,c[1])).done)return o;switch(r=0,o&&(c=[2&c[0],o.value]),c[0]){case 0:case 1:o=c;break;case 4:return a.label++,{value:c[1],done:!1};case 5:a.label++,r=c[1],c=[0];continue;case 7:c=a.ops.pop(),a.trys.pop();continue;default:if(!((o=(o=a.trys).length>0&&o[o.length-1])||6!==c[0]&&2!==c[0])){a=0;continue}if(3===c[0]&&(!o||c[1]>o[0]&&c[1]<o[3])){a.label=c[1];break}if(6===c[0]&&a.label<o[1]){a.label=o[1],o=c;break}if(o&&a.label<o[2]){a.label=o[2],a.ops.push(c);break}o[2]&&a.ops.pop(),a.trys.pop();continue}c=t.call(e,a)}catch(e){c=[6,e],r=0}finally{n=o=0}if(5&c[0])throw c[1];return{value:c[0]?c[1]:void 0,done:!0}}([c,u])}}};console.log("Hyperbole 0.4.2");var j=new Set;function R(e){return N(this,void 0,void 0,(function(){function t(e){return N(this,void 0,void 0,(function(){var t,n,r;return P(this,(function(o){switch(o.label){case 0:return[4,fetch(e.url,{method:"POST",headers:{Accept:"text/html","Content-Type":"application/x-www-form-urlencoded"},body:e.form,redirect:"manual"})];case 1:return(t=o.sent()).headers.get("location")?(console.log("Found Redirect",t.headers.get("location")),window.location.href=t.headers.get("location"),[2]):t.headers.get("location")?(window.location.href=t.headers.get("location"),[2]):(b(t.headers.get("set-query")),t.ok?[3,3]:((n=new Error).name="Fetch Error "+t.status,[4,t.text()]));case 2:throw r=o.sent(),n.message=r,n;case 3:return[2,t.text()]}}))}))}return P(this,(function(n){return B.isConnected?[2,B.sendAction(e)]:[2,t(e)]}))}))}function M(e){return N(this,void 0,void 0,(function(){var t;return P(this,(function(n){switch(n.label){case 0:return n.trys.push([0,2,,3]),[4,R(e)];case 1:return[2,n.sent()];case 2:throw t=n.sent(),document.body.innerHTML=(o=[".hyp-error {background-color:#DB3524; color:white; padding: 10px}",".hyp-details {padding: 10px}"],i="<div class='hyp-error'>".concat((r=t).name,"</div>"),a="<div class='hyp-details'>".concat(r.message,"</div>"),["<style>"+o.join("\n")+"</style>",i,a].join("\n")),t;case 3:return[2]}var r,o,i,a}))}))}function q(e,t,n){return N(this,void 0,void 0,(function(){var r,o,i,a;return P(this,(function(c){switch(c.label){case 0:return r=setTimeout((function(){e.classList.add("hyp-loading")}),200),[4,M(A(e.id,t,n))];case 1:return u=c.sent(),l=(s=(new DOMParser).parseFromString(u,"text/html")).querySelector("style"),(o={content:s.querySelector("div"),css:l}).css&&o.content?(function(e){for(var t=0,n=e.sheet.cssRules;t<n.length;t++){var r=n[t];0==j.has(r.cssText)&&(I.sheet.insertRule(r.cssText),j.add(r.cssText))}}(o.css),i=m(o.content),a=m(e),y(i,a),S(document.getElementById(e.id)),clearTimeout(r),e.classList.remove("hyp-loading"),[2]):(console.error("Empty Response",o),[2])}var u,s,l}))}))}document.addEventListener("DOMContentLoaded",(function(){var e;I=document.querySelector("style"),e=function(e,t){return N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))},document.addEventListener("hyp-load",(function(t){var n=t.target.dataset.onLoad,r=t.detail.target;e(r,n)})),S(document.body),document.addEventListener("click",(function(e){var t=e.target.closest("[data-on-click]");t&&(e.preventDefault(),function(e,t){N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))}(L(t),t.dataset.onClick))})),document.addEventListener("dblclick",(function(e){var t=e.target.closest("[data-on-dblclick]");t&&(e.preventDefault(),function(e,t){N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))}(L(t),t.dataset.onDblclick))})),O("Keydown",(function(e,t){return N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))})),O("Keyup",(function(e,t){return N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))})),document.addEventListener("submit",(function(e){var t=e.target;if(null==t?void 0:t.dataset.onSubmit){e.preventDefault();var n=L(t),r=new FormData(t);!function(e,t,n){N(this,void 0,void 0,(function(){return P(this,(function(r){return q(e,t,n),[2]}))}))}(n,t.dataset.onSubmit,r)}else console.error("Missing onSubmit: ",t)})),document.addEventListener("change",(function(e){var t=e.target.closest("[data-on-change]");t&&(e.preventDefault(),t.value?function(e,t){N(this,void 0,void 0,(function(){return P(this,(function(n){return q(e,t),[2]}))}))}(L(t),t.value):console.error("Missing input value:",t))})),document.addEventListener("input",(function(e){var t=e.target.closest("[data-on-input]");if(t){var n=parseInt(t.dataset.delay)||250;if(n<250&&console.warn("Input delay < 100 can result in poor performance."),null==t?void 0:t.dataset.onInput){e.preventDefault();var r=L(t);t.debouncedCallback||(t.debouncedCallback=D((function(){return function(e,t,n){return N(this,void 0,void 0,(function(){var r;return P(this,(function(o){return r="".concat(t,' "').concat(n.replace(/\\/g,"\\\\").replace(/"/g,'\\"'),'"'),q(e,r),[2]}))}))}(r,t.dataset.onInput,t.value)}),n)),t.debouncedCallback()}else console.error("Missing onInput: ",t)}}))}));var B=new E;B.connect()})()})();+//# sourceMappingURL=hyperbole.js.map
− example/BulkUpdate.hs 
@@ -1,66 +0,0 @@-module BulkUpdate where---- import Control.Monad (forM_)--- import Control.Monad.IO.Class (liftIO)--- import Data.Text (pack)--- import Example.Colors--- import Example.Effects.Users (User (..), UserStore)--- import Example.Effects.Users qualified as Users--- import Web.Htmx--- import Web.Hyperbole (view)--- import Web.Hyperbole.Htmx--- import Web.Scotty hiding (text)--- import Web.UI------ route :: UserStore -> ScottyM ()--- route st = do---   get "/contacts/" $ do---     us <- Users.all st---     view $ viewMain us------   -- scotty doesn't support multiple ids :(---   post "/contacts/activate" $ do---     ids <- param "ids" :: ActionM [Int]---     liftIO $ print ids---     forM_ ids $ \uid ->---       Users.modify st uid $ \u -> u{isActive = True}---     us <- Users.all st---     view $ viewUsers us------   post "/contacts/deactivate" $ do---     ids <- param "ids" :: ActionM [Int]---     liftIO $ print ids---     forM_ ids $ \uid ->---       Users.modify st uid $ \u -> u{isActive = False}---     us <- Users.all st---     view $ viewUsers us------ viewMain :: [User] -> View ()--- viewMain users = do---   row (hxTarget (Query (Id "table")) . hxSwap OuterHTML . hxInclude (Id "form")) $ do---     col (pad 20 . width 500) $ do---       button (hxPost ("contacts" // "activate")) "Activate"---       button (hxPost ("contacts" // "deactivate")) "Deactivate"------     form (grow . pad 10 . att "id" "form") $ do---       viewUsers users------ viewUsers :: [User] -> View ()--- viewUsers users = do---   table (border 1 . att "id" "table") users $ do---     tcol (cell . width 20) none $ \u -> do---       input (att "type" "checkbox" . name "ids" . value (pack $ show u.id))------     tcol cell (hd "First Name") $ \u -> do---       el (if u.isActive then bold else id) $ text u.firstName------     tcol cell (hd "Last Name") $ \u -> do---       text u.lastName------     tcol cell (hd "Email") $ \u -> do---       text u.email---  where---   cell = pad 4 . border 1 . borderColor GrayLight---   hd = el bold------ --
− example/Example/Colors.hs 
@@ -1,47 +0,0 @@-module Example.Colors where--import Data.String.Conversions-import Text.Read (readMaybe)-import Web.HttpApiData-import Web.Hyperbole---data AppColor-  = White-  | Light-  | GrayLight-  | GrayDark-  | Dark-  | Success-  | Danger-  | Warning-  | Primary-  | PrimaryLight-  | Secondary-  | SecondaryLight-  deriving (Show, Read, Generic, Param)---instance ToHttpApiData AppColor where-  toQueryParam c = cs (show c)-instance FromHttpApiData AppColor where-  parseQueryParam t = do-    case readMaybe (cs t) of-      Nothing -> Left $ "Invalid AppColor: " <> t-      (Just c) -> pure c---instance ToColor AppColor where-  colorValue White = "#FFF"-  colorValue Light = "#F2F2F3"-  colorValue GrayLight = "#E3E5E9"-  colorValue GrayDark = "#2С3С44"-  colorValue Dark = "#2E3842" -- "#232C41"-  colorValue Primary = "#4171b7"-  colorValue PrimaryLight = "#6D9BD3"-  colorValue Secondary = "#5D5A5C"-  colorValue SecondaryLight = "#9D999C"-  -- colorValue Success = "67C837"-  colorValue Success = "#149e5a"-  colorValue Danger = "#ef1509"-  colorValue Warning = "#e1c915"
− example/Example/Contacts.hs 
@@ -1,194 +0,0 @@-module Example.Contacts where--import Control.Monad (forM_)-import Data.String.Conversions-import Data.Text (Text)-import Effectful-import Effectful.Dispatch.Dynamic-import Example.Colors-import Example.Effects.Debug-import Example.Effects.Users (User (..), Users)-import Example.Effects.Users qualified as Users-import Example.Style as Style-import Web.Hyperbole---page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es Response-page = do-  handle contacts-  handle contact-  load $ do-    us <- usersAll-    pure $ do-      col (pad 10 . gap 10) $ do-        hyper Contacts $ allContactsView Nothing us----- Contacts ------------------------------------------------data Contacts = Contacts-  deriving (Generic, Param)---data ContactsAction-  = Reload (Maybe Filter)-  | Delete Int-  deriving (Generic, Param)---data Filter-  = Active-  | Inactive-  deriving (Eq, Generic, Param)---instance HyperView Contacts where-  type Action Contacts = ContactsAction---contacts :: (Hyperbole :> es, Users :> es, Debug :> es) => Contacts -> ContactsAction -> Eff es (View Contacts ())-contacts _ (Reload mf) = do-  us <- usersAll-  pure $ allContactsView mf us-contacts _ (Delete uid) = do-  userDelete uid-  us <- usersAll-  pure $ allContactsView Nothing us---allContactsView :: Maybe Filter -> [User] -> View Contacts ()-allContactsView fil us = do-  row (gap 10) $ do-    el (pad 10) "Filter: "-    dropdown Reload (== fil) id $ do-      option Nothing ""-      option (Just Active) "Active!"-      option (Just Inactive) "Inactive"--  row (pad 10 . gap 10) $ do-    let filtered = filter (filterUsers fil) us-    forM_ filtered $ \u -> do-      el (border 1) $ do-        hyper (Contact u.id) $ contactView u--  row (gap 10) $ do-    button (Reload Nothing) Style.btnLight "Reload"-    target (Contact 2) $ button Edit Style.btnLight "Edit Sara"- where-  filterUsers Nothing _ = True-  filterUsers (Just Active) u = u.isActive-  filterUsers (Just Inactive) u = not u.isActive----- Contact ------------------------------------------------------data Contact = Contact Int-  deriving (Generic, Param)---data ContactAction-  = Edit-  | Save-  | View-  deriving (Generic, Param)---instance HyperView Contact where-  type Action Contact = ContactAction----- Form Fields-data FirstName = FirstName Text deriving (Generic, FormField)-data LastName = LastName Text deriving (Generic, FormField)-data Age = Age Int deriving (Generic, FormField)---contact :: (Hyperbole :> es, Users :> es, Debug :> es) => Contact -> ContactAction -> Eff es (View Contact ())-contact (Contact uid) a = do-  -- Lookup the user in the database for all actions-  u <- userFind uid-  action u a- where-  action u View = do-    pure $ contactView u-  action u Edit = do-    pure $ contactEdit u-  action _ Save = do-    delay 1000-    unew <- parseUser-    userSave unew-    pure $ contactView unew--  parseUser = do-    FirstName firstName <- formField @FirstName-    LastName lastName <- formField @LastName-    Age age <- formField @Age-    pure User{id = uid, isActive = True, firstName, lastName, age}---contactView :: User -> View Contact ()-contactView u = do-  col (pad 10 . gap 10) $ do-    row fld $ do-      el id (text "First Name:")-      text u.firstName--    row fld $ do-      el id (text "Last Name:")-      text u.lastName--    row fld $ do-      el id (text "Age:")-      text (cs $ show u.age)--    row fld $ do-      el id (text "Active:")-      text (cs $ show u.isActive)--    button Edit Style.btn "Edit"- where-  fld = gap 10---contactEdit :: User -> View Contact ()-contactEdit u =-  onRequest loading $ do-    form Save mempty (pad 10 . gap 10) $ do-      field @FirstName fld id $ do-        label "First Name:"-        input Name (value u.firstName)--      field @LastName fld id $ do-        label "Last Name:"-        input Name (value u.lastName)--      field @Age fld id $ do-        label "Age:"-        input Number (value $ cs $ show u.age)--      submit Style.btn "Submit"--      button View Style.btnLight (text "Cancel")--      target Contacts $ button (Delete u.id) (Style.btn' Danger) (text "Delete")- where-  loading = el (bg Warning . pad 10) "Loading..."-  fld = flexRow . gap 10---userFind :: (Hyperbole :> es, Users :> es) => Int -> Eff es User-userFind uid = do-  mu <- send (Users.LoadUser uid)-  maybe notFound pure mu---usersAll :: (Users :> es) => Eff es [User]-usersAll = send Users.LoadUsers---userSave :: (Users :> es) => User -> Eff es ()-userSave = send . Users.SaveUser---userDelete :: (Users :> es) => Int -> Eff es ()-userDelete = send . Users.DeleteUser
− example/Example/Counter.hs 
@@ -1,62 +0,0 @@-module Example.Counter where--import Data.Text (pack)-import Effectful-import Effectful.Concurrent.STM-import Example.Style as Style-import Web.Hyperbole----- We are using a TVar to manage our state--- In normal web applications, state will be managed in a database, abstracted behind a custom Effect. See Example.EFfects.Users for the interface--- Optionally, the count could be stored in a session. See Example.Sessions-page :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Page es Response-page var = do-  handle $ counter var--  load $ do-    n <- readTVarIO var-    pure $ col (pad 20 . gap 10) $ do-      el h1 "Counter"-      hyper Counter (viewCount n)---data Counter = Counter-  deriving (Generic, Param)-instance HyperView Counter where-  type Action Counter = Count---data Count-  = Increment-  | Decrement-  deriving (Generic, Param)---counter :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Counter -> Count -> Eff es (View Counter ())-counter var _ Increment = do-  n <- modify var $ \n -> n + 1-  pure $ viewCount n-counter var _ Decrement = do-  n <- modify var $ \n -> n - 1-  pure $ viewCount n---viewCount :: Int -> View Counter ()-viewCount n = col (gap 10) $ do-  row id $ do-    el (bold . fontSize 48 . border 1 . pad (XY 20 0)) $ text $ pack $ show n-  row (gap 10) $ do-    button Decrement Style.btn "Decrement"-    button Increment Style.btn "Increment"---modify :: (Concurrent :> es) => TVar Int -> (Int -> Int) -> Eff es Int-modify var f =-  atomically $ do-    modifyTVar var f-    readTVar var---initCounter :: (Concurrent :> es) => Eff es (TVar Int)-initCounter = newTVarIO 0
− example/Example/Effects/Debug.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE QuasiQuotes #-}--module Example.Effects.Debug where--import Control.Concurrent (threadDelay)-import Data.String.Interpolate (i)-import Effectful-import Effectful.Dispatch.Dynamic---type Milliseconds = Int-data Debug :: Effect where-  Dump :: (Show a) => String -> a -> Debug m ()-  Delay :: Milliseconds -> Debug m ()---type instance DispatchOf Debug = 'Dynamic---runDebugIO-  :: (IOE :> es)-  => Eff (Debug : es) a-  -> Eff es a-runDebugIO = interpret $ \_ -> \case-  Dump msg a -> do-    liftIO $ putStrLn [i| [#{msg}] #{show a}|]-  Delay ms -> liftIO $ threadDelay (ms * 1000)---dump :: (Debug :> es, Show a) => String -> a -> Eff es ()-dump msg a = send $ Dump msg a---delay :: (Debug :> es) => Milliseconds -> Eff es ()-delay n = send $ Delay n
− example/Example/Effects/Users.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE LambdaCase #-}--module Example.Effects.Users where--import Control.Concurrent.MVar-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as M-import Data.Text (Text)-import Effectful-import Effectful.Dispatch.Dynamic---data User = User-  { id :: Int-  , firstName :: Text-  , lastName :: Text-  , age :: Int-  , isActive :: Bool-  }-  deriving (Show)----- Load a user AND do next if missing?-data Users :: Effect where-  LoadUser :: Int -> Users m (Maybe User)-  LoadUsers :: Users m [User]-  SaveUser :: User -> Users m ()-  ModifyUser :: Int -> (User -> User) -> Users m ()-  DeleteUser :: Int -> Users m ()---type instance DispatchOf Users = 'Dynamic---type UserStore = MVar (Map Int User)---runUsersIO-  :: (IOE :> es)-  => UserStore-  -> Eff (Users : es) a-  -> Eff es a-runUsersIO var = interpret $ \_ -> \case-  LoadUser uid -> load uid-  LoadUsers -> loadAll-  SaveUser u -> save u-  ModifyUser uid f -> modify uid f-  DeleteUser uid -> delete uid- where-  load :: (MonadIO m) => Int -> m (Maybe User)-  load uid = do-    us <- liftIO $ readMVar var-    pure $ M.lookup uid us--  save :: (MonadIO m) => User -> m ()-  save u = do-    liftIO $ modifyMVar_ var $ \us -> pure $ M.insert u.id u us--  loadAll :: (MonadIO m) => m [User]-  loadAll = do-    us <- liftIO $ readMVar var-    pure $ M.elems us--  modify :: (MonadIO m) => Int -> (User -> User) -> m ()-  modify uid f = liftIO $ do-    modifyMVar_ var $ \us -> do-      pure $ M.adjust f uid us--  delete :: (MonadIO m) => Int -> m ()-  delete uid = do-    liftIO $ modifyMVar_ var $ \us -> pure $ M.delete uid us---initUsers :: (MonadIO m) => m UserStore-initUsers =-  liftIO $ newMVar $ M.fromList $ map (\u -> (u.id, u)) users- where-  users =-    [ User 1 "Joe" "Blow" 32 True-    , User 2 "Sara" "Dane" 24 False-    , User 3 "Billy" "Bob" 48 False-    , User 4 "Felicia" "Korvus" 84 True-    ]
− example/Example/Errors.hs 
@@ -1,41 +0,0 @@-module Example.Errors where--import Effectful-import Example.Style as Style-import Web.Hyperbole----- this is already running in a different context-page :: (Hyperbole :> es) => Page es Response-page = do-  handle content--  load $ do-    pure $ row (pad 20) $ do-      col (gap 10 . border 1) $ do-        hyper Contents viewContent---data Contents = Contents-  deriving (Generic, Param)---data ContentsAction-  = CauseError-  deriving (Generic, Param)---instance HyperView Contents where-  type Action Contents = ContentsAction---content :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ())-content _ CauseError = do-  -- Return a not found error 404-  notFound---viewContent :: View Contents ()-viewContent = do-  col (gap 10 . pad 20) $ do-    button CauseError Style.btn "Not Found Error"
− example/Example/Forms.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Example.Forms where--import Data.Text as T (Text, elem, length, pack)-import Effectful-import Example.Style qualified as Style-import Web.Hyperbole---page :: (Hyperbole :> es) => Page es Response-page = do-  handle formAction--  load $ do-    pure $ row (pad 20) $ do-      hyper FormView (formView mempty)---data FormView = FormView-  deriving (Generic, Param)---data FormAction = Submit-  deriving (Generic, Param)---instance HyperView FormView where-  type Action FormView = FormAction----- Form Fields-data User = User Text deriving (Generic, FormField)-data Age = Age Int deriving (Generic, FormField)-data Pass1 = Pass1 Text deriving (Generic, FormField)-data Pass2 = Pass2 Text deriving (Generic, FormField)---formAction :: (Hyperbole :> es) => FormView -> FormAction -> Eff es (View FormView ())-formAction _ Submit = do-  u <- formField @User-  a <- formField @Age-  p1 <- formField @Pass1-  p2 <- formField @Pass2--  case validateUser u a p1 p2 of-    Validation [] -> pure $ userView u a p1-    errs -> pure $ formView errs---validateUser :: User -> Age -> Pass1 -> Pass2 -> Validation-validateUser (User u) (Age a) (Pass1 p1) (Pass2 p2) =-  validation-    [ validate @Age (a < 20) "User must be at least 20 years old"-    , validate @User (T.elem ' ' u) "Username must not contain spaces"-    , validate @User (T.length u < 4) "Username must be at least 4 chars"-    , validate @Pass1 (p1 /= p2) "Passwords did not match"-    , validate @Pass1 (T.length p1 < 8) "Password must be at least 8 chars"-    ]---formView :: Validation -> View FormView ()-formView v = do-  form Submit v (gap 10 . pad 10) $ do-    el Style.h1 "Sign Up"--    field @User id Style.invalid $ do-      label "Username"-      input Username (inp . placeholder "username")-      el_ invalidText--    field @Age id Style.invalid $ do-      label "Age"-      input Number (inp . placeholder "age" . value "0")-      el_ invalidText--    field @Pass1 id Style.invalid $ do-      label "Password"-      input NewPassword (inp . placeholder "password")-      el_ invalidText--    field @Pass2 id id $ do-      label "Repeat Password"-      input NewPassword (inp . placeholder "repeat password")--    submit Style.btn "Submit"- where-  inp = border 1 . pad 8-----userView :: User -> Age -> Pass1 -> View FormView ()-userView (User user) (Age age) (Pass1 pass1) = do-  el (bold . Style.success) "Accepted Signup"-  row (gap 5) $ do-    el_ "Username:"-    el_ $ text user--  row (gap 5) $ do-    el_ "Age:"-    el_ $ text $ pack (show age)--  row (gap 5) $ do-    el_ "Password:"-    el_ $ text pass1
− example/Example/LazyLoading.hs 
@@ -1,50 +0,0 @@-module Example.LazyLoading where--import Data.Text (pack)-import Effectful-import Example.Effects.Debug-import Web.Hyperbole----- this is already running in a different context-page :: (Hyperbole :> es, Debug :> es) => Page es Response-page = do-  handle content--  load $ do-    pure $ do-      row (pad 20) $ do-        col (gap 10 . border 1 . pad 20) $ do-          hyper Contents viewInit---data Contents = Contents-  deriving (Generic, Param)-instance HyperView Contents where-  type Action Contents = ContentsAction---data ContentsAction-  = Load-  | Reload Int-  deriving (Generic, Param)---content :: (Hyperbole :> es, Debug :> es) => Contents -> ContentsAction -> Eff es (View Contents ())-content _ Load = do-  -- Pretend the initial Load takes 1s to complete-  delay 1000-  pure $ onLoad (Reload 1) 1000 $ do-    el id "Loaded, should reload once more..."-content _ (Reload n) = do-  -- then reload after a 1s delay (client-side)-  pure $ onLoad (Reload (n + 1)) 1000 $ do-    col (gap 10) $ do-      el_ "Reloaded! polling..."-      el_ $ text $ pack $ show n---viewInit :: View Contents ()-viewInit = do-  onLoad Load 0 $ do-    el id "Lazy Loading..."
− example/Example/Redirects.hs 
@@ -1,39 +0,0 @@-module Example.Redirects where--import Effectful-import Example.Style as Style-import Web.Hyperbole---page :: (Hyperbole :> es) => Page es Response-page = do-  handle contents--  load $ do-    pure $ row (pad 20) $ do-      hyper Contents contentsView---data Contents = Contents-  deriving (Generic, Param)---data ContentsAction-  = RedirectAsAction-  deriving (Generic, Param)---instance HyperView Contents where-  type Action Contents = ContentsAction---contents :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ())-contents _ RedirectAsAction = do-  redirect "/hello/redirected"---contentsView :: View Contents ()-contentsView = do-  col (gap 10 . border 1 . pad 20 . transition 300 (Height 200)) $ do-    el id "Redirect as an Action"-    button RedirectAsAction Style.btn "Redirect Me"
− example/Example/Sessions.hs 
@@ -1,80 +0,0 @@-module Example.Sessions where--import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Effectful-import Example.Colors-import Example.Effects.Debug-import Example.Style as Style-import Web.Hyperbole----- this is already running in a different context-page :: (Hyperbole :> es, Debug :> es) => Page es Response-page = do-  handle content--  load $ do-    -- setSession "color" Warning-    -- setSession "msg" ("________" :: Text)-    (clr :: Maybe AppColor) <- session "color"-    (msg :: Maybe Text) <- session "msg"-    pure $ col (pad 20 . gap 10) $ do-      el_ "Reload your browser after changing the settings below to see the session information preserved"-      row id $ do-        hyper Contents $ viewContent clr msg---data Contents = Contents-  deriving (Generic, Param)---data ContentsAction-  = SaveColor AppColor-  | SaveMessage Text-  deriving (Generic, Param)---instance HyperView Contents where-  type Action Contents = ContentsAction---content :: (Hyperbole :> es, Debug :> es) => Contents -> ContentsAction -> Eff es (View Contents ())-content _ (SaveColor clr) = do-  setSession "color" clr-  msg <- session "msg"-  pure $ viewContent (Just clr) msg-content _ (SaveMessage msg) = do-  setSession "msg" msg-  clr <- session "color"-  pure $ viewContent clr (Just msg)---viewContent :: Maybe AppColor -> Maybe Text -> View Contents ()-viewContent mclr mmsg =-  col (gap 20) $ do-    viewColorPicker mclr-    viewMessage mmsg---viewColorPicker :: Maybe AppColor -> View Contents ()-viewColorPicker mc = do-  let clr = fromMaybe White mc-  col (gap 10 . pad 20 . bg clr) $ do-    el (fontSize 24 . bold) "Session Background"-    row (gap 10) $ do-      button (SaveColor Success) (Style.btn' Success . border 1) "Successs"-      button (SaveColor Warning) (Style.btn' Warning . border 1) "Warning"-      button (SaveColor Danger) (Style.btn' Danger . border 1) "Danger"---viewMessage :: Maybe Text -> View Contents ()-viewMessage mm = do-  let msg = fromMaybe "" mm-  col (gap 10 . pad 20 . border 1) $ do-    el (fontSize 24 . bold) "Session Message:"-    el_ $ text msg-    row (gap 10) $ do-      button (SaveMessage "Hello") Style.btnLight "Msg: Hello"-      button (SaveMessage "Goodbye") Style.btnLight "Msg: Goodbye"-      button (SaveMessage "________") Style.btnLight "Clear"
− example/Example/Simple.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wno-missing-signatures #-}--module Example.Simple where--import Data.Text (Text)-import Web.Hyperbole---main = do-  run 3000 $ do-    liveApp (basicDocument "Example") (page simplePage)---simplePage :: (Hyperbole :> es) => Page es Response-simplePage = do-  handle message-  load $ do-    pure $ col (pad 20) $ do-      el bold "My Page"-      hyper (Message 1) $ messageView "Hello"-      hyper (Message 2) $ messageView "World!"---data Message = Message Int-  deriving (Generic, Param)---data MessageAction = Louder Text-  deriving (Generic, Param)---instance HyperView Message where-  type Action Message = MessageAction---message :: Message -> MessageAction -> Eff es (View Message ())-message _ (Louder m) = do-  let new = m <> "!"-  pure $ messageView new---messageView m = do-  el_ $ text m-  button (Louder m) (border 1) "Louder"
− example/Example/Style.hs 
@@ -1,43 +0,0 @@-module Example.Style where--import Example.Colors-import Web.View---btn :: Mod-btn = btn' Primary---btn' :: AppColor -> Mod-btn' clr = bg clr . hover (bg (hovClr clr)) . color (txtClr clr) . pad 10- where-  hovClr Primary = PrimaryLight-  hovClr c = c-  txtClr _ = White---btnLight :: Mod-btnLight =-  base-    . border 2-    . borderColor Secondary-    . color Secondary-    . hover (borderColor SecondaryLight . color SecondaryLight)- where-  base = pad (XY 15 8)---h1 :: Mod-h1 = bold . fontSize 32---invalid :: Mod-invalid = color Danger---success :: Mod-success = color Success---link :: Mod-link = color Primary
− example/Example/Transitions.hs 
@@ -1,48 +0,0 @@-module Example.Transitions where--import Effectful-import Example.Style as Style-import Web.Hyperbole---page :: (Hyperbole :> es) => Page es Response-page = do-  handle content--  load $ do-    pure $ row (pad 20) $ do-      hyper Contents viewSmall---data Contents = Contents-  deriving (Generic, Param)---data ContentsAction-  = Expand-  | Collapse-  deriving (Generic, Param)---instance HyperView Contents where-  type Action Contents = ContentsAction---content :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ())-content _ Expand = do-  pure viewBig-content _ Collapse = do-  pure viewSmall---viewSmall :: View Contents ()-viewSmall = do-  col (gap 10 . border 1 . pad 20 . transition 300 (Width 200)) $ do-    el id "Small"-    button Expand Style.btn "Expand"---viewBig :: View Contents ()-viewBig = col (gap 10 . border 1 . pad 20 . transition 300 (Width 400)) $ do-  el_ "Expanded"-  button Collapse Style.btn "Collapse"
− example/HelloWorld.hs 
@@ -1,59 +0,0 @@-module HelloWorld where--import Data.Text (Text)-import Web.Hyperbole----main :: IO ()-main = do-  run 3000 $ do-    liveApp (basicDocument "Example") (page messagePage')---messagePage :: (Hyperbole :> es) => Page es Response-messagePage = do-  load $ do-    pure $ do-      el bold "Message Page"-      messageView "Hello World"---messageView :: Text -> View c ()-messageView m = do-  el_ "Message:"-  el_ (text m)---data Message = Message-  deriving (Generic, Param)---data MessageAction = SetMessage Text-  deriving (Generic, Param)---instance HyperView Message where-  type Action Message = MessageAction---message :: Message -> MessageAction -> Eff es (View Message ())-message _ (SetMessage m) = do-  -- side effects-  pure $ messageView' m---messageView' :: Text -> View Message ()-messageView' m = do-  el bold "Message"-  el_ (text m)-  button (SetMessage "Goodbye World") id "Change Message"---messagePage' :: (Hyperbole :> es) => Page es Response-messagePage' = do-  handle message-  load $ do-    pure $ do-      el bold "Message Page"-      hyper Message $ messageView' "Hello World"
− example/Main.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -Wno-unused-imports #-}--module Main where--import Control.Monad (forever)-import Data.ByteString.Lazy qualified as BL-import Data.String.Conversions (cs)-import Data.String.Interpolate (i)-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Lazy qualified as L-import Data.Text.Lazy.Encoding qualified as L-import Effectful-import Effectful.Concurrent.STM-import Effectful.Dispatch.Dynamic-import Effectful.Reader.Static-import Effectful.State.Static.Local-import Example.Contacts qualified as Contacts-import Example.Counter qualified as Counter-import Example.Effects.Debug as Debug-import Example.Effects.Users as Users-import Example.Errors qualified as Errors-import Example.Forms qualified as Forms-import Example.LazyLoading qualified as LazyLoading-import Example.Redirects qualified as Redirects-import Example.Sessions qualified as Sessions-import Example.Simple qualified as Simple-import Example.Style qualified as Style-import Example.Transitions qualified as Transitions-import GHC.Generics (Generic)-import Network.HTTP.Types (Method, QueryItem, methodPost, status200, status404)-import Network.Wai qualified as Wai-import Network.Wai.Handler.Warp qualified as Warp-import Network.Wai.Middleware.Static (addBase, staticPolicy)-import Network.WebSockets (Connection, PendingConnection, acceptRequest, defaultConnectionOptions)-import Web.Hyperbole-import Web.Hyperbole.Effect (Request (..))----- import Network.Wai.Handler.WebSockets (websocketsOr)--main :: IO ()-main = do-  putStrLn "Starting Examples on http://localhost:3000"-  users <- Users.initUsers-  count <- runEff $ runConcurrent Counter.initCounter-  Warp.run 3000 $-    staticPolicy (addBase "client/dist") $-      app users count---data AppRoute-  = Main-  | Simple-  | Hello Hello-  | Contacts-  | Transitions-  | Query-  | Counter-  | Forms-  | Sessions-  | Redirects-  | RedirectNow-  | LazyLoading-  | Errors-  deriving (Eq, Generic, Route)---data Hello-  = Greet Text-  | Redirected-  deriving (Eq, Generic, Route)---app :: UserStore -> TVar Int -> Application-app users count = do-  liveApp-    toDocument-    (runApp . routeRequest $ router)- where-  runApp :: (IOE :> es) => Eff (Concurrent : Debug : Users : es) a -> Eff es a-  runApp = runUsersIO users . runDebugIO . runConcurrent--  router :: forall es. (Hyperbole :> es, Users :> es, Debug :> es, Concurrent :> es, IOE :> es) => AppRoute -> Eff es Response-  router (Hello h) = page $ hello h-  router Simple = page Simple.simplePage-  router Contacts = page Contacts.page-  router Counter = page $ Counter.page count-  router Transitions = page Transitions.page-  router Forms = page Forms.page-  router Sessions = page Sessions.page-  router LazyLoading = page LazyLoading.page-  router Redirects = page Redirects.page-  router Errors = page Errors.page-  router RedirectNow = do-    redirect (routeUrl $ Hello Redirected)-  router Query = do-    p <- reqParam "key"-    view $ el (pad 20) $ do-      text "key: "-      text p-  router Main = do-    view $ do-      col (gap 10 . pad 20) $ do-        el (bold . fontSize 32) "Examples"-        route (Hello (Greet "World")) lnk "Hello World"-        route Simple lnk "Simple"-        route Counter lnk "Counter"-        route Transitions lnk "Transitions"-        route Forms lnk "Forms"-        link "/query?key=value" lnk "Query Params"-        route Sessions lnk "Sessions"-        route Redirects lnk "Redirects"-        route RedirectNow lnk "Redirect Now"-        route LazyLoading lnk "Lazy Loading"-        route Contacts lnk "Contacts (Advanced)"-        route Errors lnk "Errors"--  lnk = Style.link--  -- Nested Router-  hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es Response-  hello Redirected = load $ do-    pure $ el_ "You were redirected"-  hello (Greet s) = load $ do-    r <- request-    pure $ col (gap 10 . pad 10) $ do-      el_ $ do-        text "Greetings: "-        text s-      el_ $ do-        text "Host: "-        text $ cs $ show r.host-      el_ $ do-        text "Path: "-        text $ cs $ show r.path-      el_ $ do-        text "Query: "-        text $ cs $ show r.query-      el_ $ do-        text "Cookies: "-        text $ cs $ show r.cookies--  -- Use the embedded version for real applications (see basicDocument).-  -- The link to /hyperbole.js here is just to make local development easier-  toDocument :: BL.ByteString -> BL.ByteString-  toDocument cnt =-    [i|<html>-      <head>-        <title>Hyperbole Examples</title>-        <script type="text/javascript" src="/hyperbole.js"></script>-        <style type type="text/css">#{cssResetEmbed}</style>-      </head>-      <body>#{cnt}</body>-    </html>|]
hyperbole.cabal view
@@ -1,13 +1,13 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           hyperbole-version:        0.3.6+version:        0.4.2 synopsis:       Interactive HTML apps using type-safe serverside Haskell-description:    Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView+description:    Interactive serverside web framework Inspired by HTMX, Elm, and Phoenix LiveView category:       Web, Network homepage:       https://github.com/seanhess/hyperbole bug-reports:    https://github.com/seanhess/hyperbole/issues@@ -16,6 +16,9 @@ license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple+tested-with:+    GHC == 9.8.2+  , GHC == 9.6.6 extra-source-files:     client/dist/hyperbole.js extra-doc-files:@@ -30,13 +33,25 @@   exposed-modules:       Web.Hyperbole       Web.Hyperbole.Application-      Web.Hyperbole.Effect-      Web.Hyperbole.Embed-      Web.Hyperbole.Forms+      Web.Hyperbole.Data.QueryData+      Web.Hyperbole.Data.Session+      Web.Hyperbole.Effect.Event+      Web.Hyperbole.Effect.Handler+      Web.Hyperbole.Effect.Hyperbole+      Web.Hyperbole.Effect.Query+      Web.Hyperbole.Effect.Request+      Web.Hyperbole.Effect.Response+      Web.Hyperbole.Effect.Server+      Web.Hyperbole.Effect.Session       Web.Hyperbole.HyperView+      Web.Hyperbole.Page       Web.Hyperbole.Route-      Web.Hyperbole.Session+      Web.Hyperbole.TypeList       Web.Hyperbole.View+      Web.Hyperbole.View.Element+      Web.Hyperbole.View.Embed+      Web.Hyperbole.View.Event+      Web.Hyperbole.View.Forms   other-modules:       Paths_hyperbole   autogen-modules:@@ -59,7 +74,8 @@     , casing >0.1 && <0.2     , containers >=0.6 && <1     , cookie ==0.4.*-    , effectful >=2.3 && <3+    , data-default >0.8 && <0.9+    , effectful >=2.4 && <3     , file-embed >=0.0.10 && <0.1     , http-api-data ==0.6.*     , http-types ==0.12.*@@ -67,80 +83,28 @@     , string-conversions ==0.4.*     , string-interpolate ==0.3.*     , text >=1.2 && <3+    , time >=1.12 && <2     , wai >=3.2 && <4     , wai-websockets >=3.0 && <4     , warp >=3.3 && <4-    , web-view >=0.4 && <=0.5-    , websockets >=0.12 && <0.14-  default-language: GHC2021--executable examples-  main-is: Main.hs-  other-modules:-      BulkUpdate-      Example.Colors-      Example.Contacts-      Example.Counter-      Example.Effects.Debug-      Example.Effects.Users-      Example.Errors-      Example.Forms-      Example.LazyLoading-      Example.Redirects-      Example.Sessions-      Example.Simple-      Example.Style-      Example.Transitions-      HelloWorld-      Paths_hyperbole-  autogen-modules:-      Paths_hyperbole-  hs-source-dirs:-      example-  default-extensions:-      OverloadedStrings-      OverloadedRecordDot-      DuplicateRecordFields-      NoFieldSelectors-      TypeFamilies-      DataKinds-      DerivingStrategies-      DeriveAnyClass-  ghc-options: -Wall -fdefer-typed-holes-  build-depends:-      base >=4.16 && <5-    , bytestring >=0.11 && <0.13-    , casing >0.1 && <0.2-    , containers >=0.6 && <1-    , cookie ==0.4.*-    , effectful >=2.3 && <3-    , file-embed >=0.0.10 && <0.1-    , http-api-data ==0.6.*-    , http-types ==0.12.*-    , hyperbole-    , network >=3.1 && <4-    , string-conversions ==0.4.*-    , string-interpolate ==0.3.*-    , text >=1.2 && <3-    , wai >=3.2 && <4-    , wai-middleware-static >=0.9 && <=0.10-    , wai-websockets >=3.0 && <4-    , warp >=3.3 && <4-    , web-view >=0.4 && <=0.5+    , web-view >=0.6.2 && <=1.0     , websockets >=0.12 && <0.14   default-language: GHC2021 -test-suite tests+test-suite test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Test.FormSpec+      Test.QuerySpec       Test.RouteSpec-      Test.ViewSpec+      Test.ViewActionSpec+      Test.ViewIdSpec       Paths_hyperbole   autogen-modules:       Paths_hyperbole   hs-source-dirs:-      test/+      test   default-extensions:       OverloadedStrings       OverloadedRecordDot@@ -150,28 +114,29 @@       DataKinds       DerivingStrategies       DeriveAnyClass-  ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N-  build-tool-depends:-      sydtest-discover:sydtest-discover+  ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor   build-depends:-      base >=4.16 && <5+      Diff >=0.5 && <1.0+    , base >=4.16 && <5     , bytestring >=0.11 && <0.13     , casing >0.1 && <0.2     , containers >=0.6 && <1     , cookie ==0.4.*-    , effectful >=2.3 && <3+    , data-default >0.8 && <0.9+    , effectful >=2.4 && <3     , file-embed >=0.0.10 && <0.1     , http-api-data ==0.6.*     , http-types ==0.12.*     , hyperbole     , network >=3.1 && <4+    , skeletest     , string-conversions ==0.4.*     , string-interpolate ==0.3.*-    , sydtest ==0.15.*     , text >=1.2 && <3+    , time >=1.12 && <2     , wai >=3.2 && <4     , wai-websockets >=3.0 && <4     , warp >=3.3 && <4-    , web-view >=0.4 && <=0.5+    , web-view >=0.6.2 && <=1.0     , websockets >=0.12 && <0.14   default-language: GHC2021
src/Web/Hyperbole.hs view
@@ -12,116 +12,166 @@   ( -- * Introduction     -- $use -    -- ** Hello World+    -- * Getting started     -- $hello -    -- ** Interactivity+    -- ** HTML Views+    -- $view-functions-intro++    -- ** Interactive HyperViews #hyperviews#     -- $interactive -    -- ** Independent Updates-    -- $multi+    -- ** View Functions #viewfunctions#+    -- $view-functions -    -- ** Examples+    -- * Managing State+    -- $state-parameters++    -- ** Side Effects+    -- $state-effects++    -- ** Databases and Custom Effects+    -- $state-databases++    -- * Multiple HyperViews+    -- $practices-multi++    -- ** Copies+    -- $practices-same++    -- ** Nesting+    -- $practices-nested++    -- * Functions, not Components #reusable#+    -- $reusable++    -- * Pages #pages#+    -- $practices-pages++    -- * Examples     -- $examples -    -- * Run an Application+    -- * Application     liveApp   , Warp.run-  , page   , basicDocument+  , Page+  , runPage      -- ** Type-Safe Routes   , routeRequest -- maybe belongs in an application section-  , Route+  , Route (..)   , routeUrl   , route -    -- * Pages+    -- * Hyperbole Effect+  , Hyperbole -    -- ** Page-  , Page-  , load-  , handle+    -- ** Response+  , respondEarly+  , notFound+  , redirect -    -- ** HyperView+    -- ** Request+  , request+  , Request (..)++    -- ** Query Params #query#+  , query+  , setQuery+  , param+  , lookupParam+  , setParam+  , deleteParam+  , queryParams++    -- ** Sessions #sessions#+  , session+  , saveSession+  , lookupSession+  , modifySession+  , modifySession_+  , deleteSession+  , Session (..)++    -- * HyperView   , HyperView (..)   , hyper+  , HasViewId (..)      -- * Interactive Elements--    -- ** Buttons   , button--    -- ** Dropdowns+  , search   , dropdown   , option   , Option -    -- ** Events-  , onRequest+    -- * Events+  , onClick+  , onDblClick+  , onInput+  , onKeyDown+  , onKeyUp   , onLoad+  , onRequest+  , Key (..)   , DelayMs      -- * Type-Safe Forms -    -- | Painless forms with type-checked field names, and support for validation. See [Example.Forms](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)+    -- | Painless forms with type-checked field names, and support for validation. See [Example.Forms](https://docs.hyperbole.live/formsimple)+  , formData+  , Form (..)+  , formFields+  , formFieldsWith   , FormField+  , Field+  , Identity      -- ** Form View   , form   , field   , label   , input+  , textarea   , submit   , placeholder   , InputType (..) -    -- ** Handlers-  , formField-     -- ** Validation-  , Validation (..)+  , Validated (..)   , validate-  , validation+  , fieldValid   , invalidText--    -- * Hyperbole Effect-  , Hyperbole--    -- ** Request Info-  , reqParam-  , reqParams-  , request-  , lookupParam-  , formData--    -- ** Response-  , notFound-  , redirect-  , respondEarly+  , anyInvalid -    -- ** Sessions-  , session-  , setSession-  , clearSession+    -- * Query Param Encoding+  , ToQuery (..)+  , FromQuery (..)+  , ToParam (..)+  , FromParam (..)+  , QueryData+  , DefaultParam (..)      -- * Advanced   , target   , view-  , Param (..)   , Response+  , ViewId+  , ViewAction+  , Root      -- * Exports      -- ** Web.View      -- | Hyperbole is tightly integrated with [Web.View](https://hackage.haskell.org/package/web-view/docs/Web-View.html) for HTML generation-  , module Web.Hyperbole.View+  , module Web.View      -- ** Embeds      -- | Embedded CSS and Javascript to include in your document function. See 'basicDocument'-  , module Web.Hyperbole.Embed+  , module Web.Hyperbole.View.Embed      -- ** Effectful     -- $effects@@ -133,16 +183,24 @@   ) where  import Effectful (Eff, (:>))-import GHC.Generics (Generic) import Network.Wai (Application) import Network.Wai.Handler.Warp as Warp (run) import Web.Hyperbole.Application-import Web.Hyperbole.Effect-import Web.Hyperbole.Embed-import Web.Hyperbole.Forms (FormField, InputType (..), Validation (..), field, form, formField, input, invalidText, label, placeholder, submit, validate, validation)+import Web.Hyperbole.Data.QueryData+import Web.Hyperbole.Data.Session+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Query+import Web.Hyperbole.Effect.Request+import Web.Hyperbole.Effect.Response (notFound, redirect, respondEarly, view)+import Web.Hyperbole.Effect.Server+import Web.Hyperbole.Effect.Session import Web.Hyperbole.HyperView+import Web.Hyperbole.Page (Page, runPage) import Web.Hyperbole.Route import Web.Hyperbole.View+import Web.Hyperbole.View.Embed+import Web.Hyperbole.View.Forms+import Web.View hiding (Query, Segment, button, cssResetEmbed, form, input, label)   -- import Web.View.Types.Url (Segment)@@ -151,7 +209,7 @@  Single Page Applications (SPAs) require the programmer to write two programs: a Javascript client and a Server, which both must conform to a common API -Hyperbole allows us instead to write a single Haskell program which runs exclusively on the server. All user interactions are sent to the server for processing, and a sub-section of the page is updated with the resulting HTML.+Hyperbole allows us to instead write a single Haskell program which runs exclusively on the server. All user interactions are sent to the server for processing, and a sub-section of the page is updated with the resulting HTML.  There are frameworks that support this in different ways, including [HTMX](https://htmx.org/), [Phoenix LiveView](https://www.phoenixframework.org/), and others. Hyperbole has the following advantages @@ -165,9 +223,9 @@  Like [Phoenix LiveView](https://www.phoenixframework.org/), it upgrades the page to a fast WebSocket connection and uses VirtualDOM for live updates -Like [Elm](https://elm-lang.org/), it relies on an update function to 'handle' actions, but greatly simplifies the Elm Architecture by handling state with extensible effects. 'form's are easy to use with minimal boilerplate+Like [Elm](https://elm-lang.org/), it uses an update function to process actions, but greatly simplifies the Elm Architecture by remaining stateless. Effects are handled by [Effectful](https://hackage.haskell.org/package/effectful). 'form's are easy to use with minimal boilerplate -Depends heavily on the following frameworks+Hyperbole depends heavily on the following frameworks  * [Effectful](https://hackage.haskell.org/package/effectful-core) * [Web View](https://hackage.haskell.org/package/web-view)@@ -178,120 +236,388 @@  Hyperbole applications run via [Warp](https://hackage.haskell.org/package/warp) and [WAI](https://hackage.haskell.org/package/wai) -They are divided into top-level 'Page's. We use 'load' to handle the initial page load+They are divided into top-level 'Page's, which run side effects (such as loading data from a database), then respond with an HTML 'View'. The following application has a single 'Page' that displays a static "Hello World"  @-main = do-  'run' 3000 $ do-    'liveApp' ('basicDocument' \"Example\") ('page' messagePage)+{\-# LANGUAGE DeriveAnyClass #-\}+{\-# LANGUAGE OverloadedStrings #-\}+{\-# LANGUAGE TypeFamilies #-\}+{\-# LANGUAGE DataKinds #-\} -messagePage = do-  'load' $ do-    pure $ do-      'el' 'bold' "Message Page"-      messageView "Hello World"+module Main where -messageView m = do-  el_ "Message:"-  el_ (text m)+import Web.Hyperbole++#EMBED Example/Docs/BasicPage.hs main++#EMBED Example/Docs/BasicPage.hs page @ -}   {- $interactive -Embed 'HyperView's to add type-safe interactivity to subsections of a 'Page'.+We can embed one or more 'HyperView's to add type-safe interactivity to live subsections of our 'Page'. To start, first define a data type (a 'ViewId') that uniquely identifies that subsection of the page: -To do this, first we connect a view id type to the actions it supports+@+#EMBED Example/Docs/Interactive.hs data Message+@ +Make our 'ViewId' an instance of 'HyperView' by:++* Create an 'Action' type with a constructor for every possible way that the user can interact with it+* Write an 'update' for each 'Action'+ @-data Message = Message-  deriving (Generic, 'Param')+#EMBED Example/Docs/Interactive.hs instance HyperView Message+@ -data MessageAction = Louder Text-  deriving (Generic, 'Param')+If an 'Action' occurs, the contents of our 'HyperView' will be replaced with 'update'. -instance 'HyperView' Message where-  type Action Message = MessageAction+To embed our new 'HyperView', add the 'ViewId' to the type-level list of 'Page', and then wrap the view in 'hyper'.+ @+#EMBED Example/Docs/Interactive.hs page+@ +Now let's add a button to trigger the 'Action'. Note that we must update the 'View'\'s 'context' to match our 'ViewId'. The compiler will tell us if we try to trigger actions that don't belong to our 'HyperView' -Next we add a 'handle'r for our view type. It performs side effects, and returns a new view of the same type+@+#EMBED Example/Docs/Interactive.hs messageView+@ +If the user clicks the button, the contents of `hyper` will be replaced with the result of 'update', leaving the rest of the page untouched.+-}+++{- $view-functions-intro++'View's are HTML fragments with embedded CSS+ @-message :: Message -> MessageAction -> Eff es (View Message ())-message _ (Louder m) = do-  -- side effects-  let new = m <> "!"-  pure $ messageView new+#EMBED Example/Docs/BasicPage.hs helloWorld @ -We update our parent page view to make the messageView interactive using 'hyper', and add our 'handle'r to the 'Page'+>>> Web.View.renderText $ el bold "Hello World"+<style type='text/css'>.bold { font-weight:bold }</style>+<div class='bold'>Hello World</div> +We can factor 'View's into reusable functions:+ @-messagePage = do-  'handle' message-  'load' $ do-    pure $ do-      'el' 'bold' "Message Page"-      'hyper' Message $ messageView "Hello World"+#EMBED Example/Docs/BasicPage.hs messageView++#EMBED Example/Docs/BasicPage.hs page' @ -Finally, let's add a 'button' to our view. When clicked, Hyperbole will run the `message` handler, and update our view, leaving the page header untouched+We use plain functions to maintain a consistent look and feel rather than stylesheets:  @-messageView :: Text -> 'View' Message ()-messageView m = do-  'el_' m-  'button' (Louder m) id "Change Message"+header = bold+h1 = header . fontSize 32+h2 = header . fontSize 24+page = gap 10++example = col page $ do+  el h1 "My Page" @++See [Web.View](https://hackage.haskell.org/package/web-view) for more details -}  -{- $multi+{- $view-functions -Multiple views update independently, as long as they have different values for their View Id. Add an Int identifier to Message+We showed above how we can factor 'View's into functions. It's best-practice to have a __main__ 'View' for each 'HyperView'. These take the form: +> state -> View viewId ()++There's nothing special about `state` or 'View' functions. They're just functions that take parameters and return a view.++We can write multiple view functions with our 'HyperView' as the 'context', and factor them however is most convenient:+ @-data Message = Message Int-  deriving (Generic, 'Param')+#EMBED Example/Docs/ViewFunctions.hs messageButton @ -We can embed multiple HyperViews on the same page with different ids. Each button will update its view independently+We can also create 'View' functions that work in any 'context': +@+#EMBED Example/Docs/ViewFunctions.hs header+@ +Then we can refactor our main 'View' to use view functions to avoid repeating ourselves+ @-messagePage = do-  'handle' message-  'load' $ do-    pure $ do-      'el' bold "Message Page"-      'hyper' (Message 1) $ messageView \"Hello\"-      'hyper' (Message 2) $ messageView \"World\"+#EMBED Example/Docs/ViewFunctions.hs messageView @ -}  +{- $practices++We've mentioned most of the Architecture of a hyperbole application, but let's go over each layer here:++* [Pages](#g:pages) - routes map to completely independent web pages+* [HyperViews](#g:hyperviews) - independently updating live subsections of a 'Page'+* Main [View Functions](#g:viewfunctions) - A view function that renders and updates a 'HyperView'+* [Reusable View Functions](#g:reusable) - Generic view functions you can use in any 'HyperView'+-}+++{- $practices-multi++We can add as many 'HyperView's to a page as we want. Let's create another 'HyperView' for a simple counter++From [Example.Docs.MultiView](https://github.com/seanhess/hyperbole/blob/0.4/example/Example/Docs/MultiView.hs)++@+#EMBED Example/Docs/MultiView.hs data Count+++#EMBED Example/Docs/MultiView.hs instance HyperView Count+++#EMBED Example/Docs/MultiView.hs countView+@++We can use both 'Message' and 'Count' 'HyperView's in our page, and they will update independently:++@+#EMBED Example/Docs/MultiView.hs page+@+-}+++{- $practices-same++We can embed multiple copies of the same 'HyperView' as long as the value of 'ViewId' is unique. Let's update `Message` to allow for more than one value:++See [Example.Page.Simple](https://docs.hyperbole.live/simple)++@+#EMBED Example/Page/Simple.hs data Message+@++Now we can embed multiple `Message` 'HyperView's into the same page. Each will update independently.++@+#EMBED Example/Page/Simple.hs page'+@+++This is especially useful if we put identifying information in our 'ViewId', such as a database id. The [Contacts Example](https://docs.hyperbole.live/contacts) uses this to allow the user to edit multiple contacts on the same page. The 'viewId' function gives us access to that info++From [Example.Contacts](https://docs.hyperbole.live/contacts)++@+#EMBED Example/Page/Contact.hs data Contact++#EMBED Example/Page/Contact.hs instance (Users :> es,+@+-}+++{- $practices-pages++An app has multiple 'Page's with different 'Route's that each map to a unique url path:++@+#EMBED Example/Docs/MultiPage.hs data AppRoute+@++When we define our app, we define a function that maps a 'Route' to a 'Page'++@+#EMBED Example/Docs/MultiPage.hs main+@++Each 'Page' is completely independent. The web page is freshly reloaded each time you switch routes. We can add type-safe links to other pages using 'route'++@+#EMBED Example/Docs/MultiPage.hs menu+@++If you need the same header or menu on all pages, use a view function:++@+#EMBED Example/Docs/MultiPage.hs exampleLayout++#EMBED Example/Docs/MultiPage.hs examplePage+@++As shown above, each 'Page' can contain multiple interactive 'HyperView's to add interactivity+-}+++{- $practices-nested++We can nest smaller, specific 'HyperView's inside of a larger parent. You might need this technique to display a list of items which need to update themselves++Let's imagine we want to display a list of Todos. The user can mark individual todos complete, and have them update independently. The specific 'HyperView' might look like this:++From [Example.Docs.Nested](https://github.com/seanhess/hyperbole/blob/0.4/example/Example/Docs/Nested.hs)++@+#EMBED Example/Docs/Nested.hs data TodoItem++#EMBED Example/Docs/Nested.hs instance HyperView TodoItem+@++But we also want the entire list to refresh when a user adds a new todo. We need to create a parent 'HyperView' for the whole list.++List all allowed nested views by adding them to 'Require'++@+#EMBED Example/Docs/Nested.hs data AllTodos++#EMBED Example/Docs/Nested.hs instance HyperView AllTodos+@++Then we can embed the child 'HyperView' into the parent with 'hyper'++@+#EMBED Example/Docs/Nested.hs todosView+@+See this technique used in the [TodoMVC Example](https://docs.hyperbole.live/todos)+-}+++{- $reusable++You may be tempted to use 'HyperView's to create reusable \"Components\". This leads to object-oriented designs that don't compose well. We are using a functional language, so our main unit of reuse should be functions!++We showed earlier that we can write a [View Function](#g:view-functions) with a generic 'context' that we can reuse in any view.  A function like this might help us reuse styles:++@+#EMBED Example/Docs/ViewFunctions.hs header+@++What if we want to reuse functionality too? We can pass an 'Action' into the view function as a parameter:++@+#EMBED Example/Docs/Component.hs styledButton+@++We can create more complex view functions by passing state in as a parameter. Here's a button that toggles between a checked and unchecked state:++@+#EMBED Example/View/Inputs.hs toggleCheckBtn+@++View functions can wrap other Views:++@+#EMBED Example/View/Inputs.hs progressBar+@+++Don't leverage 'HyperView's for code reuse. Think about which subsections of a page ought to update independently. Those are 'HyperView's. If you need reusable functionality, use [view functions](#g:viewfunctions) instead.++* See [Example.View.DataTable](https://docs.hyperbole.live/datatable) for a more complex example+-}++ {- $examples-The [example directory](https://github.com/seanhess/hyperbole/blob/main/example/README.md) contains an app with pages demonstrating various features+https://docs.hyperbole.live is full of live examples demonstrating different features. Each example includes a link to the source code. Some highlights: -* [Main](https://github.com/seanhess/hyperbole/blob/main/example/Main.hs)-* [Simple](https://github.com/seanhess/hyperbole/blob/main/example/Example/Simple.hs)-* [Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs)-* [CSS Transitions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Transitions.hs)-* [Forms](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)-* [Sessions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)-* [Redirects](https://github.com/seanhess/hyperbole/blob/main/example/Example/Redirects.hs)-* [Lazy Loading and Polling](https://github.com/seanhess/hyperbole/blob/main/example/Example/LazyLoading.hs)-* [Errors](https://github.com/seanhess/hyperbole/blob/main/example/Example/Errors.hs)-* [Contacts (Advanced)](https://github.com/seanhess/hyperbole/blob/main/example/Example/Contacts.hs)+* [Simple](https://docs.hyperbole.live/simple)+* [Counter](https://docs.hyperbole.live/counter)+* [CSS Transitions](https://docs.hyperbole.live/transitions)+* [Lazy Loading](https://docs.hyperbole.live/lazyloading)+* [Forms](https://docs.hyperbole.live/formsimple)+* [Data Table](https://docs.hyperbole.live/datatable)+* [Sessions](https://docs.hyperbole.live/sessions)+* [Filter Items](https://docs.hyperbole.live/filter)+* [Autocomplete](https://docs.hyperbole.live/autocomplete)+* [Todo MVC](https://docs.hyperbole.live/todos)++The [National Solar Observatory](https://nso.edu) uses Hyperbole for the Level 2 Data creation tool for the [DKIST telescope](https://nso.edu/telescopes/dki-solar-telescope/). It is completely [open source](https://github.com/DKISTDC/level2/). This production application contains complex interfaces, workers, databases, and more. -}  -{- $effects+{- $state-parameters -Hyperbole is tighly integrated with [Effectful](https://hackage.haskell.org/package/effectful) for extensible effects. It is used to implement the 'Hyperbole' and 'Server' effects.+'HyperView's are stateless. They 'update' based entirely on the 'Action'. However, we can track simple state by passing it back and forth between the 'Action' and the 'View' -* See [Effectful.Dispatch.Dynamic](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) for an example of how to create a custom effect-* See [Example.Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs) for an example of how to compose an existing effect+From [Example.Page.Simple](https://docs.hyperbole.live/simple)++@+#EMBED Example/Docs/State.hs instance HyperView Message++#EMBED Example/Docs/State.hs messageView+@+-}+++{- $state-effects++For any real application with more complex state and data persistence, we need side effects.++Hyperbole relies on [Effectful](https://hackage.haskell.org/package/effectful) to compose side effects. We can use effects in a page or an 'update'. The 'Hyperbole' effect gives us access to the 'request' and 'Client' state, including 'session's and the 'query' 'param's. In this example the page keeps the message in the 'query' 'param's++From [Example.Docs.SideEffects](https://github.com/seanhess/hyperbole/blob/0.4/example/Example/Docs/SideEffects.hs)++@+#EMBED Example/Docs/SideEffects.hs page++#EMBED Example/Docs/SideEffects.hs instance HyperView Message+@+++To use an 'Effect' other than 'Hyperbole', add it as a constraint to the 'Page' and any 'HyperView' instances that need it.++From [Example.Page.Counter](https://docs.hyperbole.live/counter)++@+{\-# LANGUAGE UndecidableInstances #-\}++#EMBED Example/Page/Counter.hs instance (Reader+@++Then run the effect in your application++@+#EMBED Example/Page/Counter.hs app+@++* Read more about [Effectful](https://hackage.haskell.org/package/effectful)+-}+++{- $state-databases++A database is no different from any other 'Effect'. We recommend you create a custom effect to describe high-level data operations.++From [Example.Effects.Todos](https://github.com/seanhess/hyperbole/blob/0.4/example/Example/Effects/Todos.hs)++@+#EMBED Example/Effects/Todos.hs data Todos++#EMBED Example/Effects/Todos.hs loadAll+@++Once you've created an 'Effect', you add it to any 'HyperView' or 'Page' as a constraint.++From [Example.Page.Todo](https://docs.hyperbole.live/todos):++@+{\-# LANGUAGE UndecidableInstances #-\}++#EMBED Example/Page/Todo.hs simplePage+@++We run a custom effect in our Application just like any other. Here we implementing our custom effect using 'Hyperbole' 'sessions', but you could write a different runner that connects to a database instead.++@+#EMBED Example/Page/Todo.hs main+@++See [example/Main](https://github.com/seanhess/hyperbole/blob/0.4/example/Main.hs) for a full example application with multiple effects++Implementing a database runner for a custom 'Effect' is beyond the scope of this documentation, but see the following:++* [Effectful.Dynamic.Dispatch](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) - Introduction to Effects+* [NSO.Data.Datasets](https://github.com/DKISTDC/level2/blob/main/src/NSO/Data/Datasets.hs) - Production Data Effect with a database runner+* [Effectful.Rel8](https://github.com/DKISTDC/level2/blob/main/types/src/Effectful/Rel8.hs) - Effect for the [Rel8](https://hackage.haskell.org/package/rel8) Postgres Library -}
src/Web/Hyperbole/Application.hs view
@@ -7,214 +7,76 @@   , defaultConnectionOptions   , liveApp   , socketApp-  , runServerSockets-  , runServerWai   , basicDocument   , routeRequest   ) where  import Control.Monad (forever)-import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL-import Data.List qualified as L import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.String.Interpolate (i)-import Data.Text (Text, pack)+import Data.Text (Text) import Data.Text qualified as T import Effectful+import Effectful.Concurrent.Async import Effectful.Dispatch.Dynamic import Effectful.Error.Static-import Effectful.State.Static.Local-import Network.HTTP.Types (HeaderName, Method, parseQuery, status200, status400, status401, status404, status500)+import Network.HTTP.Types as HTTP (parseQuery) import Network.Wai qualified as Wai import Network.Wai.Handler.WebSockets (websocketsOr)-import Network.Wai.Internal (ResponseReceived (..)) import Network.WebSockets (Connection, PendingConnection, defaultConnectionOptions) import Network.WebSockets qualified as WS import Web.Cookie (parseCookies)-import Web.Hyperbole.Effect-import Web.Hyperbole.Embed (cssResetEmbed, scriptEmbed)+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Request (reqPath)+import Web.Hyperbole.Effect.Server (Host (..), Request (..), Response (..), Server, SocketError (..), cookiesFromHeader, runServerSockets, runServerWai) import Web.Hyperbole.Route-import Web.Hyperbole.Session-import Web.View (View, renderLazyByteString, renderUrl)+import Web.Hyperbole.View.Embed (cssResetEmbed, scriptEmbed)   {- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets -> main = do->   run 3000 $ do->   liveApp (basicDocument "Example") $ do->      page mainPage+> #EMBED Example/Docs/BasicPage.hs main -}-liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application+liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, Concurrent, IOE] Response -> Wai.Application liveApp toDoc app =   websocketsOr     defaultConnectionOptions-    (runEff . socketApp app)+    (runEff . runConcurrent . socketApp app)     (waiApp toDoc app)  -socketApp :: (IOE :> es) => Eff (Hyperbole : Server : es) Response -> PendingConnection -> Eff es ()-socketApp actions pend = do-  conn <- liftIO $ WS.acceptRequest pend-  forever $ do-    runServerSockets conn $ runHyperbole actions---waiApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application+waiApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, Concurrent, IOE] Response -> Wai.Application waiApp toDoc actions req res = do-  rr <- runEff $ runServerWai toDoc req res $ runHyperbole actions+  rr <- runEff $ runConcurrent $ runServerWai toDoc req res $ runHyperbole actions   case rr of     Nothing -> error "Missing required response in handler"     Just r -> pure r  -errNotHandled :: Event Text Text -> String-errNotHandled ev =-  L.intercalate-    "\n"-    [ "No Handler for Event viewId: " <> cs ev.viewId <> " action: " <> cs ev.action-    , "<p>Remember to add a `hyper` handler in your page function</p>"-    , "<pre>"-    , "page :: (Hyperbole :> es) => Page es Response"-    , "page = do"-    , "  handle contentsHandler"-    , "  load $ do"-    , "    pure $ hyper Contents contentsView"-    , "</pre>"-    ]---runServerWai-  :: (IOE :> es)-  => (BL.ByteString -> BL.ByteString)-  -> Wai.Request-  -> (Wai.Response -> IO ResponseReceived)-  -> Eff (Server : es) a-  -> Eff es (Maybe Wai.ResponseReceived)-runServerWai toDoc req respond =-  reinterpret runLocal $ \_ -> \case-    LoadRequest -> do-      fromWaiRequest req-    SendResponse sess r -> do-      rr <- liftIO $ sendResponse sess r-      put (Just rr)- where-  runLocal :: (IOE :> es) => Eff (State (Maybe ResponseReceived) : es) a -> Eff es (Maybe ResponseReceived)-  runLocal = execState Nothing--  sendResponse :: Session -> Response -> IO Wai.ResponseReceived-  sendResponse sess r =-    respond $ response r-   where-    response :: Response -> Wai.Response-    response NotFound = respError status404 "Not Found"-    response Empty = respError status500 "Empty Response"-    response (Err (ErrParse e)) = respError status400 ("Parse Error: " <> cs e)-    response (Err (ErrParam e)) = respError status400 $ "ErrParam: " <> cs e-    response (Err (ErrOther e)) = respError status500 $ "Server Error: " <> cs e-    response (Err ErrAuth) = respError status401 "Unauthorized"-    response (Err (ErrNotHandled e)) = respError status400 $ cs $ errNotHandled e-    response (Response vw) =-      respHtml $-        addDocument (Wai.requestMethod req) (renderLazyByteString vw)-    response (Redirect u) = do-      let url = renderUrl u-      -- We have to use a 200 javascript redirect because javascript-      -- will redirect the fetch(), while we want to redirect the whole page-      -- see index.ts sendAction()-      let headers = ("Location", cs url) : contentType ContentHtml : setCookies-      Wai.responseLBS status200 headers $ "<script>window.location = '" <> cs url <> "'</script>"--    respError s = Wai.responseLBS s [contentType ContentText]--    respHtml body =-      -- always set the session...-      let headers = contentType ContentHtml : setCookies-       in Wai.responseLBS status200 headers body--    setCookies =-      [("Set-Cookie", sessionSetCookie sess)]--  -- convert to document if full page request. Subsequent POST requests will only include fragments-  addDocument :: Method -> BL.ByteString -> BL.ByteString-  addDocument "GET" bd = toDoc bd-  addDocument _ bd = bd--  fromWaiRequest :: (MonadIO m) => Wai.Request -> m Request-  fromWaiRequest wr = do-    body <- liftIO $ Wai.consumeRequestBodyLazy wr-    let path = Wai.pathInfo wr-        query = Wai.queryString wr-        headers = Wai.requestHeaders wr-        cookie = fromMaybe "" $ L.lookup "Cookie" headers-        host = Host $ fromMaybe "" $ L.lookup "Host" headers-        cookies = parseCookies cookie-        method = Wai.requestMethod wr-    pure $ Request{body, path, query, method, cookies, host}---runServerSockets-  :: (IOE :> es)-  => Connection-  -> Eff (Server : es) Response-  -> Eff es Response-runServerSockets conn = reinterpret runLocal $ \_ -> \case-  LoadRequest -> receiveRequest-  SendResponse sess res -> do-    case res of-      (Response vw) -> sendView (addMetadata sess) vw-      (Err r) -> sendError r-      Empty -> sendError $ ErrOther "Empty"-      NotFound -> sendError $ ErrOther "NotFound"-      (Redirect url) -> sendRedirect (addMetadata sess) url+socketApp :: (IOE :> es, Concurrent :> es) => Eff (Hyperbole : Server : es) Response -> PendingConnection -> Eff es ()+socketApp actions pend = do+  conn <- liftIO $ WS.acceptRequest pend+  forever $ do+    ereq <- runErrorNoCallStack @SocketError $ receiveRequest conn+    case ereq of+      Left e -> liftIO $ putStrLn $ "SOCKET ERROR " <> show e+      Right r -> do+        a <- async (runServerSockets conn r $ runHyperbole actions)+        -- throw exceptions in this thread+        link a+        pure ()  where-  runLocal = runErrorNoCallStackWith @SocketError onSocketError--  onSocketError :: (IOE :> es) => SocketError -> Eff es Response-  onSocketError e = do-    let r = ErrOther $ cs $ show e-    sendError r-    pure $ Err r--  sendError :: (IOE :> es) => ResponseError -> Eff es ()-  sendError r = do-    -- conn <- ask @Connection-    -- TODO: better error handling!-    liftIO $ WS.sendTextData conn $ "|ERROR|" <> pack (show r)--  sendView :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> View () () -> Eff es ()-  sendView addMeta vw = do-    -- conn <- ask @Connection-    liftIO $ WS.sendTextData conn $ addMeta $ renderLazyByteString vw--  sendRedirect :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> Url -> Eff es ()-  sendRedirect addMeta u = do-    -- conn <- ask @Connection-    liftIO $ WS.sendTextData conn $ addMeta $ "|REDIRECT|" <> cs (renderUrl u)--  addMetadata :: Session -> BL.ByteString -> BL.ByteString-  addMetadata sess cont =-    -- you may have 1 or more lines containing metadata followed by a view-    -- \|SESSION| key=value; another=woot;-    -- <div ...>-    sessionLine <> "\n" <> cont-   where-    metaLine name value = "|" <> name <> "|" <> value--    sessionLine :: BL.ByteString-    sessionLine = metaLine "SESSION" $ cs (sessionSetCookie sess)--  receiveRequest :: (IOE :> es, Error SocketError :> es) => Eff es Request-  receiveRequest = do-    t <- receiveText+  receiveRequest :: (IOE :> es, Error SocketError :> es) => Connection -> Eff es Request+  receiveRequest conn = do+    t <- receiveText conn     case parseMessage t of       Left e -> throwError e       Right r -> pure r -  receiveText :: (IOE :> es) => Eff es Text-  receiveText = do+  receiveText :: (IOE :> es) => Connection -> Eff es Text+  receiveText conn = do     -- c <- ask @Connection     liftIO $ WS.receiveData conn @@ -235,8 +97,8 @@     parse url cook hst mbody = do       (u, q) <- parseUrl url       let path = paths u-          query = parseQuery (cs q)-          cookies = parseCookies $ cs $ header cook+          query = HTTP.parseQuery (cs q)+          cookies = cookiesFromHeader $ parseCookies $ cs $ header cook           host = Host $ cs $ header hst           method = "POST"           body = cs $ fromMaybe "" mbody@@ -248,39 +110,18 @@     header = T.drop 2 . T.dropWhile (/= ':')  -data SocketError-  = InvalidMessage Text-  deriving (Show, Eq)---data ContentType-  = ContentHtml-  | ContentText---contentType :: ContentType -> (HeaderName, BS.ByteString)-contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")-contentType ContentText = ("Content-Type", "text/plain; charset=utf-8")-- {- | wrap HTML fragments in a simple document with a custom title and include required embeds  @ 'liveApp' (basicDocument "App Title") ('routeRequest' router) @ -You may want to specify a custom document function instead:+You may want to specify a custom document function to import custom javascript, css, or add other information to the \<head\> -> myDocument :: ByteString -> ByteString-> myDocument content =->   [i|<html>->     <head>->       <title>#{title}</title>->       <script type="text/javascript">#{scriptEmbed}</script>->       <style type type="text/css">#{cssResetEmbed}</style>->     </head>->     <body>#{content}</body>->   </html>|]+> import Data.String.Interpolate (i)+> import Web.Hyperbole (scriptEmbed, cssResetEmbed)+>+> #EMBED Example/Docs/App.hs customDocument -} basicDocument :: Text -> BL.ByteString -> BL.ByteString basicDocument title cnt =@@ -288,7 +129,7 @@       <head>         <title>#{title}</title>         <script type="text/javascript">#{scriptEmbed}</script>-        <style type type="text/css">#{cssResetEmbed}</style>+        <style type="text/css">#{cssResetEmbed}</style>       </head>       <body>#{cnt}</body>   </html>|]@@ -298,26 +139,15 @@   @-import Page.Messages qualified as Messages-import Page.Users qualified as Users+#EMBED Example/Docs/App.hs import Example.Docs.Page -data AppRoute-  = Main-  | Messages-  | Users UserId-  deriving (Eq, Generic, 'Route')+#EMBED Example/Docs/App.hs type UserId -router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'-router Messages = 'page' Messages.page-router (Users uid) = 'page' $ Users.page uid-router Main = do-  'view' $ do-    'el_' "click a link below to visit a page"-    'route' Messages id \"Messages\"+#EMBED Example/Docs/App.hs data AppRoute -main = do-  'run' 3000 $ do-    'liveApp' ('basicDocument' \"Example\") (routeRequest router)+#EMBED Example/Docs/App.hs instance Route++#EMBED Example/Docs/App.hs router @ -} routeRequest :: (Hyperbole :> es, Route route) => (route -> Eff es Response) -> Eff es Response
+ src/Web/Hyperbole/Data/QueryData.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++module Web.Hyperbole.Data.QueryData where++import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.Default (Default (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Maybe (fromMaybe)+import Data.String (IsString)+import Data.String.Conversions (cs)+import Data.Text (Text, pack)+import Data.Time (UTCTime)+import Data.Word+import GHC.Generics+import Network.HTTP.Types (Query, renderQuery)+import Network.HTTP.Types qualified as HTTP+import Text.Read (readMaybe)+import Web.HttpApiData (parseQueryParam, toQueryParam)+import Prelude hiding (lookup)+++newtype Param = Param {text :: Text}+  deriving newtype (Show, Eq, Ord, IsString)+++newtype ParamValue = ParamValue {text :: Text}+  deriving newtype (Show, Eq, Ord, IsString)+++-- | Key-value store for query params and sessions+newtype QueryData = QueryData (Map Param ParamValue)+  deriving (Show)+  deriving newtype (Monoid, Semigroup)+++singleton :: (ToParam a) => Param -> a -> QueryData+singleton key a = QueryData $ M.singleton key (toParam a)+++insert :: (ToParam a) => Param -> a -> QueryData -> QueryData+insert p a (QueryData m) =+  let val = toParam a+   in QueryData $ M.insert p val m+++insertAll :: (ToQuery a) => a -> QueryData -> QueryData+insertAll a (QueryData m) =+  let QueryData kvs = toQuery a+   in QueryData $ M.union kvs m+++delete :: Param -> QueryData -> QueryData+delete p (QueryData m) =+  QueryData $ M.delete p m+++lookup :: (FromParam a) => Param -> QueryData -> Maybe a+lookup k (QueryData m) = do+  t <- M.lookup k m+  either (const Nothing) pure $ parseParam t+++require :: (FromParam a) => Param -> QueryData -> Either Text a+require p (QueryData m) = do+  case M.lookup p m of+    Nothing -> Left $ "Missing Key: " <> p.text+    Just val -> parseParam val+++filterKey :: (Param -> Bool) -> QueryData -> QueryData+filterKey p (QueryData m) =+  QueryData $ M.filterWithKey (\k _ -> p k) m+++member :: Param -> QueryData -> Bool+member k (QueryData qd) = M.member k qd+++elems :: QueryData -> [ParamValue]+elems (QueryData m) = M.elems m+++render :: QueryData -> ByteString+render (QueryData m) =+  -- urlEncode True+  renderQuery False (HTTP.toQuery $ fmap queryItem $ M.toList m)+ where+  queryItem (Param k, ParamValue val) = (k, val)+++parse :: ByteString -> QueryData+parse =+  -- urlDecode True+  queryData . HTTP.parseQuery+++queryData :: Query -> QueryData+queryData =+  QueryData . M.fromList . map (bimap (Param . cs) value)+ where+  -- empty / missing values are encoded as empty strings+  value Nothing = ""+  value (Just v) = ParamValue (cs v)+++fromList :: [(Param, ParamValue)] -> QueryData+fromList = QueryData . M.fromList+++toList :: QueryData -> [(Param, ParamValue)]+toList (QueryData m) = M.toList m+++{- | Decode a type from a 'QueryData'. Missing fields are set to 'defaultParam'++@+#EMBED Example/Docs/Encoding.hs data Filters+@++>>> parseQuery $ parse "active=true&search=asdf"+Right (Filters True "asdf")++>>> parseQuery $ parse "search=asdf"+Right (Filters False "asdf")+-}+class FromQuery a where+  parseQuery :: QueryData -> Either Text a+  default parseQuery :: (Generic a, GFromQuery (Rep a)) => QueryData -> Either Text a+  parseQuery q = to <$> gParseQuery q+++instance FromQuery QueryData where+  parseQuery = pure+++{- | A page can store state in the browser 'query' string. ToQuery and 'FromQuery' control how a datatype is encoded to a full query string++@+#EMBED Example/Docs/Encoding.hs data Filters+@++>>> render $ toQuery $ Filter True "asdf"+"active=true&search=asdf"++If the value of a field is the same as 'DefaultParam', it will be omitted from the query string++>>> render $ toQuery $ Filter True ""+"active=true"++>>> render $ toQuery $ Filter False ""+""+-}+class ToQuery a where+  toQuery :: a -> QueryData+  default toQuery :: (Generic a, GToQuery (Rep a)) => a -> QueryData+  toQuery = gToQuery . from+++instance ToQuery QueryData where+  toQuery = id+++instance ToQuery Query where+  toQuery = queryData+++{- | 'session's, 'form's, and 'query's all encode data as query strings. ToParam and FromParam control how a datatype is encoded to a parameter. By default it simply url-encodes the show instance.++@+#EMBED Example/Effects/Todos.hs data Todo = Todo+@++@+#EMBED Example/Docs/Encoding.hs data Tags++#EMBED Example/Docs/Encoding.hs instance ToParam Tags+@+-}+class ToParam a where+  toParam :: a -> ParamValue+  default toParam :: (Show a) => a -> ParamValue+  toParam = showQueryParam+++{- | Decode data from a 'query', 'session', or 'form' parameter value++@+#EMBED Example/Effects/Todos.hs data Todo = Todo+@++@+#EMBED Example/Docs/Encoding.hs data Tags++#EMBED Example/Docs/Encoding.hs instance FromParam Tags+@+-}+class FromParam a where+  parseParam :: ParamValue -> Either Text a+  default parseParam :: (Read a) => ParamValue -> Either Text a+  parseParam = readQueryParam+++instance ToParam Int where+  toParam = ParamValue . toQueryParam+instance FromParam Int where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Integer where+  toParam = ParamValue . toQueryParam+instance FromParam Integer where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Float where+  toParam = ParamValue . toQueryParam+instance FromParam Float where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Double where+  toParam = ParamValue . toQueryParam+instance FromParam Double where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Word where+  toParam = ParamValue . toQueryParam+instance FromParam Word where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Word8 where+  toParam = ParamValue . toQueryParam+instance FromParam Word8 where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Word16 where+  toParam = ParamValue . toQueryParam+instance FromParam Word16 where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Word32 where+  toParam = ParamValue . toQueryParam+instance FromParam Word32 where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Word64 where+  toParam = ParamValue . toQueryParam+instance FromParam Word64 where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Bool where+  toParam = ParamValue . toQueryParam+instance FromParam Bool where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Text where+  toParam = ParamValue . toQueryParam+instance FromParam Text where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam Char where+  toParam = ParamValue . toQueryParam+instance FromParam Char where+  parseParam (ParamValue t) = parseQueryParam t+++instance ToParam UTCTime where+  toParam = ParamValue . toQueryParam+instance FromParam UTCTime where+  parseParam (ParamValue t) = parseQueryParam t+++instance (Show a) => ToParam [a] where+  toParam = showQueryParam+instance (Read a) => FromParam [a] where+  parseParam = readQueryParam+++instance (Show k, Show v) => ToParam (Map k v) where+  toParam = showQueryParam+instance (Read k, Read v, Ord k) => FromParam (Map k v) where+  parseParam = readQueryParam+++instance (ToParam a) => ToParam (Maybe a) where+  toParam Nothing = ""+  toParam (Just a) = toParam a+instance (FromParam a) => FromParam (Maybe a) where+  parseParam "" = pure Nothing+  parseParam t = Just <$> parseParam @a t+++instance (ToParam a, ToParam b) => ToParam (Either a b) where+  toParam (Left a) = toParam a+  toParam (Right b) = toParam b+instance (FromParam a, FromParam b) => FromParam (Either a b) where+  parseParam val =+    case parseParam @a val of+      Right a -> pure $ Left a+      Left _ -> do+        case parseParam @b val of+          Left _ -> Left $ "Could not parseParam Either: " <> val.text+          Right b -> pure $ Right b+++-- | Encode a Show as a query param+showQueryParam :: (Show a) => a -> ParamValue+showQueryParam a = ParamValue $ toQueryParam $ show a+++-- | Decode a Read as a query param+readQueryParam :: (Read a) => ParamValue -> Either Text a+readQueryParam (ParamValue t) = do+  str <- parseQueryParam t+  case readMaybe str of+    Nothing -> Left $ pack $ "Could not read query param: " <> str+    Just a -> pure a+++-- | Parse a Traversable (list) of params+parseParams :: (Traversable t, FromParam a) => t ParamValue -> Either Text (t a)+parseParams = traverse parseParam+++-- | Generic decoding of records from a Query+class GFromQuery f where+  gParseQuery :: QueryData -> Either Text (f p)+++instance (GFromQuery f, GFromQuery g) => GFromQuery (f :*: g) where+  gParseQuery q = do+    a <- gParseQuery q+    b <- gParseQuery q+    pure $ a :*: b+++instance (GFromQuery f) => GFromQuery (M1 D d f) where+  gParseQuery q = M1 <$> gParseQuery q+++instance (GFromQuery f) => GFromQuery (M1 C c f) where+  gParseQuery q = M1 <$> gParseQuery q+++instance (Selector s, FromParam a, DefaultParam a) => GFromQuery (M1 S s (K1 R a)) where+  gParseQuery q = do+    let s = selName (undefined :: M1 S s (K1 R (f a)) p)+    let mval = lookup (Param $ pack s) q+    pure $ M1 $ K1 $ fromMaybe defaultParam mval+++-- | Generic encoding of records to a Query+class GToQuery f where+  gToQuery :: f p -> QueryData+++instance (GToQuery f, GToQuery g) => GToQuery (f :*: g) where+  gToQuery (f :*: g) = gToQuery f <> gToQuery g+++instance (GToQuery f) => GToQuery (M1 D d f) where+  gToQuery (M1 f) = gToQuery f+++instance (GToQuery f) => GToQuery (M1 C d f) where+  gToQuery (M1 f) = gToQuery f+++instance (Selector s, ToParam a, Eq a, DefaultParam a) => GToQuery (M1 S s (K1 R a)) where+  gToQuery (M1 (K1 a))+    | a == defaultParam = mempty+    | otherwise =+        let sel = Param $ pack $ selName (undefined :: M1 S s (K1 R (f a)) p)+         in singleton sel a+++-- | Data.Default doesn't have a Text instance. This class does+class DefaultParam a where+  defaultParam :: a+  default defaultParam :: (Default a) => a+  defaultParam = def+++instance {-# OVERLAPPABLE #-} (Default a) => DefaultParam a where+  defaultParam = def+++instance {-# OVERLAPS #-} DefaultParam Text where+  defaultParam = ""
+ src/Web/Hyperbole/Data/Session.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}++module Web.Hyperbole.Data.Session where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.String.Conversions (cs)+import Data.Text (Text)+import GHC.Generics+import Web.Hyperbole.Data.QueryData (Param (..), ParamValue (..), ToParam (..))+import Web.View.Types.Url (Segment)+++data Cookie = Cookie+  { key :: Param+  , value :: Maybe ParamValue+  , path :: Maybe [Segment]+  }+  deriving (Show, Eq)+newtype Cookies = Cookies (Map Param Cookie)+  deriving newtype (Monoid, Semigroup, Show, Eq)+++insert :: Cookie -> Cookies -> Cookies+insert cookie (Cookies m) =+  Cookies $ M.insert cookie.key cookie m+++delete :: Param -> Cookies -> Cookies+delete key (Cookies m) =+  Cookies $ M.delete key m++++lookup :: Param -> Cookies -> Maybe ParamValue+lookup key (Cookies m) = do+  cook <- M.lookup key m+  cook.value+++deletedCookie :: forall a. (Session a) => Cookie+deletedCookie =+  Cookie (sessionKey @a) Nothing (cookiePath @a)+++sessionCookie :: forall a. (Session a, ToParam a) => a -> Cookie+sessionCookie a = Cookie (sessionKey @a) (Just $ toParam a) (cookiePath @a)+++fromList :: [Cookie] -> Cookies+fromList cks = Cookies $ M.fromList (fmap keyValue cks)+ where+  keyValue c = (c.key, c)+++toList :: Cookies -> [Cookie]+toList (Cookies m) = M.elems m+++{- | Configure a data type to persist in the 'session'++@+#EMBED Example/Docs/Sessions.hs data Preferences++#EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences+@+-}+class Session a where+  -- | Unique key for the Session. Defaults to the datatypeName+  sessionKey :: Param+  default sessionKey :: (Generic a, GDatatypeName (Rep a)) => Param+  sessionKey = Param $ gDatatypeName $ from (undefined :: a)+++  -- | By default Sessions are persisted only to the current page. Set this to `Just []` to make an application-wide Session+  cookiePath :: Maybe [Segment]+  default cookiePath :: Maybe [Segment]+  cookiePath = Nothing+++-- | generic datatype name+class GDatatypeName f where+  gDatatypeName :: f p -> Text+++instance (Datatype d) => GDatatypeName (M1 D d f) where+  gDatatypeName _ =+    cs $ datatypeName (undefined :: M1 D d f p)
− src/Web/Hyperbole/Effect.hs 
@@ -1,395 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE NoFieldSelectors #-}--module Web.Hyperbole.Effect where--import Control.Monad (join)-import Data.Bifunctor (first)-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as BL-import Data.List qualified as List-import Data.String.Conversions-import Data.Text-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Error.Static-import Effectful.State.Static.Local-import Network.HTTP.Types hiding (Query)-import Web.FormUrlEncoded (Form, urlDecodeForm)-import Web.HttpApiData (FromHttpApiData, ToHttpApiData (..), parseQueryParam)-import Web.Hyperbole.HyperView-import Web.Hyperbole.Route-import Web.Hyperbole.Session as Session-import Web.View---newtype Host = Host {text :: BS.ByteString}-  deriving (Show)---data Request = Request-  { host :: Host-  , path :: [Segment]-  , query :: Query-  , body :: BL.ByteString-  , method :: Method-  , cookies :: [(BS.ByteString, BS.ByteString)]-  }-  deriving (Show)---{- | Valid responses for a 'Hyperbole' effect. Use 'notFound', etc instead. Reminds you to use 'load' in your 'Page'--> myPage :: (Hyperbole :> es) => Page es Response-> myPage = do->   -- compiler error: () does not equal Response->   pure ()--}-data Response-  = Response (View () ())-  | NotFound-  | Redirect Url-  | Err ResponseError-  | Empty---data ResponseError-  = ErrParse Text-  | ErrParam Text-  | ErrOther Text-  | ErrNotHandled (Event Text Text)-  | ErrAuth-  deriving (Show)---{- | Hyperbole applications are divided into Pages. Each Page must 'load' the whole page , and 'handle' each /type/ of 'HyperView'--@-myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'-myPage = do-  'handle' messages-  'load' pageView--pageView = do-  el_ "My Page"-  'hyper' (Message 1) $ messageView "Starting Message"-@--}-newtype Page es a = Page (Eff es a)-  deriving newtype (Applicative, Monad, Functor)----- | An action, with its corresponding id-data Event id act = Event-  { viewId :: id-  , action :: act-  }---instance (Show act, Show id) => Show (Event id act) where-  show e = "Event " <> show e.viewId <> " " <> show e.action----- | Low level effect mapping request/response to either HTTP or WebSockets-data Server :: Effect where-  LoadRequest :: Server m Request-  SendResponse :: Session -> Response -> Server m ()---type instance DispatchOf Server = 'Dynamic---{- | In any 'load' or 'handle', you can use this Effect to get extra request information or control the response manually.--For most 'Page's, you won't need to use this effect directly. Use custom 'Route's for request info, and return 'View's to respond--}-data Hyperbole :: Effect where-  GetRequest :: Hyperbole m Request-  RespondEarly :: Response -> Hyperbole m a-  SetSession :: (ToHttpApiData a) => Text -> a -> Hyperbole m ()-  DelSession :: Text -> Hyperbole m ()-  GetSession :: (FromHttpApiData a) => Text -> Hyperbole m (Maybe a)---type instance DispatchOf Hyperbole = 'Dynamic---data HyperState = HyperState-  { request :: Request-  , session :: Session-  }----- | Run the 'Hyperbole' effect to 'Server'-runHyperbole-  :: (Server :> es)-  => Eff (Hyperbole : es) Response-  -> Eff es Response-runHyperbole = fmap combine $ reinterpret runLocal $ \_ -> \case-  GetRequest -> do-    gets @HyperState (.request)-  RespondEarly r -> do-    s <- gets @HyperState (.session)-    send $ SendResponse s r-    throwError r-  SetSession k a -> do-    modify $ \st -> st{session = sessionSet k a st.session} :: HyperState-  DelSession k -> do-    modify $ \st -> st{session = sessionDel k st.session} :: HyperState-  GetSession k -> do-    s <- gets @HyperState (.session)-    pure $ sessionLookup k s- where-  runLocal :: (Server :> es) => Eff (State HyperState : Error Response : es) a -> Eff es (Either Response (a, HyperState))-  runLocal eff = do-    -- Load the request ONCE right when we start-    r <- send LoadRequest-    let st = HyperState r (sessionFromCookies r.cookies)-    runErrorNoCallStack @Response . runState st $ eff--  combine :: (Server :> es) => Eff es (Either Response (Response, HyperState)) -> Eff es Response-  combine eff = do-    er <- eff-    case er of-      Left res ->-        -- responded early, don't need to respond again-        pure res-      Right (res, st) -> do-        send $ SendResponse st.session res-        pure res----- | Return all information about the 'Request'-request :: (Hyperbole :> es) => Eff es Request-request = send GetRequest---{- | Return the request path-->>> reqPath-["users", "100"]--}-reqPath :: (Hyperbole :> es) => Eff es [Segment]-reqPath = (.path) <$> request---{- | Return the request body as a Web.FormUrlEncoded.Form--Prefer using Type-Safe 'Form's when possible--}-formData :: (Hyperbole :> es) => Eff es Form-formData = do-  b <- (.body) <$> request-  let ef = urlDecodeForm b-  -- not going to work. we need a way to `throwError` or it doesn't work...-  either (send . RespondEarly . Err . ErrParse) pure ef---getEvent :: (HyperView id, Hyperbole :> es) => Eff es (Maybe (Event id (Action id)))-getEvent = do-  q <- reqParams-  pure $ parseEvent q---parseEvent :: (HyperView id) => Query -> Maybe (Event id (Action id))-parseEvent q = do-  Event ti ta <- lookupEvent q-  vid <- parseParam ti-  act <- parseParam ta-  pure $ Event vid act---lookupEvent :: Query -> Maybe (Event Text Text)-lookupEvent q' =-  Event-    <$> lookupParam "id" q'-    <*> lookupParam "action" q'---{- | Lookup a session variable by keyword--> load $ do->   tok <- session "token"->   ...--}-session :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es (Maybe a)-session k = send $ GetSession k---{- | Set a session variable by keyword--> load $ do->   t <- reqParam "token"->   setSession "token" t->   ...--}-setSession :: (Hyperbole :> es, ToHttpApiData a) => Text -> a -> Eff es ()-setSession k v = send $ SetSession k v----- | Clear the user's session-clearSession :: (Hyperbole :> es) => Text -> Eff es ()-clearSession k = send $ DelSession k---{- | Return the entire 'Query'--@-myPage :: 'Page' es 'Response'-myPage = do-  'load' $ do-    q <- reqParams-    case 'lookupParam' "token" q of-      Nothing -> pure $ errorView "Missing Token in Query String"-      Just t -> do-        sideEffectUsingToken token-        pure myPageView-@--}-reqParams :: (Hyperbole :> es) => Eff es Query-reqParams = (.query) <$> request----- | Lookup the query param in the 'Query'-lookupParam :: BS.ByteString -> Query -> Maybe Text-lookupParam p q =-  fmap cs <$> join $ lookup p q---{- | Require a given parameter from the 'Query' arguments--@-myPage :: 'Page' es 'Response'-myPage = do-  'load' $ do-    token <- reqParam "token"-    sideEffectUsingToken token-    pure myPageView-@--}-reqParam :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es a-reqParam p = do-  q <- reqParams-  (er :: Either Response a) <- pure $ do-    mv <- require $ List.lookup (encodeUtf8 p) q-    v <- require mv-    first (Err . ErrParam) $ parseQueryParam (decodeUtf8 v)-  case er of-    Left e -> send $ RespondEarly e-    Right a -> pure a- where-  require :: Maybe x -> Either Response x-  require Nothing = Left $ Err $ ErrParam $ "Missing: " <> p-  require (Just a) = pure a---{- | Respond immediately with 404 Not Found--@-userLoad :: (Hyperbole :> es, Users :> es) => UserId -> Eff es User-userLoad uid = do-  mu <- send (LoadUser uid)-  maybe notFound pure mu--myPage :: (Hyperbole :> es, Users :> es) => Eff es View-myPage = do-  load $ do-    u <- userLoad 100-    -- skipped if user = Nothing-    pure $ userView u-@--}-notFound :: (Hyperbole :> es) => Eff es a-notFound = send $ RespondEarly NotFound----- | Respond immediately with a parse error-parseError :: (Hyperbole :> es) => Text -> Eff es a-parseError = send . RespondEarly . Err . ErrParse----- | Redirect immediately to the 'Url'-redirect :: (Hyperbole :> es) => Url -> Eff es a-redirect = send . RespondEarly . Redirect----- | Respond with the given view, and stop execution-respondEarly :: (Hyperbole :> es, HyperView id) => id -> View id () -> Eff es ()-respondEarly vid vw = do-  let res = Response $ hyper vid vw-  send $ RespondEarly res----- | Manually set the response to the given view. Normally you return a 'View' from 'load' or 'handle' instead of using this-view :: (Hyperbole :> es) => View () () -> Eff es Response-view vw = do-  pure $ Response vw---{- | The load handler is run when the page is first loaded. Run any side effects needed, then return a view of the full page--@-myPage :: (Hyperbole :> es) => UserId -> Page es Response-myPage userId = do-  'load' $ do-    user <- loadUserFromDatabase userId-    pure $ userPageView user-@--}-load-  :: (Hyperbole :> es)-  => Eff es (View () ())-  -> Page es Response-load run = Page $ do-  r <- request-  case lookupEvent r.query of-    -- Are id and action set to sometjhing?-    Just e ->-      pure $ Err $ ErrNotHandled e-    Nothing -> do-      vw <- run-      view vw---{- | A handler is run when an action for that 'HyperView' is triggered. Run any side effects needed, then return a view of the corresponding type--@-myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'-myPage = do-  'handle' messages-  'load' pageView--messages :: ('Hyperbole' :> es, MessageDatabase) => Message -> MessageAction -> 'Eff' es ('View' Message ())-messages (Message mid) ClearMessage = do-  deleteMessageSideEffect mid-  pure $ messageView ""--messages (Message mid) (Louder m) = do-  let new = m <> "!"-  saveMessageSideEffect mid new-  pure $ messageView new-@--}-handle-  :: forall id es-   . (Hyperbole :> es, HyperView id)-  => (id -> Action id -> Eff es (View id ()))-  -> Page es ()-handle run = Page $ do-  -- Get an event matching our type. If it doesn't match, skip to the next handler-  mev <- getEvent @id-  case mev of-    Just event -> do-      vw <- run event.viewId event.action-      send $ RespondEarly $ Response $ hyper event.viewId vw-    _ -> pure ()----- | Run a 'Page' in 'Hyperbole'-page-  :: (Hyperbole :> es)-  => Page es Response-  -> Eff es Response-page (Page eff) = eff
+ src/Web/Hyperbole/Effect/Event.hs view
@@ -0,0 +1,36 @@+module Web.Hyperbole.Effect.Event where++import Data.ByteString (ByteString)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Effectful+import Network.HTTP.Types (Query)+import Web.Hyperbole.Effect.Hyperbole (Hyperbole)+import Web.Hyperbole.Effect.Request (request)+import Web.Hyperbole.Effect.Server (Event (..), Request (..))+import Web.Hyperbole.HyperView (HyperView (..), ViewAction (..), ViewId (..))+++getEvent :: (HyperView id es, Hyperbole :> es) => Eff es (Maybe (Event id (Action id)))+getEvent = do+  q <- (.query) <$> request+  pure $ do+    Event ti ta <- lookupEvent q+    vid <- parseViewId ti+    act <- parseAction ta+    pure $ Event vid act+++lookupEvent :: Query -> Maybe (Event Text Text)+lookupEvent q = do+  viewId <- lookupParam "hyp-id" q+  action <- lookupParam "hyp-action" q+  pure $ Event{viewId, action}+++-- | Lower-level lookup straight from the request+lookupParam :: ByteString -> Query -> Maybe Text+lookupParam key q = do+  mval <- lookup key q+  val <- mval+  pure $ cs val
+ src/Web/Hyperbole/Effect/Handler.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}++module Web.Hyperbole.Effect.Handler where++import Data.Kind (Type)+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Reader.Dynamic+import Web.Hyperbole.Effect.Event (getEvent, lookupEvent)+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Request (request)+import Web.Hyperbole.Effect.Response (respondEarly)+import Web.Hyperbole.Effect.Server+import Web.Hyperbole.HyperView+import Web.View+++class RunHandlers (views :: [Type]) es where+  runHandlers :: (Hyperbole :> es) => Eff es ()+++instance RunHandlers '[] es where+  runHandlers = pure ()+++instance (HyperView view es, RunHandlers views es) => RunHandlers (view : views) es where+  runHandlers = do+    runHandler @view (update @view)+    runHandlers @views+++runHandler+  :: forall id es+   . (HyperView id es, Hyperbole :> es)+  => (Action id -> Eff (Reader id : es) (View id ()))+  -> Eff es ()+runHandler run = do+  -- Get an event matching our type. If it doesn't match, skip to the next handler+  mev <- getEvent @id :: Eff es (Maybe (Event id (Action id)))+  case mev of+    Just event -> do+      vw <- runReader event.viewId $ run event.action+      respondEarly event.viewId vw+    _ -> do+      pure ()+++runLoad+  :: forall views es+   . (Hyperbole :> es, RunHandlers views es)+  => Eff es (View (Root views) ())+  -> Eff es Response+runLoad loadPage = do+  runHandlers @views+  guardNoEvent+  loadToResponse loadPage+++guardNoEvent :: (Hyperbole :> es) => Eff es ()+guardNoEvent = do+  q <- (.query) <$> request+  case lookupEvent q of+    -- Are id and action set to something?+    Just e -> send $ RespondEarly $ Err $ ErrNotHandled e+    Nothing -> pure ()+++loadToResponse :: Eff es (View (Root total) ()) -> Eff es Response+loadToResponse run = do+  vw <- run+  let vid = TargetViewId (toViewId Root)+  let res = Response vid $ addContext Root vw+  pure res+++-- deriving newtype (Applicative, Monad, Functor)++{- | The load handler is run when the page is first loaded. Run any side effects needed, then return a view of the full page++@+myPage :: (Hyperbole :> es) => UserId -> Page es Response+myPage userId = do+  'load' $ do+    user <- loadUserFromDatabase userId+    pure $ userPageView user+@+-}++-- load+--   :: (Hyperbole :> es)+--   => Eff es (View (Root views) ())+--   -> Page views es Response+-- load run = Page $ do+--   r <- request+--   case lookupEvent r.query of+--     -- Are id and action set to sometjhing?+--     Just e ->+--       pure $ Err $ ErrNotHandled e+--     Nothing -> do+--       vw <- run+--       view vw++{- | A handler is run when an action for that 'HyperView' is triggered. Run any side effects needed, then return a view of the corresponding type++@+myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'+myPage = do+  'handle' messages+  'load' pageView++messages :: ('Hyperbole' :> es, MessageDatabase) => Message -> MessageAction -> 'Eff' es ('View' Message ())+messages (Message mid) ClearMessage = do+  deleteMessageSideEffect mid+  pure $ messageView ""++messages (Message mid) (Louder m) = do+  let new = m <> "!"+  saveMessageSideEffect mid new+  pure $ messageView new+@+-}++{- | Hyperbole applications are divided into Pages. Each Page must 'load' the whole page , and 'handle' each /type/ of 'HyperView'++@+myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'+myPage = do+  'handle' messages+  'load' pageView++pageView = do+  el_ "My Page"+  'hyper' (Message 1) $ messageView "Starting Message"+@+-}++-- pageView :: (Hyperbole :> es, Handlers views es) => View (Root views) () -> Eff es (Page views)+-- pageView = pure
+ src/Web/Hyperbole/Effect/Hyperbole.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UndecidableInstances #-}++module Web.Hyperbole.Effect.Hyperbole where++import Data.ByteString qualified as BS+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.State.Static.Local+import Web.Hyperbole.Data.QueryData (queryData)+import Web.Hyperbole.Effect.Server+++-- | The 'Hyperbole' 'Effect' allows you to access information in the 'Request', manually 'respondEarly', and manipulate the Client 'session' and 'query'.+data Hyperbole :: Effect where+  GetRequest :: Hyperbole m Request+  RespondEarly :: Response -> Hyperbole m a+  ModClient :: (Client -> Client) -> Hyperbole m ()+  GetClient :: Hyperbole m Client+++type instance DispatchOf Hyperbole = 'Dynamic+++-- | Run the 'Hyperbole' effect to 'Server'+runHyperbole+  :: (Server :> es)+  => Eff (Hyperbole : es) Response+  -> Eff es Response+runHyperbole = fmap combine $ reinterpret runLocal $ \_ -> \case+  GetRequest -> do+    gets @HyperState (.request)+  RespondEarly r -> do+    s <- gets @HyperState (.client)+    send $ SendResponse s r+    throwError_ r+  GetClient -> do+    gets @HyperState (.client)+  ModClient f -> do+    modify @HyperState $ \st -> st{client = f st.client}+ where+  runLocal :: (Server :> es) => Eff (State HyperState : Error Response : es) a -> Eff es (Either Response (a, HyperState))+  runLocal eff = do+    -- Load the request ONCE right when we start+    r <- send LoadRequest+    let client = Client mempty (queryData $ queryParams r)+    let st = HyperState r client+    runErrorNoCallStack @Response . runState st $ eff++  queryParams request =+    filter (not . isSystemParam) request.query++  isSystemParam (key, _) =+    "hyp-" `BS.isPrefixOf` key++  combine :: (Server :> es) => Eff es (Either Response (Response, HyperState)) -> Eff es Response+  combine eff = do+    er <- eff+    case er of+      Left res ->+        -- responded early, don't need to respond again+        pure res+      Right (res, st) -> do+        send $ SendResponse st.client res+        pure res+++data HyperState = HyperState+  { request :: Request+  , client :: Client+  }
+ src/Web/Hyperbole/Effect/Query.hs view
@@ -0,0 +1,86 @@+module Web.Hyperbole.Effect.Query where++import Data.String.Conversions (cs)+import Effectful+import Effectful.Dispatch.Dynamic (send)+import Web.Hyperbole.Data.QueryData (FromParam (..), FromQuery (..), Param, QueryData (..), ToParam (..), ToQuery (..))+import Web.Hyperbole.Data.QueryData qualified as QueryData+import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..))+import Web.Hyperbole.Effect.Server (Client (..), Response (..), ResponseError (..))+import Prelude+++{- | Parse querystring from the 'Request' into a datatype. See 'FromQuery'++@+#EMBED Example/Docs/Encoding.hs data Filters++#EMBED Example/Docs/Params.hs page+@+-}+query :: (FromQuery a, Hyperbole :> es) => Eff es a+query = do+  q <- queryParams+  case parseQuery q of+    Left e -> send $ RespondEarly $ Err $ ErrQuery $ "Query Parse " <> e <> " from " <> cs (show q)+    Right a -> pure a+++{- | Update the client's querystring to an encoded datatype. See 'ToQuery'++@+#EMBED Example/Docs/Params.hs instance HyperView Todos+@+-}+setQuery :: (ToQuery a, Hyperbole :> es) => a -> Eff es ()+setQuery a = do+  modifyQuery (const $ toQuery a)+++{- | Parse a single query parameter. Return a 400 status if missing or if parsing fails. See 'FromParam'++@+#EMBED Example/Docs/Params.hs page'+@+-}+param :: (FromParam a, Hyperbole :> es) => Param -> Eff es a+param p = do+  q <- queryParams+  case QueryData.require p q of+    Left e -> send $ RespondEarly $ Err $ ErrQuery e+    Right a -> pure a+++-- | Parse a single parameter from the query string if available+lookupParam :: (FromParam a, Hyperbole :> es) => Param -> Eff es (Maybe a)+lookupParam p = do+  QueryData.lookup p <$> queryParams+++{- | Modify the client's querystring to set a single parameter. See 'ToParam'++@+#EMBED Example/Docs/Params.hs instance HyperView Message+@+-}+setParam :: (ToParam a, Hyperbole :> es) => Param -> a -> Eff es ()+setParam key a = do+  modifyQuery (QueryData.insert key a)+++-- | Delete a single parameter from the query string+deleteParam :: (Hyperbole :> es) => Param -> Eff es ()+deleteParam key = do+  modifyQuery (QueryData.delete key)+++-- | Return the query from 'Request' as a 'QueryData'+queryParams :: (Hyperbole :> es) => Eff es QueryData+queryParams = do+  (.query) <$> send GetClient+++modifyQuery :: (Hyperbole :> es) => (QueryData -> QueryData) -> Eff es ()+modifyQuery f =+  send $ ModClient $ \client ->+    Client{query = f client.query, session = client.session}
+ src/Web/Hyperbole/Effect/Request.hs view
@@ -0,0 +1,33 @@+module Web.Hyperbole.Effect.Request where++import Effectful+import Effectful.Dispatch.Dynamic+import Web.FormUrlEncoded (Form, urlDecodeForm)+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Server+import Web.View+++-- | Return all information about the 'Request'+request :: (Hyperbole :> es) => Eff es Request+request = send GetRequest+++{- | Return the request path++>>> reqPath+["users", "100"]+-}+reqPath :: (Hyperbole :> es) => Eff es [Segment]+reqPath = (.path) <$> request+++{- | Return the request body as a Web.FormUrlEncoded.Form++Prefer using Type-Safe 'Form's when possible+-}+formBody :: (Hyperbole :> es) => Eff es Form+formBody = do+  b <- (.body) <$> request+  let ef = urlDecodeForm b+  either (send . RespondEarly . Err . ErrParse) pure ef
+ src/Web/Hyperbole/Effect/Response.hs view
@@ -0,0 +1,45 @@+module Web.Hyperbole.Effect.Response where++import Data.Text (Text)+import Effectful+import Effectful.Dispatch.Dynamic+import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..))+import Web.Hyperbole.Effect.Server (Response (..), ResponseError (..), TargetViewId (..))+import Web.Hyperbole.HyperView (HyperView (..), ViewId (..), hyperUnsafe)+import Web.View (Url, View)+++-- | Respond with the given view, and stop execution+respondEarly :: (Hyperbole :> es, HyperView id es) => id -> View id () -> Eff es ()+respondEarly i vw = do+  let vid = TargetViewId (toViewId i)+  let res = Response vid $ hyperUnsafe i vw+  send $ RespondEarly res+++{- | Respond immediately with 404 Not Found++@+#EMBED Example/Docs/App.hs findUser++#EMBED Example/Docs/App.hs userPage+@+-}+notFound :: (Hyperbole :> es) => Eff es a+notFound = send $ RespondEarly NotFound+++-- | Respond immediately with a parse error+parseError :: (Hyperbole :> es) => Text -> Eff es a+parseError = send . RespondEarly . Err . ErrParse+++-- | Redirect immediately to the 'Url'+redirect :: (Hyperbole :> es) => Url -> Eff es a+redirect = send . RespondEarly . Redirect+++-- | Manually set the response to the given view. Normally you would return a 'View' from 'runPage' instead+view :: (Hyperbole :> es) => View () () -> Eff es Response+view vw = do+  pure $ Response (TargetViewId "") vw
+ src/Web/Hyperbole/Effect/Server.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE LambdaCase #-}++module Web.Hyperbole.Effect.Server where++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.List qualified as L+import Data.Maybe (fromMaybe)+import Data.String.Conversions (cs)+import Data.Text (Text, pack)+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.State.Static.Local+import Network.HTTP.Types (HeaderName, Method, Query, status200, status400, status401, status404, status500, urlDecode, urlEncode)+import Network.Wai qualified as Wai+import Network.Wai.Internal (ResponseReceived (..))+import Network.WebSockets (Connection)+import Network.WebSockets qualified as WS+import Web.Cookie (parseCookies)+import Web.Hyperbole.Data.QueryData as QueryData+import Web.Hyperbole.Data.Session as Cookies+import Web.Hyperbole.Route+import Web.View (Segment, View, renderLazyByteString, renderUrl)+++-- | Low level effect mapping request/response to either HTTP or WebSockets+data Server :: Effect where+  LoadRequest :: Server m Request+  SendResponse :: Client -> Response -> Server m ()+++type instance DispatchOf Server = 'Dynamic+++runServerWai+  :: (IOE :> es)+  => (BL.ByteString -> BL.ByteString)+  -> Wai.Request+  -> (Wai.Response -> IO ResponseReceived)+  -> Eff (Server : es) a+  -> Eff es (Maybe Wai.ResponseReceived)+runServerWai toDoc req respond =+  reinterpret runLocal $ \_ -> \case+    LoadRequest -> do+      fromWaiRequest req+    SendResponse client r -> do+      rr <- liftIO $ sendResponse client r+      put (Just rr)+ where+  runLocal :: (IOE :> es) => Eff (State (Maybe ResponseReceived) : es) a -> Eff es (Maybe ResponseReceived)+  runLocal = execState Nothing++  sendResponse :: Client -> Response -> IO Wai.ResponseReceived+  sendResponse client r =+    respond $ response r+   where+    response :: Response -> Wai.Response+    response NotFound = respError status404 "Not Found"+    response Empty = respError status500 "Empty Response"+    response (Err (ErrParse e)) = respError status400 ("Parse Error: " <> cs e)+    response (Err (ErrQuery e)) = respError status400 $ "ErrQuery: " <> cs e+    response (Err (ErrSession param e)) = respError status400 $ "ErrSession: " <> cs (show param) <> " " <> cs e+    response (Err (ErrOther e)) = respError status500 $ "Server Error: " <> cs e+    response (Err ErrAuth) = respError status401 "Unauthorized"+    response (Err (ErrNotHandled e)) = respError status400 $ cs $ errNotHandled e+    response (Response _ vw) =+      respHtml $+        addDocument (Wai.requestMethod req) (renderLazyByteString vw)+    response (Redirect u) = do+      let url = renderUrl u+      -- We have to use a 200 javascript redirect because javascript+      -- will redirect the fetch(), while we want to redirect the whole page+      -- see index.ts sendAction()+      let headers = ("Location", cs url) : contentType ContentHtml : setCookies+      Wai.responseLBS status200 headers $ "<script>window.location = '" <> cs url <> "'</script>"++    respError s = Wai.responseLBS s [contentType ContentText]++    respHtml body =+      -- always set the session...+      let headers = contentType ContentHtml : (setCookies <> setQuery client.query)+       in Wai.responseLBS status200 headers body++    setCookies =+      fmap setCookie $ Cookies.toList client.session++    setCookie :: Cookie -> (HeaderName, BS.ByteString)+    setCookie cookie =+      ("Set-Cookie", renderCookie (Wai.pathInfo req) cookie)++    setQuery qd =+      [("Set-Query", QueryData.render qd)]++  -- convert to document if full page request. Subsequent POST requests will only include fragments+  addDocument :: Method -> BL.ByteString -> BL.ByteString+  addDocument "GET" bd = toDoc bd+  addDocument _ bd = bd++  fromWaiRequest :: (MonadIO m) => Wai.Request -> m Request+  fromWaiRequest wr = do+    body <- liftIO $ Wai.consumeRequestBodyLazy wr+    let path = Wai.pathInfo wr+        query = Wai.queryString wr+        headers = Wai.requestHeaders wr+        cookie = fromMaybe "" $ L.lookup "Cookie" headers+        host = Host $ fromMaybe "" $ L.lookup "Host" headers+        cookies = cookiesFromHeader (parseCookies cookie)+        method = Wai.requestMethod wr+    pure $ Request{body, path, query, method, cookies, host}+++renderCookie :: [Segment] -> Cookie -> BS.ByteString+renderCookie requestPath cookie =+  let path = fromMaybe requestPath cookie.path+   in key <> "=" <> value cookie.value <> "; SameSite=None; secure; path=" <> cs (renderUrl (pathUrl path))+ where+  key = cs cookie.key.text+  value Nothing = "; expires=Thu, 01 Jan 1970 00:00:00 GMT"+  value (Just val) = urlEncode True (cs val.text)+++cookiesFromHeader :: [(BS.ByteString, BS.ByteString)] -> Cookies+cookiesFromHeader cks = do+  Cookies.fromList $ fmap toCookie cks+ where+  toCookie (k, v) =+    let value = ParamValue (cs $ urlDecode True v)+        key = Param (cs k)+     in Cookie key (Just value) Nothing+++runServerSockets+  :: (IOE :> es)+  => Connection+  -> Request+  -> Eff (Server : es) Response+  -> Eff es Response+runServerSockets conn req = reinterpret runLocal $ \_ -> \case+  LoadRequest -> pure req -- receiveRequest conn+  SendResponse client res -> do+    case res of+      (Response vid vw) -> do+        let meta = sessionMetas client.session <> queryMeta client.query+        sendView meta vid vw+      (Err r) -> sendError r+      Empty -> sendError $ ErrOther "Empty"+      NotFound -> sendError $ ErrOther "NotFound"+      (Redirect url) -> sendRedirect (sessionMetas client.session) url+ where+  runLocal = runErrorNoCallStackWith @SocketError onSocketError++  onSocketError :: (IOE :> es) => SocketError -> Eff es Response+  onSocketError e = do+    let r = ErrOther $ cs $ show e+    sendError r+    pure $ Err r++  sendMessage :: (MonadIO m) => Metadata -> BL.ByteString -> m ()+  sendMessage meta cnt = do+    let msg = renderMetadata meta <> "\n" <> cnt+    liftIO $ WS.sendTextData conn msg++  sendError :: (IOE :> es) => ResponseError -> Eff es ()+  sendError r = do+    -- TODO: better error handling!+    sendMessage (metadata "ERROR" (pack (show r))) ""++  sendView :: (IOE :> es) => Metadata -> TargetViewId -> View () () -> Eff es ()+  sendView meta vid vw = do+    sendMessage (viewIdMeta vid <> meta) (renderLazyByteString vw)++  renderMetadata :: Metadata -> BL.ByteString+  renderMetadata (Metadata m) = BL.intercalate "\n" $ fmap (uncurry metaLine) m++  sendRedirect :: (IOE :> es) => Metadata -> Url -> Eff es ()+  sendRedirect meta u = do+    -- conn <- ask @Connection+    let r = metadata "REDIRECT" (renderUrl u)+    sendMessage (r <> meta) ""++  sessionMetas :: Cookies -> Metadata+  sessionMetas cookies = mconcat $ fmap cookieMeta $ Cookies.toList cookies++  cookieMeta :: Cookie -> Metadata+  cookieMeta cookie =+    Metadata [("COOKIE", cs (renderCookie req.path cookie))]++  queryMeta :: QueryData -> Metadata+  queryMeta q =+    Metadata [("QUERY", cs $ QueryData.render q)]++  viewIdMeta :: TargetViewId -> Metadata+  viewIdMeta (TargetViewId vid) = Metadata [("VIEW-ID", cs vid)]++  metadata :: BL.ByteString -> Text -> Metadata+  metadata name value = Metadata [(name, value)]++  metaLine :: BL.ByteString -> Text -> BL.ByteString+  metaLine name value = "|" <> name <> "|" <> cs value+++errNotHandled :: Event Text Text -> String+errNotHandled ev =+  L.intercalate+    "\n"+    [ "No Handler for Event viewId: " <> cs ev.viewId <> " action: " <> cs ev.action+    , "<p>Remember to add a `hyper` handler in your page function</p>"+    , "<pre>"+    , "page :: (Hyperbole :> es) => Page es Response"+    , "page = do"+    , "  handle contentsHandler"+    , "  load $ do"+    , "    pure $ hyper Contents contentsView"+    , "</pre>"+    ]+++data Client = Client+  { session :: Cookies+  , query :: QueryData+  }+++data SocketError+  = InvalidMessage Text+  deriving (Show, Eq)+++data ContentType+  = ContentHtml+  | ContentText+++contentType :: ContentType -> (HeaderName, BS.ByteString)+contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")+contentType ContentText = ("Content-Type", "text/plain; charset=utf-8")+++newtype Metadata = Metadata [(BL.ByteString, Text)]+  deriving newtype (Semigroup, Monoid)+++newtype Host = Host {text :: BS.ByteString}+  deriving (Show)+++data Request = Request+  { host :: Host+  , path :: [Segment]+  , query :: Query+  , body :: BL.ByteString+  , method :: Method+  , cookies :: Cookies+  }+  deriving (Show)+++-- | Valid responses for a 'Hyperbole' effect. Use 'notFound', etc instead.+data Response+  = Response TargetViewId (View () ())+  | NotFound+  | Redirect Url+  | Err ResponseError+  | Empty+++data ResponseError+  = ErrParse Text+  | ErrQuery Text+  | ErrSession Param Text+  | ErrOther Text+  | ErrNotHandled (Event Text Text)+  | ErrAuth+  deriving (Show)+++-- | Serialized ViewId+newtype TargetViewId = TargetViewId Text+++-- | An action, with its corresponding id+data Event id act = Event+  { viewId :: id+  , action :: act+  }+++instance (Show act, Show id) => Show (Event id act) where+  show e = "Event " <> show e.viewId <> " " <> show e.action
+ src/Web/Hyperbole/Effect/Session.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Web.Hyperbole.Effect.Session where++import Data.Maybe (fromMaybe)+import Effectful+import Effectful.Dispatch.Dynamic+import Web.Hyperbole.Data.QueryData+import Web.Hyperbole.Data.Session as Cookies+import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..))+import Web.Hyperbole.Effect.Request (request)+import Web.Hyperbole.Effect.Server (Client (..), Request (..), Response (..), ResponseError (..))+import Prelude+++{- | Persist datatypes in browser cookies. If the session doesn't exist, the 'DefaultParam' is used++@+#EMBED Example/Docs/Sessions.hs data Preferences++#EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences++#EMBED Example/Docs/Sessions.hs page+@+-}+session :: (Session a, DefaultParam a, FromParam a, Hyperbole :> es) => Eff es a+session = do+  ms <- lookupSession+  pure $ fromMaybe defaultParam ms+++-- | Return a session if it exists+lookupSession :: forall a es. (Session a, FromParam a, Hyperbole :> es) => Eff es (Maybe a)+lookupSession = do+  let key = sessionKey @a+  mck <- Cookies.lookup key <$> sessionCookies+  case mck of+    Nothing -> pure Nothing+    Just val -> parseSession key val+++{- | Persist datatypes in browser cookies++@+#EMBED Example/Docs/Sessions.hs data Preferences++#EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences++#EMBED Example/Docs/Sessions.hs instance HyperView Content+@+-}+saveSession :: (Session a, ToParam a, Hyperbole :> es) => a -> Eff es ()+saveSession a = do+  modifyCookies $ Cookies.insert (sessionCookie a)+++modifySession :: (Session a, DefaultParam a, ToParam a, FromParam a, Hyperbole :> es) => (a -> a) -> Eff es a+modifySession f = do+  s <- session+  let updated = f s+  saveSession updated+  pure updated+++modifySession_ :: (Session a, DefaultParam a, ToParam a, FromParam a, Hyperbole :> es) => (a -> a) -> Eff es ()+modifySession_ f = do+  _ <- modifySession f+  pure ()+++-- | Remove a single 'Session' from the browser cookies+deleteSession :: forall a es. (Session a, Hyperbole :> es) => Eff es ()+deleteSession = do+  modifyCookies $ Cookies.insert (deletedCookie @a)+++parseSession :: (FromParam a, Hyperbole :> es) => Param -> ParamValue -> Eff es a+parseSession prm val = do+  case parseParam val of+    Left e -> send $ RespondEarly $ Err $ ErrSession prm e+    Right a -> pure a+++-- | save a single datatype to a specific key in the session+setCookie :: (ToParam a, Hyperbole :> es) => Cookie -> Eff es ()+setCookie ck = do+  modifyCookies (Cookies.insert ck)+++-- | Modify the client cookies+modifyCookies :: (Hyperbole :> es) => (Cookies -> Cookies) -> Eff es ()+modifyCookies f =+  send $ ModClient $ \client ->+    Client{session = f client.session, query = client.query}+++-- | Return all the cookies, both those sent in the request and others added by the page+sessionCookies :: (Hyperbole :> es) => Eff es Cookies+sessionCookies = do+  clt <- clientSessionCookies+  req <- requestSessionCookies+  pure $ clt <> req+++-- | Return the session from the Client cookies+clientSessionCookies :: (Hyperbole :> es) => Eff es Cookies+clientSessionCookies = do+  (.session) <$> send GetClient+++-- | Return the session from the 'Request' cookies+requestSessionCookies :: (Hyperbole :> es) => Eff es Cookies+requestSessionCookies = do+  (.cookies) <$> request
− src/Web/Hyperbole/Embed.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Web.Hyperbole.Embed-  ( cssResetEmbed-  , cssResetLink-  , scriptEmbed-  )-where--import Data.ByteString-import Data.FileEmbed-import Web.View.Reset---scriptEmbed :: ByteString-scriptEmbed = $(embedFile "client/dist/hyperbole.js")
− src/Web/Hyperbole/Forms.hs 
@@ -1,361 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DefaultSignatures #-}--module Web.Hyperbole.Forms-  ( FormFields (..)-  , InputType (..)-  , Label-  , Invalid-  , Input (..)-  , field-  , label-  , input-  , form-  , placeholder-  , submit-  , parseForm-  , formField-  , Form (..)-  , defaultFormOptions-  , FormOptions (..)-  , genericFromForm-  , Validation (..)-  , FormField (..)-  , lookupInvalid-  , invalidStyle-  , invalidText-  , validate-  , validation--    -- * Re-exports-  , FromHttpApiData-  , Generic-  )-where--import Data.Functor.Identity (Identity)-import Data.Kind (Type)-import Data.Maybe (catMaybes)-import Data.Text-import Effectful-import GHC.Generics-import Text.Casing (kebab)-import Web.FormUrlEncoded qualified as FE-import Web.HttpApiData (FromHttpApiData (..))-import Web.Hyperbole.Effect-import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)-import Web.Internal.FormUrlEncoded (FormOptions (..), GFromForm, defaultFormOptions, genericFromForm)-import Web.View hiding (form, input, label)----- | The only time we can use Fields is inside a form-data FormFields id = FormFields id Validation---instance (Param id) => Param (FormFields id) where-  parseParam t = do-    i <- parseParam t-    pure $ FormFields i mempty-  toParam (FormFields i _) = toParam i---instance (HyperView id, Param id) => HyperView (FormFields id) where-  type Action (FormFields id) = Action id----- | Choose one for 'input's to give the browser autocomplete hints-data InputType-  = -- TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete-    NewPassword-  | CurrentPassword-  | Username-  | Email-  | Number-  | TextInput-  | Name-  | OneTimeCode-  | Organization-  | StreetAddress-  | Country-  | CountryName-  | PostalCode-  | Search-  deriving (Show)---{- | Validation results for a 'form'--@-validateUser :: User -> Age -> Validation-validateUser (User u) (Age a) =-  validation-    [ 'validate' \@Age (a < 20) "User must be at least 20 years old"-    , 'validate' \@User (T.elem ' ' u) "Username must not contain spaces"-    , 'validate' \@User (T.length u < 4) "Username must be at least 4 chars"-    ]--formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())-formAction _ SignUp = do-  a <- 'formField' \@Age-  u <- 'formField' \@User--  case validateUser u a of-    'Validation' [] -> successView-    errs -> userForm v-@-@--}-newtype Validation = Validation [(Text, Text)]-  deriving newtype (Semigroup, Monoid)----- | Create a 'Validation' from list of validators-validation :: [Maybe (Text, Text)] -> Validation-validation = Validation . catMaybes---invalidStyle :: forall a. (FormField a) => Mod -> Validation -> Mod-invalidStyle f errs =-  case lookupInvalid @a errs of-    Nothing -> id-    Just _ -> f---lookupInvalid :: forall a. (FormField a) => Validation -> Maybe Text-lookupInvalid (Validation es) = lookup (inputName @a) es---{- | Display any validation error for the 'FormField' from the 'Validation' passed to 'form'--@-'field' \@User id Style.invalid $ do-  'label' \"Username\"-  'input' Username ('placeholder' "username")-  el_ 'invalidText'-@--}-invalidText :: forall a id. (FormField a) => View (Input id a) ()-invalidText = do-  Input _ v <- context-  maybe none text $ lookupInvalid @a v----- | specify a check for a 'Validation'-validate :: forall a. (FormField a) => Bool -> Text -> Maybe (Text, Text)-validate True t = Just (inputName @a, t)-validate False _ = Nothing---data Label a---data Invalid a---data Input id a = Input Text Validation---{- | Display a 'FormField'--@-data Age = Age Int deriving (Generic, FormField)--myForm = do-  'form' SignUp mempty id $ do-    field @Age id id $ do-     'label' "Age"-     'input' Number (value "0")-@--}-field :: forall a id. (FormField a) => Mod -> Mod -> View (Input id a) () -> View (FormFields id) ()-field f inv cnt = do-  let n = inputName @a-  FormFields _ v <- context-  tag "label" (f . flexCol . invalidStyle @a inv v) $-    addContext (Input n v) cnt----- | label for a 'field'-label :: Text -> View (Input id a) ()-label = text----- | input for a 'field'-input :: InputType -> Mod -> View (Input id a) ()-input ft f = do-  Input nm _ <- context-  tag "input" (f . name nm . att "type" (inpType ft) . att "autocomplete" (auto ft)) none- where-  inpType NewPassword = "password"-  inpType CurrentPassword = "password"-  inpType Number = "number"-  inpType Email = "email"-  inpType Search = "search"-  inpType _ = "text"--  auto :: InputType -> Text-  auto = pack . kebab . show---placeholder :: Text -> Mod-placeholder = att "placeholder"---{- | Type-safe \<form\>. Calls (Action id) on submit--@-userForm :: 'Validation' -> 'View' FormView ()-userForm v = do-  form Signup v id $ do-    el Style.h1 "Sign Up"--    'field' \@User id Style.invalid $ do-      'label' \"Username\"-      'input' Username ('placeholder' "username")-      el_ 'invalidText'--    'field' \@Age id Style.invalid $ do-      'label' \"Age\"-      'input' Number ('placeholder' "age" . value "0")-      el_ 'invalidText'--    'submit' (border 1) \"Submit\"-@--}-form :: forall id. (HyperView id) => Action id -> Validation -> Mod -> View (FormFields id) () -> View id ()-form a v f cnt = do-  vid <- context-  -- let frm = formLabels :: form Label-  -- let cnt = fcnt frm-  tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid v) cnt- where-  onSubmit :: (Param a) => a -> Mod-  onSubmit = att "data-on-submit" . toParam----- | Button that submits the 'form'. Use 'button' to specify actions other than submit-submit :: Mod -> View (FormFields id) () -> View (FormFields id) ()-submit f = tag "button" (att "type" "submit" . f)---type family Field' (context :: Type -> Type) a-type instance Field' Identity a = a-type instance Field' Label a = Text-type instance Field' Invalid a = Maybe Text---parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity)-parseForm = do-  f <- formData-  let ef = fromForm f :: Either Text (form Identity)-  either parseError pure ef---{- | Parse a 'FormField' from the request--@-formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())-formAction _ SignUp = do-  a <- formField \@Age-  u <- formField \@User-  saveUserToDB u a-  pure $ el_ "Saved!"-@--}-formField :: forall a es. (FormField a, Hyperbole :> es) => Eff es a-formField = do-  f <- formData-  case fieldParse (inputName @a) f of-    Left e -> parseError e-    Right a -> pure a---class Form (form :: (Type -> Type) -> Type) where-  formLabels :: form Label-  default formLabels :: (Generic (form Label), GForm (Rep (form Label))) => form Label-  formLabels = to gForm---  formInvalid :: form Invalid-  default formInvalid :: (Generic (form Invalid), GForm (Rep (form Invalid))) => form Invalid-  formInvalid = to gForm---  fromForm :: FE.Form -> Either Text (form Identity)-  default fromForm :: (Generic (form Identity), GFromForm (form Identity) (Rep (form Identity))) => FE.Form -> Either Text (form Identity)-  fromForm = genericFromForm defaultFormOptions----- | Automatically derive labels from form field names-class GForm f where-  gForm :: f p---instance GForm U1 where-  gForm = U1---instance (GForm f, GForm g) => GForm (f :*: g) where-  gForm = gForm :*: gForm---instance (GForm f) => GForm (M1 D d f) where-  gForm = M1 gForm---instance (GForm f) => GForm (M1 C c f) where-  gForm = M1 gForm---instance (Selector s) => GForm (M1 S s (K1 R Text)) where-  gForm = M1 . K1 $ pack (selName (undefined :: M1 S s (K1 R Text) p))---instance GForm (M1 S s (K1 R (Maybe Text))) where-  gForm = M1 . K1 $ Nothing---{- | Form Fields are identified by a type--@-data User = User Text deriving (Generic, FormField)-data Age = Age Int deriving (Generic, FormField)-@--}-class FormField a where-  inputName :: Text-  default inputName :: (Generic a, GDataName (Rep a)) => Text-  inputName = gDataName (from (undefined :: a))---  fieldParse :: Text -> FE.Form -> Either Text a-  default fieldParse :: (Generic a, GFieldParse (Rep a)) => Text -> FE.Form -> Either Text a-  fieldParse t f = to <$> gFieldParse t f---class GDataName f where-  gDataName :: f p -> Text---instance (Datatype d) => GDataName (M1 D d (M1 C c f)) where-  gDataName m1 = pack $ datatypeName m1---class GFieldParse f where-  gFieldParse :: Text -> FE.Form -> Either Text (f p)---instance (GFieldParse f) => GFieldParse (M1 D d f) where-  gFieldParse t f = M1 <$> gFieldParse t f---instance (GFieldParse f) => GFieldParse (M1 C c f) where-  gFieldParse t f = M1 <$> gFieldParse t f---instance (GFieldParse f) => GFieldParse (M1 S s f) where-  gFieldParse t f = M1 <$> gFieldParse t f---instance (FromHttpApiData a) => GFieldParse (K1 R a) where-  gFieldParse t f = K1 <$> FE.parseUnique t f
src/Web/Hyperbole/HyperView.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}  module Web.Hyperbole.HyperView where -import Control.Applicative ((<|>))-import Control.Monad (guard)-import Data.Kind (Type)-import Data.Text (Text, pack, unpack)-import Data.Text qualified as T-import GHC.Generics-import Text.Read-import Web.Hyperbole.Route (Route (..), routeUrl)-import Web.View+import Data.Kind (Constraint, Type)+import Data.Text (Text)+import Effectful+import Effectful.Reader.Dynamic+import GHC.TypeLits hiding (Mod)+import Web.Hyperbole.Data.QueryData (ParamValue (..), readQueryParam, showQueryParam)+import Web.Hyperbole.Effect.Hyperbole (Hyperbole)+import Web.Hyperbole.TypeList+import Web.View (View, addContext, att, context, el, flexCol, none)   {- | HyperViews are interactive subsections of a 'Page'@@ -18,308 +19,199 @@ Create an instance with a unique view id type and a sum type describing the actions the HyperView supports. The View Id can contain context (a database id, for example)  @-data Message = Message Int-  deriving (Generic, 'Param')--data MessageAction-  = Louder Text-  | ClearMessage-  deriving (Generic, 'Param')+#EMBED Example/Docs/Interactive.hs data Message -instance HyperView Message where-  type Action Message = MessageAction+#EMBED Example/Docs/Interactive.hs instance HyperView Message es where @ -}-class (Param id, Param (Action id)) => HyperView id where-  type Action id :: Type+class (ViewId id, ViewAction (Action id)) => HyperView id es where+  -- | Outline all actions that are permitted in this HyperView+  --+  -- > data Action Message = SetMessage Text | ClearMessage+  -- >   deriving (Show, Read, ViewAction)+  data Action id  -{- | Embed HyperViews into the page, or nest them into other views+  -- | Include any child hyperviews here. The compiler will make sure that the page knows how to handle them+  --+  -- > type Require = '[ChildView]+  type Require id :: [Type] -@-myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'-myPage = do-  'handle' messages-  'load' $ do-    pure $ do-      'el_' "My Page"-      'hyper' (Message 1) $ messageView "Hello World"-      'hyper' (Message 2) $ do-        messageView "Another Message"-        'hyper' OtherView otherView-@ -Views can only trigger actions that match their HyperView+  type Require id = '[] -@-messageView :: Text -> View Message ()-messageView m = do-  el_ (text m)-  button (Louder m) "Louder" -otherView :: View OtherView ()-otherView = do-  -- Type Error!-  button (Louder \"Hi\") id "Louder"-@--}-hyper :: forall id ctx. (HyperView id) => id -> View id () -> View ctx ()-hyper vid vw = do-  el (att "id" (toParam vid) . flexCol) $-    addContext vid vw+  -- | Specify how the view should be updated for each Action+  --+  -- > update (SetMessage msg) = pure $ messageView msg+  -- > update ClearMessage = pure $ messageView ""+  update :: (Hyperbole :> es) => Action id -> Eff (Reader id : es) (View id ())  -{- | \<button\> HTML tag which sends the action when pressed--> button SomeAction (border 1) "Click Me"--}-button :: (HyperView id) => Action id -> Mod -> View id () -> View id ()-button a f cd = do-  c <- context-  tag "button" (att "data-on-click" (toParam a) . dataTarget c . f) cd+-- | The top-level view returned by a 'Page'. It carries a type-level list of every 'HyperView' used in our 'Page' so the compiler can check our work and wire everything together.+data Root (views :: [Type]) = Root+  deriving (Show, Read, ViewId)  -{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling--@-pollMessageView :: Text -> 'View' Message ()-pollMessageView m = do-  onLoad LoadMessage 1000 $ do-    'el' 'bold' "Current Message. Reloading in 1s"-    'el_' ('text' m)-@--}-onLoad :: (HyperView id) => Action id -> DelayMs -> View id () -> View id ()-onLoad a delay initContent = do-  c <- context-  el (att "data-on-load" (toParam a) . att "data-delay" (toParam delay) . dataTarget c) initContent+instance HyperView (Root views) es where+  data Action (Root views) = RootNone+    deriving (Show, Read, ViewAction)+  type Require (Root views) = views+  update _ = pure none  -type DelayMs = Int+type family ValidDescendents x :: [Type] where+  ValidDescendents x = x : NextDescendents '[] '[x]  -{- | Give visual feedback when an action is in-flight.--@-myView = do-  onRequest loadingIndicator $ do-    'el_' \"Loaded\"-  where-    loadingIndicator = 'el_' "Loading..."-@--}-onRequest :: View id () -> View id () -> View id ()-onRequest a b = do-  el (parent "hyp-loading" flexCol . hide) a-  el (parent "hyp-loading" hide . flexCol) b+type family NextDescendents (ex :: [Type]) (xs :: [Type]) where+  NextDescendents _ '[] = '[]+  NextDescendents ex (x ': xs) =+    RemoveAll (x : ex) (Require x)+      <++> NextDescendents ((x : ex) <++> Require x) (RemoveAll (x : ex) (Require x))+      <++> NextDescendents (x : ex) (RemoveAll (x : ex) xs)  --- | Internal-dataTarget :: (Param a) => a -> Mod-dataTarget = att "data-target" . toParam+type NotHandled id ctx (views :: [Type]) =+  TypeError+    ( 'Text "HyperView "+        :<>: 'ShowType id+        :<>: 'Text " not found in (Require "+        :<>: 'ShowType ctx+        :<>: 'Text ")"+        :$$: 'Text "  "+          :<>: 'ShowType views+        :$$: 'Text "Try adding it to the HyperView instance:"+        :$$: 'Text "  instance HyperView "+          :<>: 'ShowType ctx+          :<>: 'Text " where"+        :$$: 'Text "    type Action "+          :<>: 'ShowType ctx+          :<>: 'Text " = "+          :<>: ShowType (Action id)+          :<>: 'Text ""+        :$$: 'Text "    type Require "+          :<>: 'ShowType ctx+          :<>: 'Text " = ["+          :<>: ShowType id+          :<>: 'Text ", ...]"+    )  -{- | Trigger actions for another view. They will update the view specified--> otherView :: View OtherView ()-> otherView = do->   el_ "This is not a message view"->   button OtherAction id "Do Something"->->   target (Message 2) $ do->     el_ "Now we can trigger a MessageAction which will update our Message HyperView, not this one"->     button ClearMessage id "Clear Message #2"--}-target :: (HyperView id) => id -> View id () -> View a ()-target = addContext+type NotDesc id ctx x cs =+  TypeError+    ( 'Text ""+        :<>: 'ShowType x+        :<>: 'Text ", a child of HyperView "+        :<>: 'ShowType id+        :<>: 'Text ", not handled by context "+        :<>: 'ShowType ctx+        :$$: ('Text " Require = " ':<>: 'ShowType cs)+        -- ':$$: 'ShowType x+        -- ':$$: 'ShowType cs+    )  -{- | Type-safe dropdown. Sends (opt -> Action id) when selected. The selection predicate (opt -> Bool) controls which option is selected. See [Example.Contacts](https://github.com/seanhess/hyperbole/blob/main/example/Example/Contacts.hs)--@-data ContactsAction-  = Reload (Maybe Filter)-  | Delete Int-  deriving (Generic, Param)--allContactsView :: Maybe Filter -> View Contacts ()-allContactsView fil = do-  row (gap 10) $ do-    el (pad 10) "Filter: "-    dropdown Reload (== fil) id $ do-      option Nothing ""-      option (Just Active) "Active!"-      option (Just Inactive) "Inactive"-  ...-@--}-dropdown-  :: (HyperView id)-  => (opt -> Action id)-  -> (opt -> Bool) -- check if selec-  -> Mod-  -> View (Option opt id (Action id)) ()-  -> View id ()-dropdown toAction isSel f options = do-  c <- context-  tag "select" (att "data-on-change" "" . dataTarget c . f) $ do-    addContext (Option toAction isSel) options+type NotInPage x total =+  TypeError+    ( 'Text ""+        :<>: 'ShowType x+        :<>: 'Text " not included in: "+        :$$: 'Text "  Page es "+          :<>: ShowType total+        :$$: 'Text "try expanding the page views to:"+        :$$: 'Text "  Page es "+          :<>: ShowType (x : total)+          -- :$$: 'Text " " :<>: 'ShowType ctx :<>: 'Text " = " :<>: ShowType (Action id) :<>: 'Text ""+          -- :$$: 'Text "    page :: (Hyperbole :> es) => Page es '[" :<>: 'ShowType ctx :<>: 'Text " = [" :<>: ShowType id :<>: 'Text ", ...]"+    )  --- | An option for a 'dropdown'. First argument is passed to (opt -> Action id) in the 'dropdown', and to the selected predicate-option-  :: (HyperView id, Eq opt)-  => opt-  -> View (Option opt id (Action id)) ()-  -> View (Option opt id (Action id)) ()-option opt cnt = do-  os <- context-  tag "option" (att "value" (toParam (os.toAction opt)) . selected (os.selected opt)) cnt+type HyperViewHandled id ctx =+  ( -- the id must be found in the children of the context+    ElemOr id (Require ctx) (NotHandled id ctx (Require ctx))+  , -- Make sure the descendents of id are in the context for the root page+    CheckDescendents id ctx+  )  --- | sets selected = true if the 'dropdown' predicate returns True-selected :: Bool -> Mod-selected b = if b then att "selected" "true" else id+-- TODO: Report which view requires the missing one+type family CheckDescendents id ctx :: Constraint where+  CheckDescendents id (Root total) =+    ( AllInPage (ValidDescendents id) total+    )+  CheckDescendents id ctx = ()  --- | The view context for an 'option'-data Option opt id action = Option-  { toAction :: opt -> action-  , selected :: opt -> Bool-  }+type family AllInPage ids total :: Constraint where+  AllInPage '[] _ = ()+  AllInPage (x ': xs) total =+    (ElemOr x total (NotInPage x total), AllInPage xs total)  -{- | Types that can be serialized. 'HyperView' requires this for both its view id and action+{- | Embed a 'HyperView' into another 'View' -> data Message = Message Int->   deriving (Generic, Param)+@+#EMBED Example/Docs/Interactive.hs page+@ -}-class Param a where-  toParam :: a -> Text-  default toParam :: (Generic a, GParam (Rep a)) => a -> Text-  toParam = gToParam . from---  -- not as flexible as FromHttpApiData, but derivable-  parseParam :: Text -> Maybe a-  default parseParam :: (Generic a, GParam (Rep a)) => Text -> Maybe a-  parseParam t = to <$> gParseParam t---class GParam f where-  gToParam :: f p -> Text-  gParseParam :: Text -> Maybe (f p)---instance (GParam f, GParam g) => GParam (f :*: g) where-  gToParam (a :*: b) = gToParam a <> "-" <> gToParam b-  gParseParam t = do-    let (at, bt) = breakSegment t-    a <- gParseParam at-    b <- gParseParam bt-    pure $ a :*: b---instance (GParam f, GParam g) => GParam (f :+: g) where-  gToParam (L1 a) = gToParam a-  gToParam (R1 b) = gToParam b-  gParseParam t = do-    (L1 <$> gParseParam @f t) <|> (R1 <$> gParseParam @g t)----- do we add the datatypename? no, the constructor name-instance (Datatype d, GParam f) => GParam (M1 D d f) where-  gToParam (M1 a) = gToParam a-  gParseParam t = M1 <$> gParseParam t---instance (Constructor c, GParam f) => GParam (M1 C c f) where-  gToParam (M1 a) =-    let cn = toSegment (conName (undefined :: M1 C c f p))-     in case gToParam a of-          "" -> cn-          t -> cn <> "-" <> t-  gParseParam t = do-    let (c, rest) = breakSegment t-    guard $ c == toSegment (conName (undefined :: M1 C c f p))-    M1 <$> gParseParam rest---instance GParam U1 where-  gToParam _ = ""-  gParseParam _ = pure U1+hyper+  :: forall id ctx+   . (HyperViewHandled id ctx, ViewId id)+  => id+  -> View id ()+  -> View ctx ()+hyper = hyperUnsafe  -instance (GParam f) => GParam (M1 S s f) where-  gToParam (M1 a) = gToParam a-  gParseParam t = M1 <$> gParseParam t+hyperUnsafe :: (ViewId id) => id -> View id () -> View ctx ()+hyperUnsafe vid vw = do+  el (att "id" (toViewId vid) . flexCol) $+    addContext vid vw  -instance GParam (K1 R Text) where-  gToParam (K1 t) = t-  gParseParam t = pure $ K1 t+class ViewAction a where+  toAction :: a -> Text+  default toAction :: (Show a) => a -> Text+  toAction = (.text) . showQueryParam  -instance GParam (K1 R String) where-  gToParam (K1 s) = pack s-  gParseParam t = pure $ K1 $ unpack t+  parseAction :: Text -> Maybe a+  default parseAction :: (Read a) => Text -> Maybe a+  parseAction t =+    either (const Nothing) pure $ readQueryParam (ParamValue t)  -instance {-# OVERLAPPABLE #-} (Param a) => GParam (K1 R a) where-  gToParam (K1 a) = toParam a-  gParseParam t = K1 <$> parseParam t+instance ViewAction () where+  toAction _ = ""+  parseAction _ = Just ()  --- instance {-# OVERLAPPABLE #-} (Show a, Read a) => GParam (K1 R a) where---   gToParam (K1 a) = pack $ show a---   gParseParam t = do---     K1 <$> readMaybe (unpack t)--breakSegment :: Text -> (Text, Text)-breakSegment t =-  let (start, rest) = T.breakOn "-" t-   in (start, T.drop 1 rest)+class ViewId a where+  toViewId :: a -> Text+  default toViewId :: (Show a) => a -> Text+  toViewId = (.text) . showQueryParam  -toSegment :: String -> Text-toSegment = T.toLower . pack+  parseViewId :: Text -> Maybe a+  default parseViewId :: (Read a) => Text -> Maybe a+  parseViewId t =+    either (const Nothing) pure $ readQueryParam (ParamValue t)  --- instance (GParam f) => GParam (M1 C c f) where---   gForm = M1 gForm---- where---  toDouble '\'' = '\"'---  toDouble c = c--instance (Param a) => Param (Maybe a) where-  toParam Nothing = ""-  toParam (Just a) = toParam a-  parseParam "" = pure Nothing-  parseParam t = Just $ parseParam t-instance Param Integer where-  toParam = pack . show-  parseParam = readMaybe . unpack-instance Param Float where-  toParam = pack . show-  parseParam = readMaybe . unpack-instance Param Int where-  toParam = pack . show-  parseParam = readMaybe . unpack-instance Param () where-  toParam = pack . show-  parseParam = readMaybe . unpack+{- | Access the 'viewId' in a 'View' or 'update' +@+#EMBED Example/Page/Contact.hs data Contact -instance Param Text where-  parseParam = pure-  toParam = id+#EMBED Example/Page/Contact.hs instance (Users :> es+@+-}+class HasViewId m view where+  viewId :: m view  -{- | A hyperlink to another route-->>> route (User 100) id "View User"-<a href="/user/100">View User</a>--}-route :: (Route a) => a -> Mod -> View c () -> View c ()-route r = link (routeUrl r)+instance HasViewId (View ctx) ctx where+  viewId = context+instance HasViewId (Eff (Reader view : es)) view where+  viewId = ask
+ src/Web/Hyperbole/Page.hs view
@@ -0,0 +1,33 @@+module Web.Hyperbole.Page where++import Data.Kind (Type)+import Effectful+import Web.Hyperbole.Effect.Handler (RunHandlers, runLoad)+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Server (Response)+import Web.Hyperbole.HyperView (Root)+import Web.View (View)+++{- | Conceptually, an application is dividied up into multiple [Pages](#g:pages). Each page module should have a function that returns a 'Page'. The 'Page' itself is a 'View' with a type-level list of 'HyperView's used on the page.++@+#EMBED Example/Docs/MultiView.hs page+@+-}+type Page (views :: [Type]) = View (Root views) ()+++{- | Run a 'Page' and return a 'Response'++@+#EMBED Example/Docs/BasicPage.hs main++#EMBED Example/Docs/BasicPage.hs page+@+-}+runPage+  :: (Hyperbole :> es, RunHandlers views es)+  => Eff es (Page views)+  -> Eff es Response+runPage = runLoad
src/Web/Hyperbole/Route.hs view
@@ -22,50 +22,58 @@  {- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns -> data AppRoute->  = HomePage->  | Users->  | User Int->  deriving (Generic, Route)->-> /         -> HomePage-> /users/   -> Users-> /user/100 -> User 100--}-class Route a where-  -- | The default route to use if attempting to match on empty segments-  defRoute :: a+@+#EMBED Example/Docs/App.hs data AppRoute +#EMBED Example/Docs/App.hs instance Route+@ -  -- | Map a route to segments-  routePath :: a -> [Segment]+>>> routeUrl Main+/ +>>> routeUrl (User 9)+/user/9+-}+class Route a where+  -- | The route to use if attempting to match on empty segments+  baseRoute :: Maybe a+  default baseRoute :: (Generic a, GenRoute (Rep a)) => Maybe a+  baseRoute = Nothing +   -- | Try to match segments to a route   matchRoute :: [Segment] -> Maybe a   default matchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a   -- this will match a trailing slash, but not if it is missing-  matchRoute [""] = pure defRoute-  matchRoute [] = pure defRoute-  matchRoute segs = to <$> genRoute segs+  matchRoute segs =+    case (segs, baseRoute) of+      ([""], Just b) -> pure b+      ([], Just b) -> pure b+      (_, _) -> genMatchRoute segs  +  -- | Map a route to segments+  routePath :: a -> [Segment]   default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> [Segment]   routePath p-    | p == defRoute = []-    | otherwise = filter (not . T.null) $ genPaths $ from p---  default defRoute :: (Generic a, GenRoute (Rep a)) => a-  defRoute = to genFirst+    | Just p == baseRoute = []+    | otherwise = genRoutePath p   -- | Try to match a route, use 'defRoute' if it's empty findRoute :: (Route a) => [Segment] -> Maybe a-findRoute [] = Just defRoute+findRoute [] = baseRoute findRoute ps = matchRoute ps  +genMatchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a+genMatchRoute segs = to <$> genRoute segs+++genRoutePath :: (Generic a, GenRoute (Rep a)) => a -> [Segment]+genRoutePath = genPaths . from++ {- | Convert a 'Route' to a 'Url'  >>> routeUrl (User 100)@@ -79,14 +87,12 @@ class GenRoute f where   genRoute :: [Text] -> Maybe (f p)   genPaths :: f p -> [Text]-  genFirst :: f p   -- datatype metadata instance (GenRoute f) => GenRoute (M1 D c f) where   genRoute ps = M1 <$> genRoute ps   genPaths (M1 x) = genPaths x-  genFirst = M1 genFirst   -- Constructor names / lines@@ -101,12 +107,9 @@   genRoute [] = Nothing  -  genFirst = M1 genFirst--   genPaths (M1 x) =     let name = conName (undefined :: M1 C c f x)-     in toLower (pack name) : genPaths x+     in filter (not . T.null) $ toLower (pack name) : genPaths x   -- Unary constructors@@ -114,7 +117,6 @@   genRoute [] = pure U1   genRoute _ = Nothing   genPaths _ = []-  genFirst = U1   -- Selectors@@ -123,16 +125,14 @@     M1 <$> genRoute ps  -  genFirst = M1 genFirst--   genPaths (M1 x) = genPaths x   -- Sum types instance (GenRoute a, GenRoute b) => GenRoute (a :+: b) where   genRoute ps = L1 <$> genRoute ps <|> R1 <$> genRoute ps-  genFirst = L1 genFirst++   genPaths (L1 a) = genPaths a   genPaths (R1 a) = genPaths a @@ -146,15 +146,13 @@   genRoute _ = Nothing  -  genFirst = genFirst :*: genFirst--   genPaths (a :*: b) = genPaths a <> genPaths b   instance (Route sub) => GenRoute (K1 R sub) where   genRoute ts = K1 <$> matchRoute ts-  genFirst = K1 defRoute++   genPaths (K1 sub) = routePath sub  @@ -168,26 +166,26 @@   matchRoute [t] = pure t   matchRoute _ = Nothing   routePath t = [t]-  defRoute = ""+  baseRoute = Nothing   instance Route String where   matchRoute [t] = pure (unpack t)   matchRoute _ = Nothing   routePath t = [pack t]-  defRoute = ""+  baseRoute = Nothing   instance Route Integer where   matchRoute = matchRouteRead   routePath = routePathShow-  defRoute = 0+  baseRoute = Nothing   instance Route Int where   matchRoute = matchRouteRead   routePath = routePathShow-  defRoute = 0+  baseRoute = Nothing   instance (Route a) => Route (Maybe a) where@@ -195,7 +193,7 @@   matchRoute ps = Just <$> matchRoute ps   routePath (Just a) = routePath a   routePath Nothing = []-  defRoute = Nothing+  baseRoute = Nothing   matchRouteRead :: (Read a) => [Segment] -> Maybe a
− src/Web/Hyperbole/Session.hs 
@@ -1,68 +0,0 @@-module Web.Hyperbole.Session where--import Data.ByteString (ByteString)-import Data.List qualified as L-import Data.Map (Map)-import Data.Map qualified as Map-import Data.Maybe (fromMaybe)-import Data.String.Conversions (cs)-import Data.Text (Text)-import Network.HTTP.Types-import Web.HttpApiData-import Prelude---newtype Session = Session (Map Text Text)-  deriving (Show)----- | Set the session key to value-sessionSet :: (ToHttpApiData a) => Text -> a -> Session -> Session-sessionSet k a (Session kvs) =-  let val = toQueryParam a-   in Session $ Map.insert k val kvs---sessionDel :: Text -> Session -> Session-sessionDel k (Session kvs) =-  Session $ Map.delete k kvs---sessionLookup :: (FromHttpApiData a) => Text -> Session -> Maybe a-sessionLookup k (Session sm) = do-  t <- Map.lookup k sm-  either (const Nothing) pure $ parseQueryParam t---sessionEmpty :: Session-sessionEmpty = Session Map.empty----- | Render a session as a url-encoded query string-sessionRender :: Session -> ByteString-sessionRender (Session sm) =-  urlEncode True $ renderQuery False (toQuery $ Map.toList sm)----- | Parse a session as a url-encoded query string-sessionParse :: ByteString -> Session-sessionParse = Session . Map.fromList . map toText . parseQuery . urlDecode True- where-  toText (k, Nothing) = (cs k, "false")-  toText (k, Just v) = (cs k, cs v)---sessionFromCookies :: [(ByteString, ByteString)] -> Session-sessionFromCookies cks = fromMaybe sessionEmpty $ do-  bs <- L.lookup "session" cks-  pure $ sessionParse bs---sessionSetCookie :: Session -> ByteString-sessionSetCookie ss = "session=" <> sessionRender ss <> "; SameSite=None; secure; path=/"---- sessionKeyParse :: (FromHttpApiData a) => Text -> Session -> Either Text (Maybe a)--- sessionKeyParse k (Session kvs) =---   case Map.lookup k kvs of---     Nothing -> pure Nothing---     Just t -> Just <$> parseQueryParam t
+ src/Web/Hyperbole/TypeList.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE UndecidableInstances #-}++module Web.Hyperbole.TypeList where++import Data.Kind (Constraint, Type)+import GHC.TypeLits hiding (Mod)+++-- concat lists+type family (<++>) xs ys where+  '[] <++> ys = ys+  xs <++> '[] = xs+  (x ': xs) <++> ys = x : xs <++> ys+++type family Remove x ys where+  Remove x '[] = '[]+  Remove x (x ': ys) = Remove x ys+  Remove x (y ': ys) = y ': Remove x ys+++type family RemoveAll xs ys where+  RemoveAll '[] ys = ys+  RemoveAll xs '[] = '[]+  RemoveAll (x ': xs) ys = RemoveAll xs (Remove x ys)+++-- Type family to check if an element is in a type-level list+type Elem e es = ElemOr e es (NotElem e es)+++-- 'orig' is used to store original list for better error messages+type family ElemOr e es err :: Constraint where+  ElemOr x (x ': xs) err = ()+  ElemOr y (x ': xs) err = ElemOr y xs err+  -- Note [Custom Errors]+  ElemOr x '[] err = err+++type family AllElemOr xs ys err :: Constraint where+  AllElemOr '[] _ _ = ()+  AllElemOr (x ': xs) ys err =+    (ElemOr x ys err, AllElemOr xs ys err)+++type NotElem x (orig :: [Type]) =+  TypeError+    ( 'ShowType x+        ':<>: 'Text " not found in "+        ':<>: 'ShowType orig+    )+++type family TupleList a where+  TupleList () = '[]+  TupleList (a, b) = [a, b]+  TupleList (a, b, c) = [a, b, c]+  TupleList (a, b, c, d) = [a, b, c, d]+  TupleList (a, b, c, d, e) = [a, b, c, d, e]+  TupleList (a, b, c, d, e, f) = [a, b, c, d, e, f]+  TupleList (a, b, c, d, e, f, g) = [a, b, c, d, e, f, g]+  TupleList (a, b, c, d, e, f, g, h) = [a, b, c, d, e, f, g, h]+  TupleList (a, b, c, d, e, f, g, h, i) = [a, b, c, d, e, f, g, h, i]+  TupleList (a, b, c, d, e, f, g, h, i, j) = [a, b, c, d, e, f, g, h, i, j]+  TupleList a = '[a]
src/Web/Hyperbole/View.hs view
@@ -1,6 +1,14 @@ module Web.Hyperbole.View-  ( module Web.View+  ( hyper+  , module Web.Hyperbole.View.Element+  , module Web.Hyperbole.View.Event+  , module Web.View+  , module Web.Hyperbole.View.Embed   ) where +import Web.Hyperbole.HyperView (hyper)+import Web.Hyperbole.View.Element+import Web.Hyperbole.View.Embed+import Web.Hyperbole.View.Event import Web.View hiding (Query, Segment, button, cssResetEmbed, form, input, label)
+ src/Web/Hyperbole/View/Element.hs view
@@ -0,0 +1,72 @@+module Web.Hyperbole.View.Element where++import Data.Text (Text)+import Web.Hyperbole.HyperView (HyperView (..), ViewAction (..))+import Web.Hyperbole.Route (Route (..), routeUrl)+import Web.Hyperbole.View.Event (DelayMs, onClick, onInput)+import Web.View hiding (Query, Segment, button, cssResetEmbed, form, input, label)+++{- | \<button\> HTML tag which sends the action when pressed++> button SomeAction (border 1) "Click Me"+-}+button :: (ViewAction (Action id)) => Action id -> Mod id -> View id () -> View id ()+button action f cd = do+  tag "button" (onClick action . f) cd+++{- | Type-safe dropdown. Sends (opt -> Action id) when selected. The selection predicate (opt -> Bool) controls which option is selected. See [Example.Page.Filter](https://docs.hyperbole.live/filter)++@+#EMBED Example/Page/Filter.hs familyDropdown+@+-}+dropdown+  :: (ViewAction (Action id))+  => (opt -> Action id)+  -> (opt -> Bool) -- check if selec+  -> Mod id+  -> View (Option opt id (Action id)) ()+  -> View id ()+dropdown act isSel f options = do+  tag "select" (att "data-on-change" "" . f) $ do+    addContext (Option act isSel) options+++-- | An option for a 'dropdown'. First argument is passed to (opt -> Action id) in the 'dropdown', and to the selected predicate+option+  :: (ViewAction (Action id), Eq opt)+  => opt+  -> View (Option opt id (Action id)) ()+  -> View (Option opt id (Action id)) ()+option opt cnt = do+  os <- context+  tag "option" (att "value" (toAction (os.toAction opt)) . selected (os.selected opt)) cnt+++-- | sets selected = true if the 'dropdown' predicate returns True+selected :: Bool -> Mod id+selected b = if b then att "selected" "true" else id+++-- | The view context for an 'option'+data Option opt id action = Option+  { toAction :: opt -> action+  , selected :: opt -> Bool+  }+++-- | A live search field+search :: (ViewAction (Action id)) => (Text -> Action id) -> DelayMs -> Mod id -> View id ()+search go delay f = do+  tag "input" (onInput go delay . f) none+++{- | A hyperlink to another route++>>> route (User 100) id "View User"+<a href="/user/100">View User</a>+-}+route :: (Route a) => a -> Mod c -> View c () -> View c ()+route r = link (routeUrl r)
+ src/Web/Hyperbole/View/Embed.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}++module Web.Hyperbole.View.Embed+  ( cssResetEmbed+  , cssResetLink+  , scriptEmbed+  )+where++import Data.ByteString+import Data.FileEmbed+import Web.View.Reset+++scriptEmbed :: ByteString+scriptEmbed = $(embedFile "client/dist/hyperbole.js")
+ src/Web/Hyperbole/View/Event.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE LambdaCase #-}++module Web.Hyperbole.View.Event where++import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Text qualified as T+import Text.Casing (kebab)+import Web.Hyperbole.HyperView+import Web.View (Mod, View, addContext, att, parent)+import Web.View.Types (Content (Node), Element (..))+import Web.View.View (viewModContents)+++type DelayMs = Int+++{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling. See [Example.Page.Concurrent](https://docs.hyperbole.live/concurrent)++@+#EMBED Example/Page/Concurrent.hs viewUpdating+@+-}+onLoad :: (ViewAction (Action id)) => Action id -> DelayMs -> Mod id+onLoad a delay = do+  att "data-on-load" (toAction a) . att "data-delay" (cs $ show delay)+++onClick :: (ViewAction (Action id)) => Action id -> Mod id+onClick a = do+  att "data-on-click" (toAction a)+++onDblClick :: (ViewAction (Action id)) => Action id -> Mod id+onDblClick a = do+  att "data-on-dblclick" (toAction a)+++{- | Run an action when the user types into an 'input' or 'textarea'.++WARNING: a short delay can result in poor performance. It is not recommended to set the 'value' of the input++> input (onInput OnSearch) 250 id+-}+onInput :: (ViewAction (Action id)) => (Text -> Action id) -> DelayMs -> Mod id+onInput a delay = do+  att "data-on-input" (toActionInput a) . att "data-delay" (cs $ show delay)+++onSubmit :: (ViewAction (Action id)) => Action id -> Mod id+onSubmit act = do+  att "data-on-submit" (toAction act)+++onKeyDown :: (ViewAction (Action id)) => Key -> Action id -> Mod id+onKeyDown key act = do+  att ("data-on-keydown-" <> keyDataAttribute key) (toAction act)+++onKeyUp :: (ViewAction (Action id)) => Key -> Action id -> Mod id+onKeyUp key act = do+  att ("data-on-keyup-" <> keyDataAttribute key) (toAction act)+++keyDataAttribute :: Key -> Text+keyDataAttribute = cs . kebab . showKey+ where+  showKey (OtherKey t) = cs t+  showKey k = show k+++-- https://developer.mozilla.org/en-US/docs/Web/API/UI_Events/Keyboard_event_key_values+data Key+  = ArrowDown+  | ArrowUp+  | ArrowLeft+  | ArrowRight+  | Enter+  | Space+  | Escape+  | Alt+  | CapsLock+  | Control+  | Fn+  | Meta+  | Shift+  | OtherKey Text+  deriving (Show, Read)+++-- | Serialize a constructor that expects a single 'Text', like `data MyAction = GoSearch Text`+toActionInput :: (ViewAction a) => (Text -> a) -> Text+toActionInput con =+  -- remove the ' ""' at the end of the constructor+  T.dropEnd 3 $ toAction $ con ""+++{- | Apply a Mod only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1)++@+#EMBED Example/Page/Contact.hs contactEditView+@+-}+onRequest :: Mod id -> Mod id+onRequest f = do+  parent "hyp-loading" f+++-- | Internal+dataTarget :: (ViewId a) => a -> Mod x+dataTarget = att "data-target" . toViewId+++-- | Allow inputs to trigger actions for a different view+target :: forall id ctx. (HyperViewHandled id ctx, ViewId id) => id -> View id () -> View ctx ()+target newId view = do+  addContext newId $ do+    view+    viewModContents (fmap addDataTarget)+ where+  addDataTarget :: Content -> Content+  addDataTarget = \case+    Node elm ->+      Node $+        let atts = elm.attributes+         in elm{attributes = dataTarget newId atts}+    cnt -> cnt
+ src/Web/Hyperbole/View/Forms.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}++module Web.Hyperbole.View.Forms+  ( FormFields (..)+  , InputType (..)+  , FieldName+  , Invalid+  , Input (..)+  , field+  , label+  , input+  , form+  , textarea+  , placeholder+  , submit+  , formData+  , Form (..)+  , formParseParam+  , formLookupParam+  , formFields+  , formFieldsWith+  , Field+  , defaultFormOptions+  , FormOptions (..)+  , Validated (..)+  , FormField (..)+  , fieldValid+  , anyInvalid+  , invalidText+  , validate+  , Identity++    -- * Re-exports+  , FromParam+  , Generic+  , GenFields (..)+  , GenField (..)+  )+where++import Data.Function ((&))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import Debug.Trace+import Effectful+import GHC.Generics+import Text.Casing (kebab)+import Web.FormUrlEncoded (FormOptions (..), defaultFormOptions, parseUnique)+import Web.FormUrlEncoded qualified as FE+import Web.Hyperbole.Data.QueryData (FromParam (..), Param (..), ParamValue (..))+import Web.Hyperbole.Effect.Hyperbole+import Web.Hyperbole.Effect.Request+import Web.Hyperbole.Effect.Response (parseError)+import Web.Hyperbole.HyperView+import Web.Hyperbole.View.Event (onSubmit)+import Web.View hiding (form, input, label)+import Web.View.Style (addClass, cls, prop)+++-- | The only time we can use Fields is inside a form+data FormFields id = FormFields id+++data FormField v a = FormField+  { fieldName :: FieldName a+  , validated :: v a+  }+  deriving (Show)+++-- instance Show (v a) => Show (FormField v) where+--   show f = "Form Field"++-- instance (ViewId id) => ViewId (FormFields id v fs) where+--   parseViewId t = do+--     i <- parseViewId t+--     pure $ FormFields i lbls mempty+--   toViewId (FormFields i _ _) = toViewId i+--+--+-- instance (HyperView id, ViewId id) => HyperView (FormFields id v fs) where+--   type Action (FormFields id v fs) = Action id++-- | Choose one for 'input's to give the browser autocomplete hints+data InputType+  = -- TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete+    NewPassword+  | CurrentPassword+  | Username+  | Email+  | Number+  | TextInput+  | Name+  | OneTimeCode+  | Organization+  | StreetAddress+  | Country+  | CountryName+  | PostalCode+  | Search+  deriving (Show)+++{- | Validation results for a 'Form'. See 'validate'++@+#EMBED Example/Page/FormValidation.hs data UserForm+#EMBED Example/Page/FormValidation.hs instance Form UserForm++#EMBED Example/Page/FormValidation.hs validateForm++#EMBED Example/Page/FormValidation.hs validateAge+@+-}+data Validated a = Invalid Text | NotInvalid | Valid+  deriving (Show)+++instance Semigroup (Validated a) where+  Invalid t <> _ = Invalid t+  _ <> Invalid t = Invalid t+  Valid <> _ = Valid+  _ <> Valid = Valid+  a <> _ = a+++instance Monoid (Validated a) where+  mempty = NotInvalid+++class ValidationState (v :: Type -> Type) where+  convert :: v a -> v b+  isInvalid :: v a -> Bool+++instance ValidationState Validated where+  convert :: Validated a -> Validated b+  convert (Invalid t) = Invalid t+  convert NotInvalid = NotInvalid+  convert Valid = Valid+++  isInvalid :: Validated a -> Bool+  isInvalid (Invalid _) = True+  isInvalid _ = False+++{- Only shows if 'Validated' is 'Invalid'. See 'formFieldsWith'+@+@+-}+invalidText :: forall a id. View (Input id Validated a) ()+invalidText = do+  Input _ v <- context+  case v of+    Invalid t -> text t+    _ -> none+++{- | specify a check for a 'Validation'++@+#EMBED Example/Page/FormValidation.hs validateAge+@+-}+validate :: Bool -> Text -> Validated a+validate True t = Invalid t -- Validation [(inputName @a, Invalid t)]+validate False _ = NotInvalid -- Validation [(inputName @a, NotInvalid)]+++-- validateWith :: forall a fs v. (FormField a, Elem a fs, ValidationState v) => v a -> Validation' v fs+-- validateWith v = Validation [(inputName @a, convert v)]++-- eh... not sure how to do this...+anyInvalid :: forall form val. (Form form val, ValidationState val) => form val -> Bool+anyInvalid f = any isInvalid (collectValids f :: [val ()])+++-- any (isInvalid . snd) vs++-- | Returns the 'Validated' for the 'field'. See 'formFieldsWith'+fieldValid :: View (Input id v a) (v a)+fieldValid = do+  Input _ v <- context+  pure v+++data FieldName a = FieldName Text+  deriving (Show)+++data Invalid a+++data Input (id :: Type) (valid :: Type -> Type) (a :: Type) = Input+  { inputName :: FieldName a+  , valid :: valid a+  }+++-- | Display a 'FormField'. See 'form' and 'Form'+field+  :: forall (id :: Type) (v :: Type -> Type) (a :: Type)+   . FormField v a+  -> (v a -> Mod (FormFields id))+  -> View (Input id v a) ()+  -> View (FormFields id) ()+field fld md cnt = do+  tag "label" (md fld.validated . flexCol) $ do+    addContext (Input fld.fieldName fld.validated) cnt+++-- | label for a 'field'+label :: Text -> View (Input id v a) ()+label = text+++-- | input for a 'field'+input :: InputType -> Mod (Input id v a) -> View (Input id v a) ()+input ft f = do+  Input (FieldName nm) _ <- context+  tag "input" (f . name nm . att "type" (inpType ft) . att "autocomplete" (auto ft)) none+ where+  inpType NewPassword = "password"+  inpType CurrentPassword = "password"+  inpType Number = "number"+  inpType Email = "email"+  inpType Search = "search"+  inpType _ = "text"++  auto :: InputType -> Text+  auto = pack . kebab . show+++placeholder :: Text -> Mod id+placeholder = att "placeholder"+++-- | textarea for a 'field'+textarea :: Mod (Input id v a) -> Maybe Text -> View (Input id v a) ()+textarea f mDefaultText = do+  Input (FieldName nm) _ <- context+  tag "textarea" (f . name nm) (text $ fromMaybe "" mDefaultText)+++{- | Type-safe \<form\>. Calls (Action id) on submit++@+#EMBED Example/Page/FormSimple.hs formView+@+-}+form :: (Form form v, ViewAction (Action id)) => Action id -> Mod id -> View (FormFields id) () -> View id ()+form a md cnt = do+  vid <- context+  tag "form" (onSubmit a . md . flexCol . marginEnd0) $ do+    addContext (FormFields vid) cnt+ where+  -- not sure why chrome is adding margin-block-end: 16 to forms? Add to web-view?+  marginEnd0 =+    addClass $+      cls "mg-end-0"+        & prop @PxRem "margin-block-end" 0+++-- | Button that submits the 'form'. Use 'button' to specify actions other than submit+submit :: Mod (FormFields id) -> View (FormFields id) () -> View (FormFields id) ()+submit f = tag "button" (att "type" "submit" . f)+++{- | Field allows a Higher Kinded 'Form' to reuse the same selectors for form parsing, generating html forms, and validation++> Field Identity Text ~ Text+> Field Maybe Text ~ Maybe Text+-}+type family Field (context :: Type -> Type) a+++type instance Field Identity a = a+type instance Field FieldName a = FieldName a+type instance Field (FormField v) a = FormField v a+type instance Field Validated a = Validated a+type instance Field Maybe a = Maybe a+type instance Field (Either String) a = Either String a+++formData :: forall form val es. (Form form val, Hyperbole :> es) => Eff es (form Identity)+formData = do+  f <- formBody+  traceM $ show f+  let ef = formParse @form @val f :: Either Text (form Identity)+  case ef of+    Left e -> parseError e+    Right a -> pure a+++{- | A Form is a Higher Kinded record listing each 'Field'. `ContactForm` `Identity` behaves like a normal record, while `ContactForm` `Maybe` would be maybe values for each field++From [Example.Page.FormSimple](https://docs.hyperbole.live/formsimple)++@+#EMBED Example/Page/FormSimple.hs data ContactForm+#EMBED Example/Page/FormSimple.hs instance Form ContactForm+@+-}+class Form form (val :: Type -> Type) | form -> val where+  formParse :: FE.Form -> Either Text (form Identity)+  default formParse :: (Generic (form Identity), GFormParse (Rep (form Identity))) => FE.Form -> Either Text (form Identity)+  formParse f = to <$> gFormParse f+++  collectValids :: (ValidationState val) => form val -> [val ()]+  default collectValids :: (Generic (form val), GCollect (Rep (form val)) val) => form val -> [val ()]+  collectValids f = gCollect (from f)+++  genForm :: form val+  default genForm :: (Generic (form val), GenFields (Rep (form val))) => form val+  genForm = to gGenFields+++  genFieldsWith :: form val -> form (FormField val)+  default genFieldsWith+    :: (Generic (form val), Generic (form (FormField val)), GConvert (Rep (form val)) (Rep (form (FormField val))))+    => form val+    -> form (FormField val)+  genFieldsWith fv = to $ gConvert (from fv)+++formParseParam :: (FromParam a) => Param -> FE.Form -> Either Text a+formParseParam (Param key) frm = do+  t <- FE.parseUnique @Text key frm+  parseParam (ParamValue t)+++formLookupParam :: (FromParam a) => Param -> FE.Form -> Either Text (Maybe a)+formLookupParam (Param key) frm = do+  mt <- FE.parseMaybe @Text key frm+  maybe (pure Nothing) (parseParam . ParamValue) mt+++{- | Generate FormFields for the given instance of 'Form', with no validation information. See [Example.Page.FormSimple](https://docs.hyperbole.live/formsimple)++> #EMBED Example/Page/FormSimple.hs data ContactForm+>+> #EMBED Example/Page/FormSimple.hs formView+-}+formFields :: (Form form val) => form (FormField val)+formFields = genFieldsWith genForm+++{- | Generate FormFields for the given instance of 'Form' from validation data. See [Example.Page.FormValidation](https://docs.hyperbole.live/formvalidation)++> #EMBED Example/Page/FormValidation.hs data UserForm+> #EMBED Example/Page/FormValidation.hs instance Form UserForm+>+> #EMBED Example/Page/FormValidation.hs formView+-}+formFieldsWith :: (Form form val) => form val -> form (FormField val)+formFieldsWith = genFieldsWith+++-- | Automatically derive labels from form field names+class GFormParse f where+  gFormParse :: FE.Form -> Either Text (f p)+++-- instance GForm U1 where+--   gForm = U1++instance (GFormParse f, GFormParse g) => GFormParse (f :*: g) where+  gFormParse f = do+    a <- gFormParse f+    b <- gFormParse f+    pure $ a :*: b+++instance (GFormParse f) => GFormParse (M1 D d f) where+  gFormParse f = M1 <$> gFormParse f+++instance (GFormParse f) => GFormParse (M1 C c f) where+  gFormParse f = M1 <$> gFormParse f+++instance (Selector s, FromParam a) => GFormParse (M1 S s (K1 R a)) where+  gFormParse f = do+    let s = selName (undefined :: M1 S s (K1 R (f a)) p)+    t <- parseUnique @Text (pack s) f+    M1 . K1 <$> parseParam (ParamValue t)+++------------------------------------------------------------------------------+-- GEN FIELDS :: Create the field! -------------------------------------------+------------------------------------------------------------------------------++class GenFields f where+  gGenFields :: f p+++instance GenFields U1 where+  gGenFields = U1+++instance (GenFields f, GenFields g) => GenFields (f :*: g) where+  gGenFields = gGenFields :*: gGenFields+++instance (Selector s, GenField f a, Field f a ~ f a) => GenFields (M1 S s (K1 R (f a))) where+  gGenFields =+    let sel = selName (undefined :: M1 S s (K1 R (f a)) p)+     in M1 . K1 $ genField @f @a sel+++instance (GenFields f) => GenFields (M1 D d f) where+  gGenFields = M1 gGenFields+++instance (GenFields f) => GenFields (M1 C c f) where+  gGenFields = M1 gGenFields+++------------------------------------------------------------------------------+-- GenField -- Generate a value from the selector name+------------------------------------------------------------------------------++class GenField f a where+  genField :: String -> Field f a+++instance GenField FieldName a where+  genField s = FieldName $ pack s+++instance GenField Validated a where+  genField = const NotInvalid+++instance GenField (FormField Validated) a where+  genField s = FormField (FieldName $ pack s) NotInvalid+++instance GenField (FormField Maybe) a where+  genField s = FormField (FieldName $ pack s) Nothing+++instance GenField Maybe a where+  genField _ = Nothing+++------------------------------------------------------------------------------+-- GMerge - combine two records with the same structure+------------------------------------------------------------------------------++-- class ConvertFields a where+--   convertFields :: (FromSelector f g) => a f -> a g+--   default convertFields :: (Generic (a f), Generic (a g), GConvert (Rep (a f)) (Rep (a g))) => a f -> a g+--   convertFields x = to $ gConvert (from x)++class GMerge ra rb rc where+  gMerge :: ra p -> rb p -> rc p+++instance (GMerge ra0 rb0 rc0, GMerge ra1 rb1 rc1) => GMerge (ra0 :*: ra1) (rb0 :*: rb1) (rc0 :*: rc1) where+  gMerge (a0 :*: a1) (b0 :*: b1) = gMerge a0 b0 :*: gMerge a1 b1+++instance (GMerge ra rb rc) => GMerge (M1 D d ra) (M1 D d rb) (M1 D d rc) where+  gMerge (M1 fa) (M1 fb) = M1 $ gMerge fa fb+++instance (GMerge ra rb rc) => GMerge (M1 C d ra) (M1 C d rb) (M1 C d rc) where+  gMerge (M1 fa) (M1 fb) = M1 $ gMerge fa fb+++instance (Selector s, MergeField a b c) => GMerge (M1 S s (K1 R a)) (M1 S s (K1 R b)) (M1 S s (K1 R c)) where+  gMerge (M1 (K1 a)) (M1 (K1 b)) = M1 . K1 $ mergeField a b+++class MergeField a b c where+  mergeField :: a -> b -> c+++instance MergeField (FieldName a) (Validated a) (FormField Validated a) where+  mergeField = FormField+++------------------------------------------------------------------------------+-- GConvert - combine two records with the same structure+------------------------------------------------------------------------------++-- class ConvertFields a where+--   convertFields :: (FromSelector f g) => a f -> a g+--   default convertFields :: (Generic (a f), Generic (a g), GConvert (Rep (a f)) (Rep (a g))) => a f -> a g+--   convertFields x = to $ gConvert (from x)++class GConvert ra rc where+  gConvert :: ra p -> rc p+++instance (GConvert ra0 rc0, GConvert ra1 rc1) => GConvert (ra0 :*: ra1) (rc0 :*: rc1) where+  gConvert (a0 :*: a1) = gConvert a0 :*: gConvert a1+++instance (GConvert ra rc) => GConvert (M1 D d ra) (M1 D d rc) where+  gConvert (M1 fa) = M1 $ gConvert fa+++instance (GConvert ra rc) => GConvert (M1 C d ra) (M1 C d rc) where+  gConvert (M1 fa) = M1 $ gConvert fa+++instance (Selector s, GenFieldFrom f g a, Field g a ~ g a) => GConvert (M1 S s (K1 R (f a))) (M1 S s (K1 R (g a))) where+  gConvert (M1 (K1 inp)) =+    let sel = selName (undefined :: M1 S s (K1 R (f a)) p)+     in M1 . K1 $ genFieldFrom @f @g sel inp+++class GenFieldFrom inp f a where+  genFieldFrom :: String -> inp a -> Field f a+++-- instance GenFieldFrom Validated (FormField Validated) a where+--   genFieldFrom s = FormField (FieldName $ pack s)+--++instance GenFieldFrom val (FormField val) a where+  genFieldFrom s = FormField (FieldName $ pack s)+++------------------------------------------------------------------------------++class GCollect ra v where+  gCollect :: ra p -> [v ()]+++instance GCollect U1 v where+  gCollect _ = []+++instance (GCollect f v, GCollect g v) => GCollect (f :*: g) v where+  gCollect (a :*: b) = gCollect a <> gCollect b+++instance (Selector s, ValidationState v) => GCollect (M1 S s (K1 R (v a))) v where+  gCollect (M1 (K1 val)) = [convert val]+++instance (GCollect f v) => GCollect (M1 D d f) v where+  gCollect (M1 f) = gCollect f+++instance (GCollect f v) => GCollect (M1 C c f) v where+  gCollect (M1 f) = gCollect f++------------------------------------------------------------------------------
test/Spec.hs view
@@ -1,3 +1,2 @@-{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}-+import Skeletest.Main
+ test/Test/FormSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedLists #-}++module Test.FormSpec where++import Data.Text (Text)+import Skeletest+import Web.Hyperbole.View.Forms+++data Example f = Example+  { message :: Field f Text+  , age :: Field f Int+  , whatever :: Field f (Maybe Float)+  }+  deriving (Generic)+instance Form Example Maybe+++spec :: Spec+spec = do+  describe "forms" $ do+    it "should parse a form" $ do+      case formParse @Example [("message", "hello"), ("age", "23"), ("whatever", "")] of+        Left e -> fail $ show e+        Right a -> do+          a.message `shouldBe` "hello"+          a.age `shouldBe` 23+          a.whatever `shouldBe` Nothing
+ test/Test/QuerySpec.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE RecordWildCards #-}++module Test.QuerySpec where++import Data.Function ((&))+import Data.String.Conversions (cs)+import Data.Text (Text)+import Network.HTTP.Types (urlEncode)+import Skeletest+import Web.Hyperbole+import Web.Hyperbole.Data.QueryData as QueryData+import Web.Hyperbole.Data.Session as Session+import Web.Hyperbole.Effect.Server+++spec :: Spec+spec = do+  describe "param" paramSpec+  describe "render" renderSpec+  describe "multi" multiSpec+  describe "session" sessionSpec+++data Woot = Woot Text+  deriving (Generic, Show, ToParam)+instance Session Woot where+  cookiePath = Just ["somepage"]+++sessionSpec :: Spec+sessionSpec = do+  it "should create cookie" $ do+    let woot = Woot "hello"+    sessionCookie woot `shouldBe` Cookie "Woot" (Just (toParam woot)) (Just ["somepage"])++  it "should render cookie with root path" $ do+    let cookie = Cookie "Woot" (Just "Woot") Nothing+    renderCookie [] cookie `shouldBe` "Woot=Woot; SameSite=None; secure; path=/"++  it "should render complex cookie with included path" $ do+    let woot = Woot "hello"+    let cookie = sessionCookie woot+    renderCookie [] cookie `shouldBe` "Woot=" <> urlEncode True (cs (show woot)) <> "; SameSite=None; secure; path=/somepage"++  it "should parse cookies" $ do+    cookiesFromHeader [("Woot", "Woot")] `shouldBe` Session.fromList [Cookie "Woot" (Just "Woot") Nothing]+++paramSpec :: Spec+paramSpec = do+  describe "ToParam" $ do+    it "should encode text flat" $ do+      toParam @Text "hello" `shouldBe` "hello"++    it "should encode int" $ do+      toParam @Int 23 `shouldBe` "23"++    it "should encode Maybe" $ do+      toParam @(Maybe Int) Nothing `shouldBe` ""+      toParam @(Maybe Int) (Just 23) `shouldBe` "23"++    it "should encode lists as show" $ do+      let items = ["one", "two"]+      toParam @[Text] items `shouldBe` ParamValue (cs (show items))++  describe "FromParam" $ do+    it "should parse text" $ do+      parseParam @Text "hello" `shouldBe` Right "hello"++    it "should parse int" $ do+      parseParam @Int "3" `shouldBe` Right 3++    it "should handle lists" $ do+      let items = ["one", "two", "three"] :: [Text]+      parseParam (toParam items) `shouldBe` Right items+++renderSpec :: Spec+renderSpec = do+  it "should parse multiple items" $ do+    let qd = parse "msg=hello&age=1"+    require @Text "msg" qd `shouldBe` Right "hello"+    require @Int "age" qd `shouldBe` Right 1++  it "should render as a querystring" $ do+    let q =+          mempty+            & QueryData.insert @Text "msg" "value"+            & QueryData.insert @Int "age" 1+    QueryData.render q `shouldBe` "age=1&msg=value"++  it "should escape special characters in strings" $ do+    let q = mempty & QueryData.insert @Text "msg" "bob&henry=fast"+    QueryData.render q `shouldBe` "msg=bob%26henry%3Dfast"++  it "should roundtrip special characters" $ do+    let msg = "bob&henry=fast"+    let q = mempty & QueryData.insert @Text "msg" msg+    let out = QueryData.render q+    let q' = QueryData.parse out+    QueryData.lookup "msg" q' `shouldBe` Just msg++  it "should render lists" $ do+    let items = ["one", "two"]+    let q = mempty & QueryData.insert @[Text] "items" items+    QueryData.render q `shouldBe` "items=" <> urlEncode True (cs $ show items)+++data Filters = Filters+  { term :: Text+  , isActive :: Bool+  , another :: Maybe Text+  }+  deriving (Eq, Show, ToParam)+++instance ToQuery Filters where+  toQuery f =+    mempty+      & QueryData.insert "term" f.term+      & QueryData.insert "isActive" f.isActive+      & QueryData.insert "another" f.another+++instance FromQuery Filters where+  parseQuery q = do+    term <- QueryData.require "term" q+    isActive <- QueryData.require "isActive" q+    another <- QueryData.require "another" q+    pure Filters{..}+++data Nested = Nested+  { filters :: Filters+  }+++instance ToQuery Nested where+  toQuery n =+    mempty & QueryData.insert "filters" n.filters+++multiSpec :: Spec+multiSpec = do+  it "should convert to querydata" $ do+    let f = Filters "woot" False Nothing+    QueryData.render (toQuery f) `shouldBe` "another=&isActive=false&term=woot"++  it "should parse from querydata" $ do+    let f = Filters "woot" False Nothing+    let out = QueryData.render (toQuery f)+    let q = QueryData.parse out+    parseQuery q `shouldBe` Right f++  it "should work with Just" $ do+    let f = Filters "woot" False (Just "hello")+    let out = QueryData.render (toQuery f)+    print out+    let q = QueryData.parse out+    parseQuery q `shouldBe` Right f
test/Test/RouteSpec.hs view
@@ -1,7 +1,8 @@-module Test.RouteSpec (spec) where+module Test.RouteSpec where +import Data.Text (Text) import GHC.Generics-import Test.Syd+import Skeletest import Web.Hyperbole.Route  @@ -9,16 +10,30 @@   = MainPage   | Hello Hello   | Goodbye-  deriving (Show, Generic, Eq, Route)+  deriving (Show, Generic, Eq)+instance Route Routes where+  baseRoute = Just MainPage   data Hello   = MainHello   | World   | Message String+  deriving (Show, Generic, Eq)+instance Route Hello where+  baseRoute = Just MainHello+++data NoMain = NoMain Nested   deriving (Show, Generic, Eq, Route)  +data Nested+  = Something+  | Nested Text+  deriving (Show, Generic, Eq, Route)++ spec :: Spec spec = do   describe "Route" $ do@@ -38,6 +53,12 @@       it "compound default" $         routePath (Hello MainHello) `shouldBe` ["hello"] +      it "constructors with parameters should use full url" $+        routePath (NoMain (Nested "woot")) `shouldBe` ["nomain", "nested", "woot"]++      it "no main should use full url" $+        routePath (NoMain Something) `shouldBe` ["nomain", "something"]+     describe "matchRoute" $ do       it "basic" $ matchRoute ["goodbye"] `shouldBe` Just Goodbye       it "default empty string" $ matchRoute [""] `shouldBe` Just MainPage@@ -45,7 +66,9 @@       it "compound" $ matchRoute ["hello", "world"] `shouldBe` Just (Hello World)       it "compound default" $ matchRoute ["hello"] `shouldBe` Just (Hello MainHello)       it "compound dynamic" $ matchRoute ["hello", "message", "whatever"] `shouldBe` Just (Hello (Message "whatever"))+      it "no base compound" $ matchRoute ["nomain", "nested", "hello"] `shouldBe` Just (NoMain (Nested "hello")) -    describe "defRoute" $ do-      it "default" $ defRoute `shouldBe` MainPage-      it "compound" $ (defRoute :: Hello) `shouldBe` MainHello+    describe "baseRoute" $ do+      it "default" $ baseRoute `shouldBe` Just MainPage+      it "compound" $ (baseRoute @Hello) `shouldBe` Just MainHello+      it "none" $ (baseRoute @Nested) `shouldBe` Nothing
+ test/Test/ViewActionSpec.hs view
@@ -0,0 +1,82 @@+module Test.ViewActionSpec where++import Data.Text (Text)+import GHC.Generics+import Skeletest+import Web.Hyperbole.HyperView+++data Simple = Simple+  deriving (Generic, Eq, Show, Read, ViewAction)+++data Product = Product String Int+  deriving (Generic, Show, Eq, ViewAction, Read)+++data Product' = Product' HasText Int+  deriving (Generic, Show, Eq, ViewAction, Read)+++data Sum+  = SumA+  | SumB Int+  deriving (Generic, Show, Eq, Read, ViewAction)+++data Compound = Compound Product+  deriving (Generic, Show, Eq, Read, ViewAction)+++data HasText = HasText Text+  deriving (Generic, Show, Eq, Read, ViewAction)+++-- data Compound+--   = One+--   | Two Thing+--   | WithId (Id Thing)+--   deriving (Generic, Param, Show, Eq)+--+--+-- newtype Id a = Id {fromId :: Text}+--   deriving newtype (Param, Eq, Ord)+--   deriving (Generic, Show)+--+--+-- instance Param Custom where+--   toParam Custom = "something"+--   parseParam "something" = Just Custom+--   parseParam _ = Nothing++spec :: Spec+spec = do+  describe "ViewAction" $ do+    describe "toAction" $ do+      it "simple" $ toAction Simple `shouldBe` "Simple"+      it "has text" $ toAction (HasText "hello world") `shouldBe` "HasText \"hello world\""+      it "product" $ toAction (Product "hello world" 123) `shouldBe` "Product \"hello world\" 123"+      it "sum" $ toAction (SumB 123) `shouldBe` "SumB 123"+      it "compound" $ toAction (Compound (Product "hello world" 123)) `shouldBe` "Compound (Product \"hello world\" 123)"++    describe "parseAction" $ do+      it "simple" $ parseAction "Simple" `shouldBe` Just Simple++    describe "roundTrip" $ do+      it "simple" $ do+        parseAction (toAction Simple) `shouldBe` Just Simple+      it "has text multiple words" $ do+        let a = HasText "hello world"+        parseAction (toAction a) `shouldBe` Just a+      it "product" $ do+        let a = Product "hello world" 123+        parseAction (toAction a) `shouldBe` Just a+      it "product'" $ do+        let a = Product' (HasText "hello world") 123+        parseAction (toAction a) `shouldBe` Just a+      it "compound" $ do+        let a = Compound (Product "hello world" 123)+        parseAction (toAction a) `shouldBe` Just a+      it "sum" $ do+        let a = SumB 123+        parseAction (toAction a) `shouldBe` Just a
+ test/Test/ViewIdSpec.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedLists #-}++module Test.ViewIdSpec where++import Data.Text (Text, pack)+import Data.Text qualified as T+import GHC.Generics+import Skeletest+import Web.Hyperbole.HyperView+import Web.View (att)+import Web.View.Types+++data Thing = Thing+  deriving (Generic, Show, Read, Eq, ViewId)+++data Custom = Custom+  deriving (Show, Eq)+++data HasString = HasString String+  deriving (Generic, Show, Eq, Read, ViewId)+++data Compound+  = One+  | Two Thing+  | WithId (Id Thing)+  | Compound Text Compound+  deriving (Generic, Show, Eq, Read, ViewId)+++data Product4 = Product4 Text Text Text Text+  deriving (Generic, Show, Eq, Read, ViewId)+++newtype Id a = Id {fromId :: Text}+  deriving newtype (Eq, Ord, Show, Read)+  deriving (Generic)+++instance ViewId Custom where+  toViewId Custom = "something"+  parseViewId "something" = Just Custom+  parseViewId _ = Nothing+++spec :: Spec+spec = do+  describe "ViewId" $ do+    describe "toViewId" $ do+      it "basic" $ toViewId Thing `shouldBe` "Thing"+      it "custom" $ toViewId Custom `shouldBe` "something"++    describe "parseViewId" $ do+      it "basic lowercase" $ parseViewId @Thing "thing" `shouldBe` Nothing+      it "basic" $ parseViewId @Thing "Thing" `shouldBe` Just Thing+      it "custom" $ parseViewId "something" `shouldBe` Just Custom+      it "custom other" $ parseViewId @Thing "custom" `shouldBe` Nothing++    describe "has-string" $ do+      it "should not contain single quotes" $ do+        toViewId (HasString "woot") `shouldBe` "HasString \"woot\""+        containsSingleQuotes (toViewId (HasString "woot")) `shouldBe` False++      it "should roundtrip" $ do+        let inp = HasString "woot"+        parseViewId (toViewId inp) `shouldBe` Just inp++    describe "compound" $ do+      it "should toparam" $ toViewId (Two Thing) `shouldBe` "Two Thing"+      it "double roundtrip" $ parseViewId (toViewId (Two Thing)) `shouldBe` Just (Two Thing)++    describe "nested" $ do+      let nest = Compound "one" $ Compound "two" (Two Thing)+      it "should roundtrip" $ parseViewId (toViewId nest) `shouldBe` Just nest++    describe "big product" $ do+      let p = Product4 "one" "two" "three" "four"+      it "should roundtrip" $ parseViewId (toViewId p) `shouldBe` Just p++  describe "Param Attributes" $ do+    it "should serialize basic id" $ do+      let atts = mempty :: Attributes id+      (setId "woot" atts).other `shouldBe` [("id", "woot")]++    it "should serialize compound id" $ do+      let atts = mempty :: Attributes id+      (setId (toViewId $ Two Thing) atts).other `shouldBe` [("id", pack $ show $ Two Thing)]++    it "should serialize stringy id" $ do+      let atts = mempty :: Attributes id+      (setId (toViewId $ HasString "woot") atts).other `shouldBe` [("id", pack $ show $ HasString "woot")]++    it "should serialize with Id" $ do+      let atts = mempty :: Attributes id+      (setId (toViewId $ WithId (Id "woot")) atts).other `shouldBe` [("id", "WithId \"woot\"")]+++containsSingleQuotes :: Text -> Bool+containsSingleQuotes = T.elem '\''+++setId :: Text -> Mod id+setId = att "id"
− test/Test/ViewSpec.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE OverloadedLists #-}--module Test.ViewSpec where--import Data.Text (Text)-import Data.Text qualified as T-import GHC.Generics-import Test.Syd-import Web.Hyperbole.HyperView-import Web.View (att)-import Web.View.Types---data Thing = Thing-  deriving (Generic, Param, Show, Eq)---data Custom = Custom-  deriving (Show, Eq)---data HasString = HasString String-  deriving (Generic, Param, Show, Eq)---data Compound-  = One-  | Two Thing-  | WithId (Id Thing)-  deriving (Generic, Param, Show, Eq)---newtype Id a = Id {fromId :: Text}-  deriving newtype (Param, Eq, Ord)-  deriving (Generic, Show)---instance Param Custom where-  toParam Custom = "something"-  parseParam "something" = Just Custom-  parseParam _ = Nothing---spec :: Spec-spec = do-  describe "HyperView" $ do-    describe "Param" $ do-      describe "toParam" $ do-        it "basic" $ toParam Thing `shouldBe` "thing"-        it "custom" $ toParam Custom `shouldBe` "something"--      describe "parseParam" $ do-        it "basic" $ parseParam "thing" `shouldBe` Just Thing-        it "basic lowercase" $ parseParam @Thing "Thing" `shouldBe` Nothing-        it "custom" $ parseParam "something" `shouldBe` Just Custom-        it "custom other" $ parseParam @Thing "custom" `shouldBe` Nothing--      describe "has-string" $ do-        it "should not contain single quotes" $ do-          toParam (HasString "woot") `shouldNotSatisfy` containsSingleQuotes--        it "should roundtrip" $ do-          let inp = HasString "woot"-          parseParam (toParam inp) `shouldBe` Just inp--      describe "compound" $ do-        it "should toparam" $ toParam (Two Thing) `shouldBe` "two-thing"-        it "double roundtrip" $ parseParam (toParam (Two Thing)) `shouldBe` Just (Two Thing)--  describe "Param Attributes" $ do-    it "should serialize basic id" $ do-      let atts = mempty :: Attributes-      (setId "woot" atts).other `shouldBe` [("id", "woot")]--    it "should serialize compound id" $ do-      let atts = mempty :: Attributes-      (setId (toParam $ Two Thing) atts).other `shouldBe` [("id", "two-thing")]--    it "should serialize stringy id" $ do-      let atts = mempty :: Attributes-      (setId (toParam $ HasString "woot") atts).other `shouldBe` [("id", "hasstring-woot")]--    it "should serialize with Id" $ do-      let atts = mempty :: Attributes-      (setId (toParam $ WithId (Id "woot")) atts).other `shouldBe` [("id", "withid-woot")]---containsSingleQuotes :: Text -> Bool-containsSingleQuotes = T.elem '\''---setId :: Text -> Mod-setId = att "id"