hyperbole (empty) → 0.1.1
raw patch · 22 files changed
+1799/−0 lines, 22 filesdep +basedep +bytestringdep +casing
Dependencies added: base, bytestring, casing, containers, effectful, file-embed, http-api-data, http-types, hyperbole, string-conversions, string-interpolate, text, wai, wai-middleware-static, warp, web-view
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +0/−0
- client/dist/hyperbole.js +106/−0
- example/BulkUpdate.hs +66/−0
- example/Example/Colors.hs +33/−0
- example/Example/Contacts.hs +189/−0
- example/Example/Effects/Debug.hs +36/−0
- example/Example/Effects/Users.hs +83/−0
- example/Example/Forms.hs +93/−0
- example/Example/Transitions.hs +45/−0
- example/Main.hs +101/−0
- hyperbole.cabal +115/−0
- src/Effectful/Sockets.hs +74/−0
- src/Effectful/Wai.hs +130/−0
- src/Web/Hyperbole.hs +22/−0
- src/Web/Hyperbole/Application.hs +72/−0
- src/Web/Hyperbole/Effect.hs +138/−0
- src/Web/Hyperbole/Embed.hs +16/−0
- src/Web/Hyperbole/HyperView.hs +105/−0
- src/Web/Hyperbole/Input.hs +145/−0
- src/Web/Hyperbole/Route.hs +195/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hyperbole++## 0.1.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Sean Hess++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sean Hess nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
+ client/dist/hyperbole.js view
@@ -0,0 +1,106 @@+/*+ * 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/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 */ });\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 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 _events__WEBPACK_IMPORTED_MODULE_1__ = __webpack_require__(/*! ./events */ \"./src/events.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// 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\n// const CONTENT_ID = \"yeti-root-content\"\n// console.log(\"VERSION 2\", INIT_PAGE, INIT_STATE)\nconsole.log(\"Hyperbole 0.1.4\");\n// const protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:';\n// const address = `${protocol}//${window.location.host}`\n// const socket = new WebSocket(address)\n//\nvar rootStyles;\n(0,_events__WEBPACK_IMPORTED_MODULE_1__.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_1__.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_1__.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});\nfunction sendAction(id, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var url, res;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n url = new URL(window.location.href);\n url.searchParams.append(\"id\", id);\n url.searchParams.append(\"action\", action);\n console.log(\"ACTION\", url.toString());\n return [4 /*yield*/, fetch(url, {\n method: \"POST\",\n headers: { 'Accept': 'text/html', 'Content-Type': 'application/x-www-form-urlencoded' },\n body: toSearch(form)\n })];\n case 1:\n res = _a.sent();\n return [2 /*return*/, res.text()];\n }\n });\n });\n}\nfunction runAction(target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var timeout, ret, res, next, old;\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 return [4 /*yield*/, sendAction(target.id, action, form)];\n case 1:\n ret = _a.sent();\n res = parseResponse(ret);\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 // Remove loading and clear add timeout\n clearTimeout(timeout);\n target.classList.remove(\"hyp-loading\");\n return [2 /*return*/];\n }\n });\n });\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 addCSS(text) {\n var rules = text.split(\"\\n\");\n rules.forEach(function (rule) {\n rootStyles.sheet.insertRule(rule);\n });\n}\nfunction parseResponse(ret) {\n var parser = new DOMParser();\n var doc = parser.parseFromString(ret, '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}\ndocument.addEventListener(\"DOMContentLoaded\", init);\n\n\n//# sourceURL=webpack://web-ui/./src/index.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");+/******/ +/******/ })()+;
+ example/BulkUpdate.hs view
@@ -0,0 +1,66 @@+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 view
@@ -0,0 +1,33 @@+module Example.Colors where++import Web.Hyperbole++data AppColor+ = White+ | Light+ | GrayLight+ | GrayDark+ | Dark+ | Success+ | Error+ | Warning+ | Primary+ | PrimaryLight+ | Secondary+ | SecondaryLight+ deriving (Show)++instance ToColor AppColor where+ colorValue White = "#FFF"+ colorValue Light = "#F2F2F3"+ colorValue GrayLight = "#E3E5E9"+ colorValue GrayDark = "#2С3С44"+ colorValue Dark = "#2E3842" -- "#232C41"+ colorValue Primary = "#2C74BB"+ colorValue PrimaryLight = "#3281cf"+ colorValue Secondary = "#5CADDB"+ colorValue SecondaryLight = "#8CFDAB"+ -- colorValue Success = "67C837"+ colorValue Success = "#D5E6DE"+ colorValue Error = "#F3D8DA"+ colorValue Warning = "#FDF3D1"
+ example/Example/Contacts.hs view
@@ -0,0 +1,189 @@+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 GHC.Generics (Generic)+import Web.Hyperbole+++page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es ()+page = do+ hyper contacts+ hyper contact+ load $ do+ us <- usersAll+ pure $ do+ col (pad 10 . gap 10) $ do+ viewId Contacts $ allContactsView Nothing us+++-- Contacts ----------------------------------------------++data Contacts = Contacts+ deriving (Show, Read, Param)+++data ContactsAction+ = Reload (Maybe Filter)+ | Delete Int+ deriving (Show, Read, Param)+++instance HyperView Contacts where+ type Action Contacts = ContactsAction+++data Filter+ = Active+ | Inactive+ deriving (Show, Read, Eq)+++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+ button (Reload Nothing) (bg GrayLight) "Reload"++ dropdown Reload (== fil) $ do+ option Nothing id ""+ option (Just Active) id "Active!"+ option (Just Inactive) id "Inactive"++ target (Contact 2) $ button Edit (bg GrayLight) "Edit 2"++ row (pad 10 . gap 10) $ do+ let filtered = filter (filterUsers fil) us+ forM_ filtered $ \u -> do+ el (border 1) $ do+ viewId (Contact u.id) $ contactView u+ where+ filterUsers Nothing _ = True+ filterUsers (Just Active) u = u.isActive+ filterUsers (Just Inactive) u = not u.isActive+++-- Contact ----------------------------------------------------++data Contact = Contact Int+ deriving (Show, Read, Param)+++data ContactAction+ = Edit+ | Save+ | View+ deriving (Show, Read, Param)+++instance HyperView Contact where+ type Action Contact = ContactAction+++data UserForm a = UserForm+ { firstName :: Field a Text+ , lastName :: Field a Text+ , age :: Field a Int+ }+ deriving (Generic, Form)+++contact :: (Hyperbole :> es, Users :> es, Debug :> es) => Contact -> ContactAction -> Eff es (View Contact ())+contact (Contact uid) a = do+ u <- userFind uid+ action u a+ where+ action u View = do+ pure $ contactView u+ action u Edit = do+ pure $ contactEdit u+ action u Save = do+ delay 1000+ UserForm{firstName, lastName, age} <- parseForm+ let u' = User{id = u.id, isActive = True, firstName, lastName, age}+ userSave u'+ pure $ contactView u'+++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 (bg Primary . color White . hover (bg PrimaryLight . color Dark)) "Edit"+ where+ fld = gap 10+++contactEdit :: User -> View Contact ()+contactEdit u =+ onRequest loading $ do+ form @UserForm Save (pad 10 . gap 10) $ \f -> do+ field fld $ do+ label "First Name:"+ input Name (value u.firstName) f.firstName++ field fld $ do+ label "Last Name:"+ input Name (value u.lastName) f.lastName++ field fld $ do+ label "Age:"+ input Number (value $ cs $ show u.age) f.age++ submit id "Submit"++ button View id (text "Cancel")++ target Contacts $ button (Delete u.id) (bg Secondary) (text "Delete")+ where+ loading = el (bg Secondary) "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/Effects/Debug.hs view
@@ -0,0 +1,36 @@+{-# 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 view
@@ -0,0 +1,83 @@+{-# 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/Forms.hs view
@@ -0,0 +1,93 @@+module Example.Forms where++import Data.Functor.Identity (Identity)+import Data.Text (Text, pack)+import Effectful+import Example.Colors+import GHC.Generics (Generic)+import Web.Hyperbole+++page :: (Hyperbole :> es) => Page es ()+page = do+ hyper action++ load $ do+ pure $ row (pad 20) $ do+ viewId Main formView+++data Main = Main+ deriving (Show, Read, Param)+++data MainAction+ = Submit+ | Cancel+ deriving (Show, Read, Param)+++instance HyperView Main where+ type Action Main = MainAction+++data UserForm a = UserForm+ { username :: Field a Text+ , age :: Field a Integer+ , password1 :: Field a Text+ , password2 :: Field a Text+ }+ deriving (Generic, Form)+++action :: (Hyperbole :> es) => Main -> MainAction -> Eff es (View Main ())+action _ Submit = do+ u <- parseForm+ pure $ userView u+action _ Cancel = do+ pure $ el_ "Cancelled"+++formView :: View Main ()+formView = do+ form @UserForm Submit (gap 10 . pad 10) $ \f -> do+ el h1 "Sign Up"++ field id $ do+ label "Username"+ input Username (inp . placeholder "username") f.username++ field id $ do+ label "Age"+ input Number (inp . placeholder "age") f.age++ field id $ do+ label "Password"+ input NewPassword (inp . placeholder "password") f.password1++ field id $ do+ label "Repeat Password"+ input NewPassword (inp . placeholder "repeat password") f.password2++ submit id "Submit"+ button Cancel id "Cancel"+ where+ placeholder = att "placeholder"+ inp = border 1 . pad 8+++userView :: UserForm Identity -> View Main ()+userView user = do+ el_ "User View"+ el_ $ text user.username+ el_ $ text $ pack (show user.age)+ el_ $ text user.password1+ el_ $ text user.password2+++btn :: Mod+btn = bg Primary . hover (bg PrimaryLight) . color White . pad 10+++h1 :: Mod+h1 = bold . fontSize 32
+ example/Example/Transitions.hs view
@@ -0,0 +1,45 @@+module Example.Transitions where++import Effectful+import Example.Colors+import Web.Hyperbole++page :: (Hyperbole :> es) => Page es ()+page = do+ hyper content++ load $ do+ pure $ row (pad 20) $ do+ viewId Contents viewSmall++data Contents = Contents+ deriving (Show, Read, Param)++data ContentsAction+ = Expand+ | Collapse+ deriving (Show, Read, 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 (Height 200)) $ do+ el id "Hello"+ button Expand btn "Expand"++viewBig :: View Contents ()+viewBig = col (gap 10 . border 1 . pad 20 . transition 300 (Height 400)) $ do+ el_ "One"+ el_ "TWO"+ button Collapse (bg Secondary . hover (bg SecondaryLight) . color White . pad 10) "Collapse"++btn :: Mod+btn = bg Primary . hover (bg PrimaryLight) . color White . pad 10
+ example/Main.hs view
@@ -0,0 +1,101 @@+{-# 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.Dispatch.Dynamic+import Effectful.State.Static.Local+import Example.Contacts qualified as Contacts+import Example.Effects.Debug+import Example.Effects.Users as Users+import Example.Forms qualified as Forms+import Example.Transitions qualified as Transitions+import GHC.Generics (Generic)+import Network.HTTP.Types (Method, QueryItem, methodPost, status200, status404)+import Network.Wai ()+import Network.Wai.Handler.Warp qualified as Warp+import Network.Wai.Middleware.Static (addBase, staticPolicy)+import Web.Hyperbole+++-- import Network.Wai.Handler.WebSockets (websocketsOr)++main :: IO ()+main = do+ putStrLn "Starting Examples on http://localhost:3003"+ users <- initUsers+ Warp.run 3003+ $ staticPolicy (addBase "client/dist")+ $ app users+++data AppRoute+ = Main+ | Hello Hello+ | Contacts+ | Transitions+ | Forms+ deriving (Show, Generic, Eq, Route)+++data Hello+ = Greet Text+ deriving (Show, Generic, Eq, Route)+++app :: UserStore -> Application+app users = waiApplication toDocument (runUsersIO users . runHyperbole . runDebugIO . router)+ where+ router :: (Hyperbole :> es, Users :> es, Debug :> es) => AppRoute -> Eff es ()+ router (Hello h) = page $ hello h+ router Contacts = page Contacts.page+ router Transitions = page Transitions.page+ router Forms = page Forms.page+ router Main = view $ do+ col (gap 10 . pad 10) $ do+ el (bold . fontSize 32) "Examples"+ link (Hello (Greet "World")) id "Hello World"+ link Contacts id "Contacts"+ link Transitions id "Transitions"+ link Forms id "Forms"++ -- example sub-router+ hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es ()+ hello (Greet s) = load $ do+ pure $ do+ el (pad 10 . gap 10) $ do+ text "Greetings, "+ text s++ -- Use the embedded version for real applications (see below). 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>|]++-- toDocument :: BL.ByteString -> BL.ByteString+-- toDocument cnt =+-- [i|<html>+-- <head>+-- <title>Hyperbole Examples</title>+-- <script type="text/javascript">#{scriptEmbed}</script>+-- <style type type="text/css">#{cssResetEmbed}</style>+-- </head>+-- <body>#{cnt}</body>+-- </html>|]
+ hyperbole.cabal view
@@ -0,0 +1,115 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: hyperbole+version: 0.1.1+synopsis: Web Framework inspired by HTMX+description: Web Framework inspired by HTMX.+category: Web+homepage: https://github.com/seanhess/hyperbole+bug-reports: https://github.com/seanhess/hyperbole/issues+author: Sean Hess+maintainer: seanhess@gmail.com+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ client/dist/hyperbole.js+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/seanhess/hyperbole++library+ exposed-modules:+ Effectful.Sockets+ Effectful.Wai+ Web.Hyperbole+ Web.Hyperbole.Application+ Web.Hyperbole.Effect+ Web.Hyperbole.Embed+ Web.Hyperbole.HyperView+ Web.Hyperbole.Input+ Web.Hyperbole.Route+ other-modules:+ Paths_hyperbole+ autogen-modules:+ Paths_hyperbole+ hs-source-dirs:+ src+ 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.3.0 && <0.2+ , containers >=0.6 && <1+ , effectful ==2.3.*+ , file-embed >=0.0.10 && <0.1+ , http-api-data ==0.6.*+ , http-types >=0.12.3 && <0.13+ , string-conversions >=0.4 && <=0.5+ , string-interpolate >=0.3.2 && <0.4+ , text >=1.2 && <3+ , wai >=3.2.3 && <3.3+ , warp >=3.3.30 && <3.4+ , web-view >=0.3 && <=0.4+ default-language: GHC2021++executable example+ main-is: Main.hs+ other-modules:+ BulkUpdate+ Example.Colors+ Example.Contacts+ Example.Effects.Debug+ Example.Effects.Users+ Example.Forms+ Example.Transitions+ 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.3.0 && <0.2+ , containers >=0.6 && <1+ , effectful ==2.3.*+ , file-embed >=0.0.10 && <0.1+ , http-api-data ==0.6.*+ , http-types >=0.12.3 && <0.13+ , hyperbole+ , string-conversions >=0.4 && <=0.5+ , string-interpolate >=0.3.2 && <0.4+ , text >=1.2 && <3+ , wai >=3.2.3 && <3.3+ , wai-middleware-static >=0.9 && <=0.10+ , warp >=3.3.30 && <3.4+ , web-view >=0.3 && <=0.4+ default-language: GHC2021
+ src/Effectful/Sockets.hs view
@@ -0,0 +1,74 @@+-- {-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE QuasiQuotes #-}++module Effectful.Sockets where+++-- import Control.Monad (forever)+-- import Data.Aeson (ToJSON)+-- import Data.Aeson qualified as A+-- import Data.ByteString.Lazy qualified as BL+-- import Data.String.Interpolate (i)+-- import Data.Text (Text)+-- import Effectful+-- import Effectful.Dispatch.Dynamic+-- import Effectful.State.Static.Local+-- import Network.WebSockets (Connection, ConnectionOptions, ServerApp, WebSocketsData)+-- import Network.WebSockets qualified as WS+--+-- data Command+-- = Render [Content]+-- | Test Text+--+-- data Socket :: Effect where+-- SendMessage :: BL.ByteString -> Socket m ()+-- ReceiveData :: (WebSocketsData a) => Socket m a+--+-- type instance DispatchOf Socket = 'Dynamic+--+-- -- we should assume a connection here?+-- -- Accept :: PendingConnection -> Sockets m Connection+--+-- data Client = Client+-- { counter :: Int+-- , contents :: [Content]+-- }+--+-- type instance DispatchOf Socket = 'Dynamic+--+-- connectionOptions :: ConnectionOptions+-- connectionOptions = WS.defaultConnectionOptions+--+-- socketApplication :: Eff [Socket, IOE] () -> ServerApp+-- socketApplication talk pending = do+-- conn <- WS.acceptRequest pending+-- -- WS.sendTextData conn ("HELLO CLIENT" :: Text)+-- let client = Client 0 []+-- runEff . runSocket conn client $ forever talk+--+-- runSocket+-- :: (IOE :> es)+-- => Connection+-- -> Client+-- -> Eff (Socket : es) a+-- -> Eff es a+-- runSocket conn client = reinterpret (evalState client) $ \_ -> \case+-- SendMessage t -> do+-- -- cl :: Client <- get+-- liftIO $ WS.sendTextData conn t+-- ReceiveData -> do+-- a <- liftIO $ WS.receiveData conn+-- modify $ \c -> c{counter = c.counter + 1}+-- pure a+--+-- sendCommand :: (Socket :> es) => Command -> Eff es ()+-- sendCommand (Render cnt) = send $ SendMessage (formatMessage "Render" cnt)+-- sendCommand (Test cnt) = send $ SendMessage (formatMessage "Test" cnt)+--+-- receiveData :: (Socket :> es, WebSocketsData a) => Eff es a+-- receiveData = send ReceiveData+--+-- formatMessage :: (ToJSON a) => BL.ByteString -> a -> BL.ByteString+-- formatMessage flag cnt =+-- let content = A.encode cnt+-- in [i|#{flag} #{content}|]
+ src/Effectful/Wai.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FieldSelectors #-}+{-# LANGUAGE LambdaCase #-}++module Effectful.Wai where++import Control.Monad (when)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as L+import Data.Text (Text)+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.State.Static.Local+import Network.HTTP.Types (Status, status200, status500)+import Network.HTTP.Types.Header (HeaderName)+import Network.Wai as Wai+import Web.FormUrlEncoded+import Web.HttpApiData (FromHttpApiData)+import Web.View+++data Wai :: Effect where+ ResHeader :: HeaderName -> ByteString -> Wai m ()+ ResBody :: ContentType -> L.ByteString -> Wai m ()+ ResStatus :: Status -> Wai m ()+ ReqBody :: Wai m L.ByteString+ Request :: Wai m Request+ Continue :: Wai m ()+ Interrupt :: Interrupt -> Wai m a+++type instance DispatchOf Wai = 'Dynamic+++data Handler = Handler+ { request :: Request+ , cachedRequestBody :: L.ByteString+ , status :: Status+ , headers :: [(HeaderName, ByteString)]+ , contentType :: ContentType+ , body :: L.ByteString+ }+++data ContentType+ = ContentHtml+ | ContentText+++formData :: (Wai :> es) => Eff es Form+formData = do+ bd <- send ReqBody+ let ef = urlDecodeForm bd+ either (send . Interrupt . ParseError) pure ef+++parseFormData :: (Wai :> es, FromForm a) => Eff es a+parseFormData = do+ f <- formData+ either (send . Interrupt . ParseError) pure $ fromForm f+++formParam :: (Wai :> es, FromHttpApiData a) => Text -> Eff es a+formParam k = do+ f <- formData+ either (send . Interrupt . ParseError) pure $ parseUnique k f+++requestBody :: (Wai :> es) => Eff es L.ByteString+requestBody = send ReqBody+++runWai+ :: (IOE :> es)+ => Request+ -> Eff (Wai : es) a+ -> Eff es (Either Interrupt Handler)+runWai req = reinterpret runLocal $ \_ -> \case+ Request -> do+ gets request+ ReqBody -> do+ cacheReqBody+ gets cachedRequestBody+ ResHeader k v -> modify+ $ \r -> r{headers = (k, v) : r.headers}+ ResStatus s -> modify+ $ \r -> r{status = s}+ ResBody ct bd -> modify+ $ \r -> r{body = bd, contentType = ct, status = status200}+ Continue -> do+ h <- get+ throwError $ RespondNow h+ Interrupt e -> do+ throwError e+ where+ runLocal =+ runErrorNoCallStack @Interrupt+ . execState @Handler (emptyResponse req)++ cacheReqBody :: forall es. (IOE :> es, State Handler :> es) => Eff es ()+ cacheReqBody = do+ r <- get+ when (L.null r.cachedRequestBody) $ do+ rb <- liftIO $ Wai.consumeRequestBodyLazy req+ put $ r{cachedRequestBody = rb}+++-- Ends computation with whatever has already been set on the response+continue :: (Wai :> es) => Eff es ()+continue = send Continue+++emptyResponse :: Request -> Handler+emptyResponse r = Handler r "" status500 [] ContentText "Response not set"+++data Interrupt+ = NotFound+ | Redirect Url+ | ParseError Text+ | RespondNow Handler+++notFound :: (Wai :> es) => Eff es a+notFound = send $ Interrupt NotFound+++redirect :: (Wai :> es) => Url -> Eff es ()+redirect u = do+ send $ Interrupt $ Redirect u
+ src/Web/Hyperbole.hs view
@@ -0,0 +1,22 @@+module Web.Hyperbole+ ( module Web.Hyperbole.Route+ , module Web.Hyperbole.Effect+ , module Web.Hyperbole.HyperView+ , module Web.Hyperbole.Application+ , module Web.Hyperbole.Input+ , module Web.View+ , Application+ , run+ , scriptEmbed+ ) where++import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Web.Hyperbole.Application+import Web.Hyperbole.Effect+import Web.Hyperbole.Embed (scriptEmbed)+import Web.Hyperbole.HyperView+import Web.Hyperbole.Input+import Web.Hyperbole.Route+import Web.View hiding (button, form, input, label, link)+
+ src/Web/Hyperbole/Application.hs view
@@ -0,0 +1,72 @@+module Web.Hyperbole.Application+ ( waiApplication+ , Wai+ ) where++import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as L+import Data.String.Conversions (cs)+import Effectful+import Effectful.Wai+import Network.HTTP.Types (status200, status301, status400, status404)+import Network.HTTP.Types.Header (HeaderName)+import Network.Wai+import Web.Hyperbole.Route+import Web.View.Types (Url (..))+++waiApplication :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff [Wai, IOE] ()) -> Application+waiApplication toDoc actions request respond = do+ -- let (method, paths, query) = (requestMethod req, pathInfo req, queryString req)+ case findRoute (pathInfo request) of+ Nothing -> respond $ responseLBS status404 [contentType ContentText] "Not Found"+ Just rt -> do+ res <- runEff . runWai request $ actions rt+ case res of+ Left err -> interrupt err+ Right resp -> sendResponse resp+ where+ findRoute [] = Just defRoute+ findRoute ps = matchRoute (Path True ps)++ -- convert to document if GET. Subsequent POST requests will only include fragments+ addDocument "GET" bd = toDoc bd+ addDocument _ bd = bd++ contentType :: ContentType -> (HeaderName, ByteString)+ contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")+ contentType ContentText = ("Content-Type", "text/plain; charset=utf-8")++ sendResponse :: Handler -> IO ResponseReceived+ sendResponse resp = do+ let headers = contentType resp.contentType : resp.headers+ respBody = addDocument (requestMethod request) resp.body+ respond $ responseLBS status200 headers respBody++ interrupt NotFound =+ respond $ responseLBS status404 [contentType ContentText] "Not Found"+ interrupt (ParseError e) = do+ -- TODO: logging!+ putStrLn $ "Parse Error: " <> cs e+ respond $ responseLBS status400 [contentType ContentText] $ "Parse Error: " <> cs e+ interrupt (Redirect (Url u)) =+ respond $ responseLBS status301 [("Location", cs u)] ""+ interrupt (RespondNow resp) = do+ sendResponse resp+++{- | Run both the http and ws application+application :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff [Wai, IOE] ()) -> Application+application toDoc actions =+ websocketsOr connectionOptions (socketApplication talk)+ $ httpApplication toDoc actions+-}++-- talk :: (Socket :> es) => Eff es ()+-- talk = do+-- msg :: Text <- receiveData+--+-- -- HANDLE ACTION?+-- -- SEND VIEW (possibly multiple times). Need to run action...+--+-- sendCommand $ Render [Text $ "Updated: " <> msg]
+ src/Web/Hyperbole/Effect.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}++module Web.Hyperbole.Effect where++import Control.Monad (join)+import Data.ByteString+import Data.String.Conversions+import Data.String.Interpolate (i)+import Data.Text+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Wai (ContentType (..), Wai (..))+import Effectful.Wai qualified as Wai+import Network.HTTP.Types (Query)+import Network.Wai+import Web.FormUrlEncoded (Form)+import Web.FormUrlEncoded qualified as Form+import Web.Hyperbole.HyperView+import Web.View+++data Hyperbole :: Effect where+ GetForm :: Hyperbole m Form+ ParseForm :: (Form.FromForm a) => Hyperbole m a+ GetEvent :: (HyperView id) => Hyperbole m (Maybe (Event (Action id) id))+ RespondView :: View () () -> Hyperbole m ()+ HyperError :: HyperError -> Hyperbole m a+++type instance DispatchOf Hyperbole = 'Dynamic+++data Event act id = Event+ { viewId :: id+ , action :: act+ }+++runHyperbole+ :: (Wai :> es)+ => Eff (Hyperbole : es) a+ -> Eff es a+runHyperbole = interpret $ \_ -> \case+ RespondView vw -> do+ let bd = renderLazyByteString vw+ send $ ResHeader "Content-Type" "text/html"+ send $ ResBody ContentHtml bd+ Wai.continue+ GetForm -> Wai.formData+ ParseForm -> Wai.parseFormData+ HyperError NotFound -> send $ Interrupt Wai.NotFound+ HyperError (ParseError e) -> send $ Interrupt $ Wai.ParseError e+ GetEvent -> do+ q <- fmap queryString <$> send $ Wai.Request+ pure $ do+ Event ti ta <- lookupEvent q+ vid <- parseParam ti+ act <- parseParam ta+ pure $ Event vid act+ where+ lookupParam :: ByteString -> Query -> Maybe Text+ lookupParam p q =+ fmap cs <$> join $ lookup p q++ lookupEvent :: Query -> Maybe (Event Text Text)+ lookupEvent q =+ Event+ <$> lookupParam "id" q+ <*> lookupParam "action" q+++formData :: (Hyperbole :> es) => Eff es Form+formData = send GetForm+++parseFormData :: (Hyperbole :> es, Form.FromForm a) => Eff es a+parseFormData = send ParseForm+++-- | Read a required form parameter+param :: (Hyperbole :> es, Param a) => Text -> Form -> Eff es a+param p f = do+ -- param is required+ either (send . HyperError . ParseError) pure $ do+ t <- Form.lookupUnique p f+ maybe (Left [i|could not parseParam: '#{t}'|]) pure $ parseParam t+++notFound :: (Hyperbole :> es) => Eff es a+notFound = send (HyperError NotFound)+++-- | Set the response to the view. Note that `page` already expects a view to be returned from the effect+view :: (Hyperbole :> es) => View () () -> Eff es ()+view = send . RespondView+++data HyperError+ = NotFound+ | ParseError Text+++newtype Page es a = Page (Eff es a)+ deriving newtype (Applicative, Monad, Functor)+++-- | Load the entire page when no HyperViews match+load+ :: (Hyperbole :> es)+ => Eff es (View () ())+ -> Page es ()+load run = Page $ do+ vw <- run+ view vw+++-- | Handle a HyperView. If the event matches our handler, respond with the fragment+hyper+ :: (Hyperbole :> es, HyperView id)+ => (id -> Action id -> Eff es (View id ()))+ -> Page es ()+hyper run = Page $ do+ -- Get an event matching our type. If it doesn't match, skip to the next handler+ mev <- send GetEvent+ case mev of+ Just event -> do+ vw <- run event.viewId event.action+ view $ viewId event.viewId vw+ _ -> pure ()+++page+ :: (Hyperbole :> es)+ => Page es ()+ -> Eff es ()+page (Page eff) = eff
+ src/Web/Hyperbole/Embed.hs view
@@ -0,0 +1,16 @@+{-# 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/HyperView.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}++module Web.Hyperbole.HyperView where++import Data.Kind (Type)+import Data.Text+import Text.Read+import Web.Hyperbole.Route (Route (..), pathUrl)+import Web.View+++-- | Associate a live id with a set of actions+class (Param id, Param (Action id)) => HyperView id where+ type Action id :: Type+++viewId :: forall id ctx. (HyperView id) => id -> View id () -> View ctx ()+viewId vid vw = do+ el (att "id" (toParam vid) . flexCol)+ $ addContext vid vw+++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+++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+++-- | Internal+dataTarget :: (Param a) => a -> Mod+dataTarget = att "data-target" . toParam+++-- | Change the target of any code running inside, allowing actions to target other live views on the page+target :: (HyperView id) => id -> View id () -> View a ()+target = addContext+++dropdown+ :: (HyperView id)+ => (opt -> action)+ -> (opt -> Bool)+ -> View (Option opt id action) ()+ -> View id ()+dropdown toAction isSel options = do+ c <- context+ tag "select" (att "data-on-change" "" . dataTarget c) $ do+ addContext (Option toAction isSel) options+++option+ :: (HyperView id, Eq opt)+ => opt+ -> Mod+ -> View (Option opt id (Action id)) ()+ -> View (Option opt id (Action id)) ()+option opt f cnt = do+ os <- context+ tag "option" (att "value" (toParam (os.toAction opt)) . selected (os.selected opt) . f) cnt+++selected :: Bool -> Mod+selected b = if b then att "selected" "true" else id+++data Option opt id action = Option+ { toAction :: opt -> action+ , selected :: opt -> Bool+ }+++class Param a where+ -- not as flexible as FromHttpApiData, but derivable+ parseParam :: Text -> Maybe a+ default parseParam :: (Read a) => Text -> Maybe a+ parseParam = readMaybe . unpack+++ toParam :: a -> Text+ default toParam :: (Show a) => a -> Text+ toParam = pack . show+++instance Param Integer+instance Param Float+instance Param Int+instance Param ()+++instance Param Text where+ parseParam = pure+ toParam = id+++link :: (Route a) => a -> Mod -> View c () -> View c ()+link r f cnt = do+ let Url u = pathUrl . routePath $ r+ tag "a" (att "href" u . f) cnt
+ src/Web/Hyperbole/Input.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DefaultSignatures #-}++module Web.Hyperbole.Input where++import Data.Functor.Identity (Identity)+import Data.Kind (Type)+import Data.Text+import Effectful+import Effectful.Dispatch.Dynamic+import GHC.Generics+import Text.Casing (kebab)+import Web.FormUrlEncoded qualified as FE+import Web.Hyperbole.Effect+import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)+import Web.Internal.FormUrlEncoded (GFromForm, defaultFormOptions, genericFromForm)+import Web.View hiding (form, input)+++-- | The only time we can use Fields is inside a form+newtype FormFields f id = FormFields id+ deriving newtype (Show)+++instance (Param id, Show id) => Param (FormFields f id) where+ parseParam t = FormFields <$> parseParam t+ toParam (FormFields i) = toParam i+++instance (HyperView id, Show id) => HyperView (FormFields f id) where+ type Action (FormFields f id) = Action id+++-- | TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete+data FieldInput+ = NewPassword+ | CurrentPassword+ | Username+ | Email+ | Number+ | TextInput+ | Name+ | OneTimeCode+ | Organization+ | StreetAddress+ | Country+ | CountryName+ | PostalCode+ | Search+ deriving (Show)+++data Label a+++data Input a = Input+++newtype InputName = InputName Text+++field :: Mod -> View (Input id) () -> View (FormFields form id) ()+field f cnt =+ tag "label" (f . flexCol)+ $ addContext Input cnt+++label :: Text -> View (Input id) ()+label = text+++input :: FieldInput -> Mod -> InputName -> View (Input id) ()+input fi f (InputName n) = tag "input" (f . name n . att "type" (typ fi) . att "autocomplete" (auto fi)) none+ where+ typ NewPassword = "password"+ typ CurrentPassword = "password"+ typ Number = "number"+ typ Email = "email"+ typ Search = "search"+ typ _ = "text"++ auto :: FieldInput -> Text+ auto = pack . kebab . show+++form :: forall form id. (Form form, HyperView id) => Action id -> Mod -> (form Label -> View (FormFields form id) ()) -> View id ()+form a f fcnt = do+ vid <- context+ let frm = formLabels :: form Label+ let cnt = fcnt frm+ tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid) cnt+ where+ onSubmit :: (Param a) => a -> Mod+ onSubmit = att "data-on-submit" . toParam+++submit :: Mod -> View (FormFields form id) () -> View (FormFields form id) ()+submit f = tag "button" (att "type" "submit" . f)+++parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity)+parseForm = do+ (f :: FE.Form) <- formData+ let ef = fromForm f :: Either Text (form Identity)+ either (send . HyperError . ParseError) pure ef+++class Form (form :: (Type -> Type) -> Type) where+ formLabels :: form Label+ default formLabels :: (Generic (form Label), GFormLabels (Rep (form Label))) => form Label+ formLabels = to gFormLabels+++ 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+++type family Field (context :: Type -> Type) a+type instance Field Identity a = a+type instance Field Label a = InputName+++-- | Automatically derive labels from form field names+class GFormLabels f where+ gFormLabels :: f p+++instance GFormLabels U1 where+ gFormLabels = U1+++instance (GFormLabels f, GFormLabels g) => GFormLabels (f :*: g) where+ gFormLabels = gFormLabels :*: gFormLabels+++instance (Selector s) => GFormLabels (M1 S s (K1 R InputName)) where+ gFormLabels = M1 . K1 $ InputName $ pack (selName (undefined :: M1 S s (K1 R Text) p))+++instance (GFormLabels f) => GFormLabels (M1 D d f) where+ gFormLabels = M1 gFormLabels+++instance (GFormLabels f) => GFormLabels (M1 C c f) where+ gFormLabels = M1 gFormLabels
+ src/Web/Hyperbole/Route.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DefaultSignatures #-}++module Web.Hyperbole.Route where++import Control.Applicative ((<|>))+import Control.Monad (guard)+import Data.String (IsString (..))+import Data.Text (Text, dropWhile, dropWhileEnd, intercalate, pack, splitOn, toLower, unpack)+import GHC.Generics+import Text.Read (readMaybe)+import Web.View.Types (Url (..))+import Prelude hiding (dropWhile)+++type IsAbsolute = Bool+type Segment = Text+data Path = Path+ { isAbsolute :: Bool+ , segments :: [Segment]+ }+ deriving (Show)+++-- what if you want a relative url?+instance IsString Path where+ fromString s = Path (isRoot s) [cleanSegment $ pack s]+ where+ isRoot ('/' : _) = True+ isRoot _ = False+++class Route a where+ matchRoute :: Path -> Maybe a+ routePath :: a -> Path+ defRoute :: a+++ default matchRoute :: (Generic a, GenRoute (Rep a)) => Path -> Maybe a+ -- this will match a trailing slash, but not if it is missing+ matchRoute (Path _ [""]) = pure defRoute+ matchRoute (Path _ segs) = to <$> genRoute segs+++ default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> Path+ routePath p+ | p == defRoute = Path True [""]+ | otherwise = Path True $ genPaths $ from p+++ default defRoute :: (Generic a, GenRoute (Rep a)) => a+ defRoute = to genFirst+++pathUrl :: Path -> Url+pathUrl (Path True ss) = Url $ "/" <> intercalate "/" ss+pathUrl (Path False ss) = Url $ intercalate "/" ss+++cleanSegment :: Segment -> Segment+cleanSegment = dropWhileEnd (== '/') . dropWhile (== '/')+++pathSegments :: Text -> [Segment]+pathSegments path = splitOn "/" $ dropWhile (== '/') path+++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+instance (Constructor c, GenRoute f) => GenRoute (M1 C c f) where+ genRoute (n : ps) = do+ -- take the first path off the list+ -- check that it matches the constructor name+ -- check that the rest matches+ let name = conName (undefined :: M1 C c f x)+ guard (n == toLower (pack name))+ M1 <$> genRoute ps+ genRoute [] = Nothing+++ genFirst = M1 genFirst+++ genPaths (M1 x) =+ let name = conName (undefined :: M1 C c f x)+ in toLower (pack name) : genPaths x+++-- Unary constructors+instance GenRoute U1 where+ genRoute [] = pure U1+ genRoute _ = Nothing+ genPaths _ = []+ genFirst = U1+++-- Selectors+instance (GenRoute f) => GenRoute (M1 S c f) where+ genRoute ps =+ 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+++-- Product types+instance (GenRoute a, GenRoute b) => GenRoute (a :*: b) where+ genRoute (p : ps) = do+ ga <- genRoute [p]+ gr <- genRoute ps+ pure $ ga :*: gr+ genRoute _ = Nothing+++ genFirst = genFirst :*: genFirst+++ genPaths (a :*: b) = genPaths a <> genPaths b+++instance (Route sub) => GenRoute (K1 R sub) where+ genRoute ts = K1 <$> matchRoute (Path True ts)+ genFirst = K1 defRoute+ genPaths (K1 sub) = (routePath sub).segments+++genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a)+genRouteRead [t] = do+ K1 <$> readMaybe (unpack t)+genRouteRead _ = Nothing+++instance Route Text where+ matchRoute (Path _ [t]) = pure t+ matchRoute _ = Nothing+ routePath t = Path False [t]+ defRoute = ""+++instance Route String where+ matchRoute (Path _ [t]) = pure (unpack t)+ matchRoute _ = Nothing+ routePath t = Path False [pack t]+ defRoute = ""+++instance Route Integer where+ matchRoute = matchRouteRead+ routePath = routePathShow+ defRoute = 0+++instance Route Int where+ matchRoute = matchRouteRead+ routePath = routePathShow+ defRoute = 0+++instance (Route a) => Route (Maybe a) where+ matchRoute (Path _ []) = pure Nothing+ matchRoute ps = Just <$> matchRoute ps+ routePath (Just a) = routePath a+ routePath Nothing = Path False []+ defRoute = Nothing+++matchRouteRead :: (Read a) => Path -> Maybe a+matchRouteRead (Path _ [t]) = readMaybe (unpack t)+matchRouteRead _ = Nothing+++routePathShow :: (Show a) => a -> Path+routePathShow a = Path False [pack (show a)]