hyperbole 0.7.0 → 0.7.1
raw patch · 24 files changed
+926/−152 lines, 24 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +2/−1
- client/dist/hyperbole.js +1/−1
- docs/Docgen.hs +242/−102
- hyperbole.cabal +2/−4
- src/Web/Hyperbole/Application.hs +38/−3
- src/Web/Hyperbole/Data/Encoded.hs +2/−0
- src/Web/Hyperbole/Data/QueryData.hs +41/−2
- src/Web/Hyperbole/Document.hs +23/−2
- src/Web/Hyperbole/Effect/Client.hs +50/−3
- src/Web/Hyperbole/Effect/Query.hs +72/−6
- src/Web/Hyperbole/Effect/Response.hs +18/−1
- src/Web/Hyperbole/Effect/Session.hs +57/−3
- src/Web/Hyperbole/HyperView/Event.hs +24/−3
- src/Web/Hyperbole/HyperView/Forms.hs +163/−7
- src/Web/Hyperbole/HyperView/Hyper.hs +24/−2
- src/Web/Hyperbole/HyperView/Input.hs +34/−3
- src/Web/Hyperbole/HyperView/Types.hs +20/−1
- src/Web/Hyperbole/Page.hs +27/−2
- src/Web/Hyperbole/Route.hs +21/−1
- src/Web/Hyperbole/View/CSS.hs +11/−1
- src/Web/Hyperbole/View/Embed.hs +1/−0
- src/Web/Hyperbole/View/Types.hs +29/−2
- src/Web/Hyperbole/View/ViewAction.hs +15/−1
- src/Web/Hyperbole/View/ViewId.hs +9/−1
CHANGELOG.md view
@@ -1,7 +1,7 @@ # Revision history for hyperbole -## 0.7.0 -- TODO+## 0.7.1 -- 2026-07.01 Features: * Accept multipart form file uploads with good default security settings@@ -12,6 +12,7 @@ * Deprecated `toActionInput` in favor of `inputValue` - Instead of partially applying a constructor, inputs are read with a function similar to forms * `Web.Hyperbole.Data.Param` was unnecessary and removed. Everything uses ToJSON and FromJSON as an intermediate encoding * moved OAuth2 to sub-package to allow for dependencies on cryptography libraries+* Embedded Haddock docs will work even in projects that depend on hyperbole Breaking Changes: * Actions with input like `search`, `onInput` and `dropdown` should now use an action with no arguments. Get the value using `inputValue` instead
client/dist/hyperbole.js view
@@ -11,5 +11,5 @@ `+t),this.name=`ProtocolError`}},k=`${window.location.protocol===`https:`?`wss:`:`ws:`}//${window.location.host}${window.location.pathname}`,A=class{socket;hasEverConnected=!1;isConnected=!1;reconnectDelay=0;queue=[];events;constructor(e=k){this.events=new EventTarget;let t=new WebSocket(e);this.socket=t}connect(e=k,t=!1){let n=t?new WebSocket(e):this.socket;this.socket=n;function r(e){console.error(`Connect Error`,e)}function i(e){console.error(`Socket Error`,e)}n.addEventListener(`error`,r),n.addEventListener(`open`,e=>{console.log(`Websocket Connected`),this.hasEverConnected&&document.dispatchEvent(new Event(`hyp-socket-reconnect`)),this.isConnected=!0,this.hasEverConnected=!0,this.reconnectDelay=1e3,n.removeEventListener(`error`,r),n.addEventListener(`error`,i),document.dispatchEvent(new Event(`hyp-socket-connect`)),this.runQueue()}),n.addEventListener(`close`,t=>{console.log(`CLOSE SOCKET`),this.isConnected&&document.dispatchEvent(new Event(`hyp-socket-disconnect`)),this.isConnected=!1,n.removeEventListener(`error`,i),this.hasEverConnected&&(console.log(`Reconnecting in `+this.reconnectDelay/1e3+`s`),setTimeout(()=>this.connect(e,!0),this.reconnectDelay)),n.removeEventListener(`error`,i)}),n.addEventListener(`message`,e=>this.onMessage(e))}async sendAction(e){if(this.isConnected){let t=he(e);this.socket.send(t)}else this.queue.push(e)}runQueue(){let e=this.queue.pop();e&&(console.log(`runQueue: `,e),this.sendAction(e),this.runQueue())}onMessage(e){let{command:t,metas:n,rest:r}=j(e.data),i=parseInt(a(`RequestId`),0);function a(t){let r=x(t,n);if(!r)throw new O(`Missing Required Metadata: `+t,e.data);return r}function o(e){return{requestId:i,targetViewId:void 0,viewId:a(`ViewId`),action:a(`Action`),meta:y(n),body:e.join(` `)}}function s(e){let t=o(e);return t.targetViewId=x(`TargetViewId`,n),t}function c(e){let t=e[0];return{requestId:i,meta:y(n),url:t}}function l(e){let{requestId:t,meta:n,viewId:r,action:i}=o(e),[s,c]=T(a(`Trigger`));return{requestId:t,meta:n,viewId:r,action:i,targetViewId:s,targetAction:c}}function u(e){let{requestId:t,meta:n,viewId:r,action:i}=o(e);return{requestId:t,meta:n,viewId:r,action:i,event:w(a(`Event`))}}switch(t){case`|UPDATE|`:this.dispatchEvent(new CustomEvent(`update`,{detail:s(r)}));return;case`|RESPONSE|`:this.dispatchEvent(new CustomEvent(`response`,{detail:o(r)}));return;case`|REDIRECT|`:return this.dispatchEvent(new CustomEvent(`redirect`,{detail:c(r)}));case`|TRIGGER|`:return this.dispatchEvent(new CustomEvent(`trigger`,{detail:l(r)}));case`|EVENT|`:return this.dispatchEvent(new CustomEvent(`event`,{detail:u(r)}));default:throw new O(`Unknown Server Command: `+t,e.data)}}addEventListener(e,t){this.events.addEventListener(e,t)}dispatchEvent(e){this.events.dispatchEvent(e)}disconnect(){this.isConnected=!1,this.hasEverConnected=!1,this.socket.close()}};function j(e){let t=e.split(` `),n=t[0],r=C(t.slice(1));return{command:n,metas:r,rest:de(e=>e==``,t.slice(r.length+1))}}function M(e,t=100,n={}){if(typeof e!=`function`)throw TypeError(`Expected the first parameter to be a function, got \`${typeof e}\`.`);if(t<0)throw RangeError("`wait` must not be negative.");if(typeof n==`boolean`)throw TypeError("The `options` parameter must be an object, not a boolean. Use `{immediate: true}` instead.");let{immediate:r}=n,i,a,o,s,c;function l(){let t=i,n=a;return i=void 0,a=void 0,c=e.apply(t,n),c}function u(){let e=Date.now()-s;e<t&&e>=0?o=setTimeout(u,t-e):(o=void 0,r||(c=l()))}let d=function(...e){if(i&&this!==i&&Object.getPrototypeOf(this)===Object.getPrototypeOf(i))throw Error(`Debounced method called with different contexts of the same prototype.`);i=this,a=e,s=Date.now();let n=r&&!o;if(o||=setTimeout(u,t),n)return c=l(),c};return Object.defineProperty(d,`isPending`,{get(){return o!==void 0}}),d.clear=()=>{o&&(clearTimeout(o),o=void 0,i=void 0,a=void 0)},d.flush=()=>{o&&d.trigger()},d.trigger=()=>{c=l(),d.clear()},d}var N=e=>e?.runAction!==void 0;function P(e){let t=new Event(`hyp-content`,{bubbles:!0});e.dispatchEvent(t)}function F(e,t){e.querySelectorAll(`[id]`).forEach(n=>{n.runAction=function(e,r){return t(n,e,r)},n.concurrency=n.dataset.concurrency||`Drop`,n.cancelActiveRequest=function(){n.activeRequest&&!n.activeRequest?.isCancelled&&(n.activeRequest.isCancelled=!0)},P(e)})}function Se(e){I(`keydown`,e)}function Ce(e){I(`keyup`,e)}function I(e,t){document.addEventListener(e,function(n){if(!(n.target instanceof HTMLElement)){console.warn(`listenKeyEvent received event with non HTMLElment as EventTarget: %o`,n);return}let r=n.target,i=`on`+e+n.key,a=r.dataset[i];if(!a)return;n.preventDefault();let o=V(r);if(!o){console.error(`Missing target: `,r);return}t(o,a)})}function L(e,t){document.addEventListener(e,function(n){if(!(n.target instanceof Element)){console.warn(`listenBubblingEvent received an event with non Elment as EventTarget: %o`,n);return}let r=n.target.closest(`[data-on`+e+`]`);if(!r)return;n.preventDefault();let i=V(r);if(!i){console.error(`Missing target: `,r);return}let a=r.dataset[`on`+e];if(a===void 0){console.error(`Missing action: `,r,e);return}t(i,a)})}function we(e){L(`click`,e)}function Te(e){L(`dblclick`,e)}function Ee(e){document.addEventListener(`hyp-load`,function(t){let n=t.detail.onLoad,r=t.detail.target;e(r,n)}),document.addEventListener(`hyp-mouseenter`,function(t){let n=t.detail.onMouseEnter,r=t.detail.target;e(r,n)}),document.addEventListener(`hyp-mouseleave`,function(t){let n=t.detail.onMouseLeave,r=t.detail.target;e(r,n)})}function R(e){e.querySelectorAll(`[data-onload]`).forEach(e=>{let t=parseInt(e.dataset.delay||``)||0,n=e.dataset.onload;setTimeout(()=>{let t=V(e);if(e.dataset.onload!=n)return;let r=new CustomEvent(`hyp-load`,{bubbles:!0,detail:{target:t,onLoad:n}});e.dispatchEvent(r)},t)})}function z(e){e.querySelectorAll(`[data-onmouseenter]`).forEach(e=>{let t=e.dataset.onmouseenter,n=H(e);e.onmouseenter=()=>{let r=new CustomEvent(`hyp-mouseenter`,{bubbles:!0,detail:{target:n,onMouseEnter:t}});e.dispatchEvent(r)}})}function B(e){e.querySelectorAll(`[data-onmouseleave]`).forEach(e=>{let t=e.dataset.onmouseleave,n=H(e);e.onmouseleave=()=>{let r=new CustomEvent(`hyp-mouseleave`,{bubbles:!0,detail:{target:n,onMouseLeave:t}});e.dispatchEvent(r)}})}function De(e){document.addEventListener(`change`,function(t){if(!(t.target instanceof HTMLElement)){console.warn(`listenChange received an event with non HTMLElment as EventTarget: %o`,t);return}let n=t.target.closest(`[data-onchange]`);if(!n)return;if(t.preventDefault(),n.value===null){console.error(`Missing input value:`,n);return}let r=V(n);if(!r){console.error(`Missing target: listenChange`);return}if(!n.dataset.onchange){console.error(`Missing onchange: `,n);return}e(r,n.dataset.onchange,n.value)})}function Oe(e,t){document.addEventListener(`input`,function(n){if(!(n.target instanceof HTMLElement)){console.warn(`listenInput received an event with non HTMLElment as EventTarget: %o`,n);return}let r=n.target.closest(`[data-oninput]`);if(!r)return;let i=parseInt(r.dataset.delay||``)||250;i<250&&console.warn(`Input delay < 250 can result in poor performance.`),n.preventDefault();let a=V(r);if(!a){console.error(`Missing target: `,r);return}e(a),r.debouncedCallback||=M(()=>{if(!r.dataset.oninput){console.error(`Missing onInput: `,r);return}t(a,r.dataset.oninput,r.value)},i),r.debouncedCallback()})}function ke(e){document.addEventListener(`submit`,function(t){if(!(t.target instanceof HTMLFormElement)){console.warn(`listenFormSubmit received an event with non HTMLElment as EventTarget: %o`,t);return}let n=t.target;if(!n.dataset.onsubmit){console.error(`Missing onSubmit: `,n);return}t.preventDefault();let r=V(n),i=new FormData(n);if(!r){console.error(`Missing target: `,r);return}e(r,n.dataset.onsubmit,i)})}function Ae(e){return e.closest(`[data-target]`)?.dataset.target||e.closest(`[id]`)?.id}function V(e){let t=H(e);if(!N(t)){console.error(`Non HyperView target: `,t);return}return t}function H(e){let t=Ae(e),n=t&&document.getElementById(t);if(!n){console.error(`Cannot find target: `,t,e);return}return n}function je(e){if(e!=Me()){e!=``&&(e=`?`+e);let t=location.pathname+e;window.history.replaceState({},``,t)}}function Me(){let e=window.location.search;return e.startsWith(`?`)?e.substring(1):e}async function Ne(e){let t=window.location.href,n={Accept:`text/html`,"Hyp-ViewId":e.viewId,"Hyp-RequestId":e.requestId,"Hyp-Action":e.action,"Hyp-State":e.state||`()`};console.log(`sendActionHttp`,e.form);let{metas:r,rest:i}=Pe(await(await fetch(t,{method:`POST`,headers:n,body:e.form,redirect:`manual`})).text());return xe(r,i)}function Pe(e){let t=e.split(`-`);return{metas:C(t.slice(1)),rest:t.slice(2)}}console.log(`Hyperbole 0.7.0b`);var U,W=new Set;async function G(e,t,n){if(e.activeRequest&&!e.activeRequest?.isCancelled&&e.concurrency==`Drop`){console.warn(`Drop action overlapping with active request`,e.activeRequest,t);return}e._timeout=window.setTimeout(()=>{e.classList.add(`hyp-loading`)},100);let r=e.dataset.state,i=ve(),a=me(e.id,t,r,i.requestId,n);if(e.activeRequest=i,!a.form)$.sendAction(a);else{let e=await Ne(a);switch(console.log(`RESPONSE`,e),e.kind){case`redirect`:console.log(`TODO HANDLE REDIRECT`);break;case`response`:q(e);break}}}function K(e){Q(e.targetViewId,e.targetAction)}function Fe(e){let t=document.getElementById(e.viewId);Z(e.event,t)}function Ie(e){console.log(`REDIRECT`,e),Y(e.meta.cookies??[]),window.location.href=e.url}function q(e){let t=J(e.viewId,e);t&&(delete t.activeRequest,clearTimeout(t._timeout),t.classList.remove(`hyp-loading`))}function Le(e){e.meta.error?J(e.viewId,e):e.targetViewId?J(e.targetViewId,e):console.error(`Missing Update targetViewId`,e)}function J(e,t){let n=document.getElementById(e);if(!N(n)){console.error(`Missing Update HyperView Target: `,e,t);return}if(n.activeRequest?.requestId&&t.requestId<n.activeRequest.requestId)return console.warn(`Ignore Stale Action (`+t.requestId+`) vs (`+n.activeRequest.requestId+`): `+t.action),n;if(n.activeRequest?.isCancelled)return console.warn(`Cancelled request`,n.activeRequest?.requestId),delete n.activeRequest,n;let r=be(ye(t.body));if(!r.content)return console.error(`Empty Response!`,t.body),n;ze(r.css);let i=v(n),a=v(r.content),o=a.attributes;if(!t.meta.error&&o.id!=n.id){console.error(`Mismatched ViewId in update - `,o.id,` target:`,n.id);return}let s=o[`data-state`];a.attributes=i.attributes,le(a,i);let c=document.getElementById(n.id);return c?(P(c),s===void 0||s==`()`?delete c.dataset.state:c.dataset.state=s,X(t.meta,c),Y(t.meta.cookies??[]),R(c),z(c),B(c),Re(c),F(c,G),n):(console.warn(`Target Missing: `,n.id),n)}function Y(e){e.forEach(e=>{console.log(`SetCookie: `,e),document.cookie=e})}function X(e,t){e.query!=null&&je(e.query),e.pageTitle!=null&&(document.title=e.pageTitle),e.events?.forEach(e=>{Z(e,t)}),e.actions?.forEach(([e,t])=>{Q(e,t)})}function Z(e,t){setTimeout(()=>{let n=new CustomEvent(e.name,{bubbles:!0,detail:e.detail});(t||document).dispatchEvent(n)},10)}function Q(e,t){setTimeout(()=>{let n=window.Hyperbole?.hyperView(e);n&&G(n,t,void 0)},10)}function Re(e){let t=e.querySelector(`[autofocus]`);t?.focus&&t.focus(),e.querySelectorAll(`input[value]`).forEach(e=>{let t=e.getAttribute(`value`);t!==null&&(e.value=t)}),e.querySelectorAll(`input[type=checkbox]`).forEach(e=>{e.checked=e.dataset.checked==`True`})}function ze(e){if(!e)return;let t=e.sheet?.cssRules;if(t)for(let e=0;e<t.length;e++){let n=t.item(e);n&&W.has(n.cssText)==0&&U.sheet&&(U.sheet.insertRule(n.cssText),W.add(n.cssText))}}function Be(){X(b(document.getElementById(`hyp.metadata`)?.innerText??``),null);let e=document.body.querySelector(`style`);e===null?(console.warn(`rootStyles missing from page, creating...`),U=document.createElement(`style`),U.type=`text/css`,document.body.appendChild(U)):U=e,Ee(async function(e,t){G(e,t,void 0)}),R(document.body),z(document.body),B(document.body),F(document.body,G),we(async function(e,t){G(e,t,void 0)}),Te(async function(e,t){G(e,t,void 0)}),Se(async function(e,t){G(e,t,void 0)}),Ce(async function(e,t){G(e,t)}),ke(async function(e,t,n){G(e,t,n)}),De(async function(e,t,n){G(e,t,n)});function t(e){e.concurrency==`Replace`&&e.cancelActiveRequest()}Oe(t,async function(e,t,n){G(e,t,n)})}document.addEventListener(`DOMContentLoaded`,Be);var $=new A;$.connect(),$.addEventListener(`update`,e=>Le(e.detail)),$.addEventListener(`response`,e=>q(e.detail)),$.addEventListener(`redirect`,e=>Ie(e.detail)),$.addEventListener(`trigger`,e=>K(e.detail)),$.addEventListener(`event`,e=>Fe(e.detail)),window.Hyperbole={runAction:G,parseMetadata:b,action:function(e,...t){return t.reduce((e,t)=>e+` `+JSON.stringify(t),e)},hyperView:function(e){let t=document.getElementById(e);if(!N(t)){console.error(`Element id=`+e+` was not a HyperView`);return}return t},socket:$}})();+`);return{metas:C(t.slice(1)),rest:t.slice(2)}}console.log(`Hyperbole 0.7.1b`);var U,W=new Set;async function G(e,t,n){if(e.activeRequest&&!e.activeRequest?.isCancelled&&e.concurrency==`Drop`){console.warn(`Drop action overlapping with active request`,e.activeRequest,t);return}e._timeout=window.setTimeout(()=>{e.classList.add(`hyp-loading`)},100);let r=e.dataset.state,i=ve(),a=me(e.id,t,r,i.requestId,n);if(e.activeRequest=i,!a.form)$.sendAction(a);else{let e=await Ne(a);switch(console.log(`RESPONSE`,e),e.kind){case`redirect`:console.log(`TODO HANDLE REDIRECT`);break;case`response`:q(e);break}}}function K(e){Q(e.targetViewId,e.targetAction)}function Fe(e){let t=document.getElementById(e.viewId);Z(e.event,t)}function Ie(e){console.log(`REDIRECT`,e),Y(e.meta.cookies??[]),window.location.href=e.url}function q(e){let t=J(e.viewId,e);t&&(delete t.activeRequest,clearTimeout(t._timeout),t.classList.remove(`hyp-loading`))}function Le(e){e.meta.error?J(e.viewId,e):e.targetViewId?J(e.targetViewId,e):console.error(`Missing Update targetViewId`,e)}function J(e,t){let n=document.getElementById(e);if(!N(n)){console.error(`Missing Update HyperView Target: `,e,t);return}if(n.activeRequest?.requestId&&t.requestId<n.activeRequest.requestId)return console.warn(`Ignore Stale Action (`+t.requestId+`) vs (`+n.activeRequest.requestId+`): `+t.action),n;if(n.activeRequest?.isCancelled)return console.warn(`Cancelled request`,n.activeRequest?.requestId),delete n.activeRequest,n;let r=be(ye(t.body));if(!r.content)return console.error(`Empty Response!`,t.body),n;ze(r.css);let i=v(n),a=v(r.content),o=a.attributes;if(!t.meta.error&&o.id!=n.id){console.error(`Mismatched ViewId in update - `,o.id,` target:`,n.id);return}let s=o[`data-state`];a.attributes=i.attributes,le(a,i);let c=document.getElementById(n.id);return c?(P(c),s===void 0||s==`()`?delete c.dataset.state:c.dataset.state=s,X(t.meta,c),Y(t.meta.cookies??[]),R(c),z(c),B(c),Re(c),F(c,G),n):(console.warn(`Target Missing: `,n.id),n)}function Y(e){e.forEach(e=>{console.log(`SetCookie: `,e),document.cookie=e})}function X(e,t){e.query!=null&&je(e.query),e.pageTitle!=null&&(document.title=e.pageTitle),e.events?.forEach(e=>{Z(e,t)}),e.actions?.forEach(([e,t])=>{Q(e,t)})}function Z(e,t){setTimeout(()=>{let n=new CustomEvent(e.name,{bubbles:!0,detail:e.detail});(t||document).dispatchEvent(n)},10)}function Q(e,t){setTimeout(()=>{let n=window.Hyperbole?.hyperView(e);n&&G(n,t,void 0)},10)}function Re(e){let t=e.querySelector(`[autofocus]`);t?.focus&&t.focus(),e.querySelectorAll(`input[value]`).forEach(e=>{let t=e.getAttribute(`value`);t!==null&&(e.value=t)}),e.querySelectorAll(`input[type=checkbox]`).forEach(e=>{e.checked=e.dataset.checked==`True`})}function ze(e){if(!e)return;let t=e.sheet?.cssRules;if(t)for(let e=0;e<t.length;e++){let n=t.item(e);n&&W.has(n.cssText)==0&&U.sheet&&(U.sheet.insertRule(n.cssText),W.add(n.cssText))}}function Be(){X(b(document.getElementById(`hyp.metadata`)?.innerText??``),null);let e=document.body.querySelector(`style`);e===null?(console.warn(`rootStyles missing from page, creating...`),U=document.createElement(`style`),U.type=`text/css`,document.body.appendChild(U)):U=e,Ee(async function(e,t){G(e,t,void 0)}),R(document.body),z(document.body),B(document.body),F(document.body,G),we(async function(e,t){G(e,t,void 0)}),Te(async function(e,t){G(e,t,void 0)}),Se(async function(e,t){G(e,t,void 0)}),Ce(async function(e,t){G(e,t)}),ke(async function(e,t,n){G(e,t,n)}),De(async function(e,t,n){G(e,t,n)});function t(e){e.concurrency==`Replace`&&e.cancelActiveRequest()}Oe(t,async function(e,t,n){G(e,t,n)})}document.addEventListener(`DOMContentLoaded`,Be);var $=new A;$.connect(),$.addEventListener(`update`,e=>Le(e.detail)),$.addEventListener(`response`,e=>q(e.detail)),$.addEventListener(`redirect`,e=>Ie(e.detail)),$.addEventListener(`trigger`,e=>K(e.detail)),$.addEventListener(`event`,e=>Fe(e.detail)),window.Hyperbole={runAction:G,parseMetadata:b,action:function(e,...t){return t.reduce((e,t)=>e+` `+JSON.stringify(t),e)},hyperView:function(e){let t=document.getElementById(e);if(!N(t)){console.error(`Element id=`+e+` was not a HyperView`);return}return t},socket:$}})(); //# sourceMappingURL=hyperbole.js.map
docs/Docgen.hs view
@@ -1,65 +1,251 @@ module Main where +import Control.Exception (SomeException, try)+import Control.Monad (when) import Data.Char (isAlpha, isSpace) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T+import Effectful+import Effectful.State.Static.Local import System.Directory import System.Environment (getArgs) import System.FilePath +-- Manually run this on the entire repository+-- main :: IO ()+-- main = do+-- args <- getArgs+-- case args of+-- [original, input, output] -> do+-- src <- readSource input+-- expanded <- expandFile src+-- let linePragma = T.pack $ "{-# LINE 1 \"" ++ original ++ "\" #-}"+-- let final = SourceCode [linePragma] <> expanded+-- T.writeFile output $ T.unlines final.lines+-- _ -> error "Usage (Hyperbole Internal Only): docgen src/MyModule.hs /tmp/input/MyModule.hs /build/output/Original.hs"+ main :: IO () main = do args <- getArgs- case args of- [original, input, output] -> do- src <- readSource input- expanded <- expandFile src- let linePragma = T.pack $ "{-# LINE 1 \"" ++ original ++ "\" #-}"- let final = SourceCode [linePragma] <> expanded- T.writeFile output $ T.unlines final.lines- _ -> error "Usage (Hyperbole Internal Only): docgen src/MyModule.hs /tmp/input/MyModule.hs /build/output/Original.hs"+ files <- case args of+ [] -> do+ putStrLn "Docgen: all sources"+ relativeSourceFiles "./src"+ fs -> do+ pure fs + mapM_ processFile files+ where+ processFile :: FilePath -> IO ()+ processFile file = do+ putStrLn $ "Docgen: " <> file+ src <- readSourceCode file+ src' <- expandFile src+ T.writeFile file src'.contents+ pure () --- test :: IO ()--- test = do--- src <- readSource "./src/Web/Hyperbole.hs"--- SourceCode lns <- expandFile src--- mapM_ print lns --- expandSourcesTo :: FilePath -> IO ()--- expandSourcesTo tmpDir = do--- allFiles <- relativeSourceFiles "./src"--- -- mapM_ (putStrLn . ("SOURCE " <>)) allFiles--- mapM_ (expandAndCopyFileTo tmpDir) allFiles+relativeSourceFiles :: FilePath -> IO [FilePath]+relativeSourceFiles dir = do+ contents <- tryDirectory dir+ let folders = filter isFolder contents+ let files = filter isSourceFile contents --- copyExtraFilesTo :: FilePath -> IO ()--- copyExtraFilesTo tmpDir = do--- createDirectoryIfMissing True tmpDir--- copyFile "./cabal.project" (tmpDir </> "cabal.project")--- copyFile "./hyperbole.cabal" (tmpDir </> "hyperbole.cabal")--- copyFile "./README.md" (tmpDir </> "README.md")--- copyFile "./CHANGELOG.md" (tmpDir </> "CHANGELOG.md")--- copyFile "./LICENSE" (tmpDir </> "LICENSE")--- createDirectoryIfMissing True (tmpDir </> "client/dist")--- copyFile "./client/dist/hyperbole.js" (tmpDir </> "client/dist/hyperbole.js")--- copyFile "./client/dist/hyperbole.js.map" (tmpDir </> "client/dist/hyperbole.js.map")--- createDirectoryIfMissing True (tmpDir </> "client/util")--- copyFile "./client/util/live-reload.js" (tmpDir </> "client/util/live-reload.js")+ files' <- mapM (relativeSourceFiles . addDir) folders --- expandAndCopyFileTo :: FilePath -> FilePath -> IO ()--- expandAndCopyFileTo tmpDir pth = do--- putStrLn $ "EXPANDING " <> pth--- src <- readSource pth--- expanded <- expandFile src--- writeSource tmpDir pth expanded+ pure $ fmap addDir files <> mconcat files'+ where+ isSourceFile pth = takeExtension pth == ".hs"+ isFolder pth = takeExtension pth == ""+ addDir = (dir </>)+ tryDirectory pth = do+ res <- try $ listDirectory pth+ case res of+ Left (_ :: SomeException) -> do+ putStrLn $ "SKIPPED" <> pth+ pure []+ Right files -> pure files ++srcDirectory :: FilePath+srcDirectory = "./src"+++demoDirectory :: FilePath+demoDirectory = "./demo"+++-- expandFile :: SourceCode -> IO SourceCode+-- expandFile (SourceCode src) =+-- case T.breakOn "{-$" src of+-- (end, "") -> pure $ SourceCode end+-- (start, rest) -> do+-- let (commentFragment, restInner) = T.breakOn "-}" rest+-- let next = T.drop 2 restInner -- drop the comment chars+-- let comment = commentFragment <> "-}"+-- pure SourceCode start <> next++expandFile :: SourceCode -> IO SourceCode+expandFile src = do+ parsed <- parseSource src++ -- putStrLn "\nPARSED"+ -- putStrLn "============"+ -- mapM_ print parsed++ expanded <- mconcat <$> mapM expandBlock parsed++ -- putStrLn "\nEXPANDED"+ -- putStrLn "============"+ -- mapM_ print expanded++ -- let final = dropOldHaddockBlocks expanded+ -- putStrLn "\nFINAL"+ -- putStrLn "============"+ -- mapM_ print final++ -- pure $ allToSourceCode $ dropOldHaddockBlocks final+ pure $ allToSourceCode expanded+++-- dropOldHaddockBlocks :: [ParsedSource] -> [ParsedSource]+-- dropOldHaddockBlocks ps =+-- case ps of+-- [] -> []+-- (CommentTarget t : OtherCode newlines : HaddockBlock h1 : OtherCode _ : HaddockBlock _ : rest) ->+-- CommentTarget t : OtherCode newlines : HaddockBlock h1 : rest+-- (ps1 : rest) -> ps1 : dropOldHaddockBlocks rest++expandBlock :: ParsedSource -> IO [ParsedSource]+expandBlock p =+ case p of+ OtherCode t -> pure [OtherCode t]+ HaddockBlock t -> pure [HaddockBlock t]+ CommentTarget t -> do+ haddock <- haddockBlock t+ pure [CommentTarget t, OtherCode "\n\n", haddock]+ where+ haddockBlock :: Text -> IO ParsedSource+ haddockBlock t = do+ let lns = T.lines t+ out <- mconcat <$> mapM expandLine lns+ pure $ HaddockBlock $ "{- |" <> T.drop 4 (T.dropWhileEnd (== '\n') (T.unlines out)) <> "\n"+++allToSourceCode :: [ParsedSource] -> SourceCode+allToSourceCode = mconcat . fmap toSourceCode+++data ParsedSource+ = OtherCode Text+ | CommentTarget Text+ | HaddockBlock Text+ deriving (Show, Eq)+++toSourceCode :: ParsedSource -> SourceCode+toSourceCode p =+ case p of+ OtherCode t -> SourceCode t+ CommentTarget t -> SourceCode t+ HaddockBlock t -> SourceCode t+++parseSource :: SourceCode -> IO [ParsedSource]+parseSource sourceCode =+ runParser sourceCode parseFile+ where+ runParser :: SourceCode -> Eff [State SourceCode, IOE] [ParsedSource] -> IO [ParsedSource]+ runParser src = runEff . evalState src++ parseFile :: (State SourceCode :> es) => Eff es [ParsedSource]+ parseFile = do+ ocs <- parseOtherCode+ aps <- parseAllConcat $ do+ cmts <- parseCommentTarget+ next <- parseOtherCode+ pure $ cmts <> next+ pure $ ocs <> aps++ parseOtherCode :: (State SourceCode :> es) => Eff es [ParsedSource]+ parseOtherCode = do+ code <- takeUntil commentTargetMarker+ case code of+ "" -> pure []+ _ -> pure [OtherCode code]++ parseAllConcat :: (State SourceCode :> es) => Eff es [a] -> Eff es [a]+ parseAllConcat parser = do+ empty <- isEmpty+ if empty+ then pure []+ else do+ as <- parser+ next <- parseAllConcat parser+ pure $ as <> next++ -- only when we know a comment target is there?+ parseCommentTarget :: (State SourceCode :> es) => Eff es [ParsedSource]+ parseCommentTarget = do+ comment <- takeIncluding commentEnd+ skipWhitespace+ skipHaddock -- skip any haddock immediately following this+ skipWhitespace+ pure [CommentTarget comment]++ isEmpty :: (State SourceCode :> es) => Eff es Bool+ isEmpty = do+ SourceCode src <- get+ pure $ T.null src++ takeUntil :: (State SourceCode :> es) => Text -> Eff es Text+ takeUntil match = do+ SourceCode input <- get+ let (before, after) = T.breakOn match input+ put $ SourceCode after+ pure before++ takeIncluding :: (State SourceCode :> es) => Text -> Eff es Text+ takeIncluding match = do+ SourceCode input <- get+ let (before, after) = T.breakOn match input+ put $ SourceCode $ T.drop (T.length match) after+ -- only add it back to the before if we had a match+ case after of+ "" -> pure before+ _ -> pure $ before <> match++ skipWhitespace :: (State SourceCode :> es) => Eff es ()+ skipWhitespace = do+ modify (\(SourceCode t) -> SourceCode $ T.stripStart t)++ skipHaddock :: (State SourceCode :> es) => Eff es ()+ skipHaddock = do+ SourceCode src <- get+ when (haddockMarker `T.isPrefixOf` src) $ do+ _ <- takeIncluding commentEnd+ pure ()+++commentTargetMarker :: Text+commentTargetMarker = "{- !"+++commentEnd :: Text+commentEnd = "-}"+++haddockMarker :: Text+haddockMarker = "{- |"++ readSource :: FilePath -> IO SourceCode readSource pth = do inp <- T.readFile pth- pure $ SourceCode $ T.lines inp+ pure $ SourceCode inp writeSource :: FilePath -> FilePath -> SourceCode -> IO ()@@ -67,40 +253,19 @@ let pth = tmpDir </> cleanRelativeDir relPath -- putStrLn $ "WRITE " <> pth <> " " <> show (length src.lines) createDirectoryIfMissing True $ takeDirectory pth- T.writeFile pth $ T.unlines src.lines+ T.writeFile pth src.contents where cleanRelativeDir = dropWhile (== '/') . dropWhile (== '.') --- relativeSourceFiles :: FilePath -> IO [FilePath]--- relativeSourceFiles dir = do--- contents <- tryDirectory dir--- let folders = filter isFolder contents--- let files = filter isSourceFile contents------ files' <- mapM (relativeSourceFiles . addDir) folders------ pure $ fmap addDir files <> mconcat files'--- where--- isSourceFile pth = takeExtension pth == ".hs"--- isFolder pth = takeExtension pth == ""--- addDir = (dir </>)--- tryDirectory pth = do--- res <- try $ listDirectory pth--- case res of--- Left (_ :: SomeException) -> do--- putStrLn $ "SKIPPED" <> pth--- pure []--- Right files -> pure files- data Macro = Embed { moduleName :: ModuleName , definition :: TopLevelDefinition } deriving (Eq)-newtype SourceCode = SourceCode {lines :: [Text]}+newtype SourceCode = SourceCode {contents :: Text} deriving newtype (Monoid, Semigroup) instance Show Macro where -- show (Example p) = "Example " <> show p@@ -115,11 +280,6 @@ deriving newtype (Show, Eq) -expandFile :: SourceCode -> IO SourceCode-expandFile (SourceCode lns) =- SourceCode . mconcat <$> mapM expandLine lns-- -- > EMBED Example/Docs/BasicPage.hs page expandLine :: Text -> IO [Text] expandLine line = do@@ -127,21 +287,11 @@ Nothing -> do pure [line] Just (pre, Embed src def) -> do- expandEmbed src pre def+ exists <- doesDirectoryExist demoDirectory+ if exists+ then expandEmbed src pre def+ else pure [] where- -- Just (pre, Example src) -> do- -- expandExample src pre-- parseMacro :: Text -> Maybe (Text, Macro)- parseMacro inp = do- parseEmbed inp -- <|> parseExample inp-- -- parseExample l = do- -- case T.splitOn "#EXAMPLE " l of- -- [prefix, src] -> do- -- pure (prefix, Example $ path src)- -- _ -> Nothing- parseEmbed l = do case T.splitOn "#EMBED " l of [prefix, info] -> do@@ -153,37 +303,27 @@ let (mn, def) = T.breakOn " " inp in pure (ModuleName mn, TopLevelDefinition $ T.drop 1 def) ---- look it up as a URI...---- * #EXAMPLE /simple+ parseMacro :: Text -> Maybe (Text, Macro)+ parseMacro inp = do+ parseEmbed inp -- <|> parseExample inp --- expandExample :: Path -> Text -> IO [Text]--- expandExample p prefix = do--- let pre = if T.null prefix then "▶️ " else prefix--- r <- appRoute--- pure [pre <> "[" <> routeTitle r <> "](" <> uriToText (exampleBaseURI ./. p) <> ")"]--- where--- appRoute :: IO AppRoute--- appRoute = do--- case matchRoute @AppRoute p of--- Nothing -> fail $ "Could not find example: " <> cs (pathToText False p)--- Just r -> pure r---- exampleBaseURI :: URI--- exampleBaseURI = [uri|https://hyperbole.live|]- modulePath :: ModuleName -> FilePath modulePath (ModuleName mn) = cs $ T.replace "." "/" mn <> ".hs" +readSourceCode :: FilePath -> IO SourceCode+readSourceCode p = do+ src <- T.readFile p+ pure $ SourceCode src++ expandEmbed :: ModuleName -> Text -> TopLevelDefinition -> IO [Text] expandEmbed mn pfx def = do let src = modulePath mn -- putStrLn $ " embed: " <> src- source <- T.readFile $ "./demo/" <> src- expanded <- requireTopLevel def (SourceCode $ T.lines source)+ source <- readSourceCode $ demoDirectory </> src+ expanded <- requireTopLevel def source pure $ fmap markupLine expanded where requireTopLevel :: TopLevelDefinition -> SourceCode -> IO [Text]@@ -258,7 +398,7 @@ -- returns lines of a top-level definition findTopLevel :: TopLevelDefinition -> SourceCode -> [Text] findTopLevel (TopLevelDefinition definition) source =- let rest = dropWhile (not . isTopLevel) source.lines+ let rest = dropWhile (not . isTopLevel) $ T.lines source.contents in dropWhileEnd isEmpty $ takeWhile isCurrentDefinition rest where isTopLevel = T.isPrefixOf definition
hyperbole.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hyperbole-version: 0.7.0+version: 0.7.1 synopsis: Interactive HTML apps using type-safe serverside Haskell description: Interactive HTML applications with type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView. category: Web, Network@@ -93,9 +93,7 @@ DataKinds DerivingStrategies DeriveAnyClass- ghc-options: -Wall -fdefer-typed-holes -F -pgmF=docgen- build-tool-depends:- hyperbole:docgen+ ghc-options: -Wall -fdefer-typed-holes build-depends: aeson >=2.1.2.1 && <2.4 , atomic-css ==0.2.*
src/Web/Hyperbole/Application.hs view
@@ -35,10 +35,17 @@ import Web.Hyperbole.Types.Response -{- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets+{- ! Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets > #EMBED Example.Docs.BasicPage main -}++{- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets++> main :: IO ()+> main = do+> run 3000 $ liveApp quickStartDocument (runPage page)+-} liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Concurrent, IOE] Response -> Wai.Application liveApp doc = liveAppWith $@@ -88,8 +95,7 @@ other -> throwIO other -{- | Route URL patterns to different pages-+{- ! Route URL patterns to different pages @ #EMBED Example.Docs.App type UserId@@ -101,6 +107,35 @@ #EMBED Example.Docs.App router #EMBED Example.Docs.App app+@+-}++{- | Route URL patterns to different pages++@+type UserId = Int++data AppRoute+ = Main+ | Messages+ | User UserId+ deriving (Eq, Generic)++instance 'Route' AppRoute where+ baseRoute = Just Main++router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'+router Messages = 'runPage' Messages.page+router (User cid) = 'runPage' $ Users.page cid+router Main = do+ pure $ view $ do+ 'el' \"click a link below to visit a page\"+ 'route' Messages \"Messages\"+ 'route' (User 1) \"User 1\"+ 'route' (User 2) \"User 2\"++app :: Application+app = 'liveApp' (document documentHead) ('routeRequest' router) @ -} routeRequest :: (Hyperbole :> es, Route route) => (route -> Eff es Response) -> Eff es Response
src/Web/Hyperbole/Data/Encoded.hs view
@@ -31,8 +31,10 @@ {- | Human Readable top-level encoding for ViewAction and ViewId For simple Sum and Product types it is equivalent to the Show/Read instance +@ MyConstructor 1 2 3 OtherConstructor "hello" 2+@ -} data Encoded = Encoded ConName [Argument] deriving (Show, Eq, Ord)
src/Web/Hyperbole/Data/QueryData.hs view
@@ -145,7 +145,7 @@ (cs prm, Just $ cs pval) -{- | Decode a type from a 'QueryData'. Missing fields are set to 'Data.Default.def'+{- ! Decode a type from a 'QueryData'. Missing fields are set to 'Data.Default.def' @ #EMBED Example.Docs.Encoding data Filters@@ -157,6 +157,23 @@ >>> parseQuery $ QueryData.parse "search=asdf" Right (Filters False "asdf") -}++{- | Decode a type from a 'QueryData'. Missing fields are set to 'Data.Default.def'++@+data Filters = Filters+ { active :: Bool+ , term :: Text+ }+ deriving (Generic, Eq, 'FromQuery', 'ToQuery')+@++>>> parseQuery $ QueryData.parse "active=true&search=asdf"+Right (Filters True "asdf")++>>> parseQuery $ QueryData.parse "search=asdf"+Right (Filters False "asdf")+-} class FromQuery a where parseQuery :: QueryData -> Either String a default parseQuery :: (Generic a, GFromQuery (Rep a)) => QueryData -> Either String a@@ -167,10 +184,32 @@ 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+{- ! 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 data Filters+@++>>> QueryData.render $ toQuery $ Filter True "asdf"+"active=true&search=asdf"++If the value of a field is the same as 'Default', it will be omitted from the query string++>>> QueryData.render $ toQuery $ Filter True ""+"active=true"++>>> QueryData.render $ toQuery $ Filter False ""+""+-}++{- | A page can store state in the browser 'query' string. ToQuery and 'FromQuery' control how a datatype is encoded to a full query string++@+data Filters = Filters+ { active :: Bool+ , term :: Text+ }+ deriving (Generic, Eq, 'FromQuery', 'ToQuery') @ >>> QueryData.render $ toQuery $ Filter True "asdf"
src/Web/Hyperbole/Document.hs view
@@ -11,10 +11,16 @@ data Document = Document -{- | 'liveApp' requires a function which turns an html fragment into an entire html document. Use this to import javascript, css, etc. Use 'quickStartDocument' to get going quickly+{- ! 'liveApp' requires a function which turns an html fragment into an entire html document. Use this to import javascript, css, etc. Use 'quickStartDocument' to get going quickly > #EMBED Example.Docs.App app -}++{- | 'liveApp' requires a function which turns an html fragment into an entire html document. Use this to import javascript, css, etc. Use 'quickStartDocument' to get going quickly++> app :: Application+> app = liveApp (document documentHead) (routeRequest router)+-} document :: View DocumentHead () -> BL.ByteString -> BL.ByteString document docHead cnt = [i|<!doctype html>@@ -29,13 +35,28 @@ </html>|] -{- | Create a custom \<head\> to use with 'document'. Remember to include at least `scriptEmbed`!+{- ! Create a custom \<head\> to use with 'document'. Remember to include at least `scriptEmbed`! > import Web.Hyperbole (scriptEmbed, cssEmbed) > > #EMBED Example.Docs.App documentHead > > #EMBED Example.Docs.App app+-}++{- | Create a custom \<head\> to use with 'document'. Remember to include at least `scriptEmbed`!++> import Web.Hyperbole (scriptEmbed, cssEmbed)+>+> documentHead :: View DocumentHead ()+> documentHead = do+> title "My Website"+> script' scriptEmbed+> style cssEmbed+> script "custom.js"+>+> app :: Application+> app = liveApp (document documentHead) (routeRequest router) -} data DocumentHead = DocumentHead deriving (Generic, ViewId)
src/Web/Hyperbole/Effect/Client.hs view
@@ -12,18 +12,33 @@ import Web.Hyperbole.View (toAction, toViewId) -{- | Trigger an action for an arbitrary 'HyperView'+{- ! Trigger an action for an arbitrary 'HyperView' @ #EMBED Example.Trigger instance HyperView Controls @ -}++{- | Trigger an action for an arbitrary 'HyperView'++@+instance 'HyperView' Controls es where+ type Require Controls = '[Targeted]++ data 'Action' Controls = TriggerMessage+ deriving (Generic, 'ViewAction')++ 'update' TriggerMessage = do+ trigger Targeted $ SetMessage \"Triggered!\"+ pure controlView+@+-} trigger :: (HyperView id es, HyperViewHandled id view, Hyperbole :> es) => id -> Action id -> Eff (Reader view : es) () trigger vid act = do send $ PushTrigger (TargetViewId $ toViewId vid) (toAction act) -{- | Dispatch a custom javascript event. This is emitted on the current hyper view and bubbles up to the document+{- ! Dispatch a custom javascript event. This is emitted on the current hyper view and bubbles up to the document @ #EMBED Example.Javascript instance HyperView Message@@ -38,15 +53,47 @@ } @ -}++{- | Dispatch a custom javascript event. This is emitted on the current hyper view and bubbles up to the document++@+instance 'HyperView' Message es where+ data 'Action' Message = AlertMe+ deriving (Generic, 'ViewAction')++ 'update' AlertMe = do+ pushEvent \"server-message\" (\"hello\" :: Text)+ pure \"Sent 'server-message' event\"+@++@+function listenServerEvents() {+ // you can listen on document instead, the event will bubble+ Hyperbole.hyperView("Message").addEventListener("server-message", function(e) {+ alert("Server Message: " + e.detail)+ })+}+@+-} pushEvent :: (ToJSON a, Hyperbole :> es) => Text -> a -> Eff es () pushEvent nm a = do send $ PushEvent nm (toJSON a) -{- | Set the document title+{- ! Set the document title @ #EMBED Example.Docs.Client page+@+-}++{- | Set the document title++@+page :: ('Hyperbole' :> es) => 'Page' es '[]+page = do+ pageTitle \"My 'Page' Title\"+ pure $ 'el' \"Hello World\" @ -} pageTitle :: (Hyperbole :> es) => Text -> Eff es ()
src/Web/Hyperbole/Effect/Query.hs view
@@ -16,7 +16,7 @@ import Prelude -{- | Parse querystring from the 'Request' into a datatype. See 'FromQuery'+{- ! Parse querystring from the 'Request' into a datatype. See 'FromQuery' @ #EMBED Example.Docs.Params data Filters@@ -24,6 +24,23 @@ #EMBED Example.Docs.Params page @ -}++{- | Parse querystring from the 'Request' into a datatype. See 'FromQuery'++@+data Filters = Filters+ { search :: Text+ }+ deriving ('ToQuery', 'FromQuery', Generic)++page :: ('Hyperbole' :> es) => 'Page' es '[Todos]+page = do+ filters <- query @Filters+ todos <- loadTodos filters+ pure $ do+ 'hyper' Todos $ todosView todos+@+-} query :: (FromQuery a, Hyperbole :> es) => Eff es a query = do q <- queryParams@@ -32,12 +49,28 @@ Right a -> pure a -{- | Update the client's querystring to an encoded datatype. See 'ToQuery'+{- ! Update the client's querystring to an encoded datatype. See 'ToQuery' @ #EMBED Example.Docs.Params instance HyperView Todos @ -}++{- | Update the client's querystring to an encoded datatype. See 'ToQuery'++@+instance 'HyperView' Todos es where+ data 'Action' Todos+ = SetSearch Text+ deriving (Generic, 'ViewAction')++ 'update' (SetSearch term) = do+ let filters = Filters term+ setQuery filters+ todos <- loadTodos filters+ pure $ todosView todos+@+-} setQuery :: (ToQuery a, Hyperbole :> es) => a -> Eff es () setQuery a = do modifyQueryData (const $ toQuery a)@@ -56,12 +89,23 @@ setQuery (mempty :: QueryData) -{- | Parse a single query parameter. Return a 400 status if missing or if parsing fails. See 'decodeParam'+{- ! Parse a single query parameter. Return a 400 status if missing or if parsing fails. See 'decodeParam' @ #EMBED Example.Docs.Params page' @ -}++{- | Parse a single query parameter. Return a 400 status if missing or if parsing fails. See 'decodeParam'++@+page' :: ('Hyperbole' :> es) => 'Page' es '[Message]+page' = do+ msg <- param \"message\"+ pure $ do+ 'hyper' Message $ messageView msg+@+-} param :: (FromJSON a, Hyperbole :> es) => Param -> Eff es a param p = do q <- queryParams@@ -70,22 +114,44 @@ Right a -> pure a -{- | Parse a single parameter from the query string if available-+{- ! Parse a single parameter from the query string if available @ #EMBED Example.Docs.SideEffects page @ -}++{- | Parse a single parameter from the query string if available++@+page :: ('Hyperbole' :> es, Concurrent :> es, Reader Text :> es) => 'Page' es '[SlowReader]+page = do+ pure $ 'hyper' SlowReader $ messageView \"...\"+@+-} lookupParam :: (FromJSON 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 'encodeParam'+{- ! Modify the client's querystring to set a single parameter. See 'encodeParam' @ #EMBED Example.Docs.Params instance HyperView Message+@+-}++{- | Modify the client's querystring to set a single parameter. See 'encodeParam'++@+instance 'HyperView' Message es where+ data 'Action' Message+ = SetMessage Text+ deriving (Generic, 'ViewAction')++ 'update' (SetMessage msg) = do+ 'setParam' \"message\" msg+ pure $ messageView msg @ -} setParam :: (ToJSON a, Hyperbole :> es) => Param -> a -> Eff es ()
src/Web/Hyperbole/Effect/Response.hs view
@@ -45,12 +45,29 @@ send $ RespondNow $ Err $ ErrCustom $ ServerError msg $ renderBody vw -{- | Abort execution and respond with 404 Not Found+{- ! Abort execution and respond with 404 Not Found @ #EMBED Example.Docs.App findUser #EMBED Example.Docs.App userPage+@+-}++{- | Abort execution and respond with 404 Not Found++@+findUser :: ('Hyperbole' :> es, Users :> es) => Int -> 'Eff' es User+findUser uid = do+ mu <- send (LoadUser uid)+ maybe notFound pure mu++userPage :: ('Hyperbole' :> es, Users :> es) => 'Page' es '[]+userPage = do+ user <- findUser 100++ -- skipped if user not found+ pure $ userView user @ -} notFound :: (Hyperbole :> es) => Eff es a
src/Web/Hyperbole/Effect/Session.hs view
@@ -20,7 +20,7 @@ import Web.Hyperbole.Types.Response -{- | Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session+{- ! Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session @ #EMBED Example.Docs.Sessions data Preferences@@ -28,6 +28,19 @@ #EMBED Example.Docs.Sessions instance Default Preferences @ -}++{- | Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session++@+data Preferences = Preferences+ { color :: AppColor+ }+ deriving (Generic, ToJSON, FromJSON, 'Session')++instance Default Preferences where+ def = Preferences White+@+-} class Session a where -- | Unique key for this Session Type. Defaults to the datatypeName sessionKey :: Key@@ -60,7 +73,7 @@ A.eitherDecode (cs bs) -{- | Load data from a browser cookie. If it doesn't exist, the 'Default' instance is used+{- ! Load data from a browser cookie. If it doesn't exist, the 'Default' instance is used @ #EMBED Example.Docs.Sessions data Preferences@@ -70,6 +83,24 @@ #EMBED Example.Docs.Sessions page @ -}++{- | Load data from a browser cookie. If it doesn't exist, the 'Default' instance is used++@+data Preferences = Preferences+ { color :: AppColor+ }+ deriving (Generic, ToJSON, FromJSON, 'Session')++instance Default Preferences where+ def = Preferences White++page :: ('Hyperbole' :> es) => 'Page' es '[Content]+page = do+ prefs <- session @Preferences+ pure $ 'el' ~ bg prefs.color $ \"Custom Background\"+@+-} session :: (Session a, Default a, Hyperbole :> es) => Eff es a session = do ms <- lookupSession@@ -89,7 +120,7 @@ Right a -> pure $ Just a -{- | Persist datatypes in browser cookies+{- ! Persist datatypes in browser cookies @ #EMBED Example.Docs.Sessions data Preferences@@ -97,6 +128,29 @@ #EMBED Example.Docs.Sessions instance Default Preferences #EMBED Example.Docs.Sessions instance HyperView Content+@+-}++{- | Persist datatypes in browser cookies++@+data Preferences = Preferences+ { color :: AppColor+ }+ deriving (Generic, ToJSON, FromJSON, 'Session')++instance Default Preferences where+ def = Preferences White++instance 'HyperView' Content es where+ data 'Action' Content+ = SetColor AppColor+ deriving (Generic, 'ViewAction')++ 'update' (SetColor clr) = do+ let prefs = Preferences clr+ saveSession prefs+ pure $ 'el' ~ bg prefs.color $ \"Custom Background\" @ -} saveSession :: forall a es. (Session a, Hyperbole :> es) => a -> Eff es ()
src/Web/Hyperbole/HyperView/Event.hs view
@@ -21,12 +21,23 @@ eventName t = "data-on" <> t -{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling.+{- ! Send the action after N milliseconds. Can be used to implement lazy loading or polling. @ #EMBED Example.Concurrency.LazyLoading viewTaskLoad @ -}++{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling.++@+viewTaskLoad :: 'View' LazyData ()+viewTaskLoad = do+ -- 100ms after rendering, get the details+ 'el' @ onLoad Details 100 ~ bg GrayLight . textAlign AlignCenter $ do+ text \"...\"+@+-} onLoad :: (ViewAction (Action id), Attributable a) => Action id -> DelayMs -> Attributes a -> Attributes a onLoad a delay = do event "load" a . att "data-delay" (cs $ show delay)@@ -52,7 +63,7 @@ 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+> input @ (onInput Search 250) -} onInput :: (ViewAction (Action id), Attributable a) => Action id -> DelayMs -> Attributes a -> Attributes a onInput a delay = do@@ -109,10 +120,20 @@ dataTarget = att "data-target" . encodedToText . toViewId -{- | Allow inputs to trigger actions for a different view+{- ! Allow inputs to trigger actions for a different view @ #EMBED Example.Trigger targetView+@+-}++{- | Allow inputs to trigger actions for a different view++@+targetView :: 'View' Controls ()+targetView = do+ target Targeted () $ do+ 'button' (SetMessage \"Targeted!\") ~ btn $ \"Target SetMessage\" @ -} target :: forall id ctx. (HyperViewHandled id ctx, ViewId id) => id -> ViewState id -> View id () -> View ctx ()
src/Web/Hyperbole/HyperView/Forms.hs view
@@ -76,24 +76,51 @@ type ParamKey = BS.ByteString -{- | Simple types that be decoded from form data+{- ! Simple types that be decoded from form data @ #EMBED Example.FormSimple data ContactForm @ -}++{- | Simple types that be decoded from form data++@+data ContactForm = ContactForm+ { name :: Text+ , age :: Int+ , isFavorite :: Bool+ , planet :: Planet+ , moon :: Moon+ }+ deriving (Generic, FromForm)+@+-} class FromForm (form :: Type) where fromForm :: Form -> Either String form default fromForm :: (Generic form, GFormParse (Rep form)) => Form -> Either String form fromForm f = to <$> gFormParse f -{- | A Higher-Kinded type that can be parsed from a 'Form'+{- ! A Higher-Kinded type that can be parsed from a 'Form' @ #EMBED Example.FormValidation data UserForm @ -}++{- | A Higher-Kinded type that can be parsed from a 'Form'++@+data UserForm f = UserForm+ { user :: Field f User+ , age :: Field f Int+ , pass1 :: Field f Text+ , pass2 :: Field f Text+ }+ deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)+@+-} class FromFormF (f :: (Type -> Type) -> Type) where fromFormF :: Form -> Either String (f Identity) default fromFormF :: (Generic (f Identity), GFormParse (Rep (f Identity))) => Form -> Either String (f Identity)@@ -133,7 +160,7 @@ -- GEN FIELDS: Generate a type from selector names ------------------------------------------------------------------------------ -{- | Generate a Higher Kinded record with all selectors filled with default values. See 'GenField'+{- ! Generate a Higher Kinded record with all selectors filled with default values. See 'GenField' @ #EMBED Example.FormValidation data UserForm@@ -143,18 +170,60 @@ #EMBED Example.Contacts newContactForm @ -}++{- | Generate a Higher Kinded record with all selectors filled with default values. See 'GenField'++@+data UserForm f = UserForm+ { user :: Field f User+ , age :: Field f Int+ , pass1 :: Field f Text+ , pass2 :: Field f Text+ }+ deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)+@++@+newContactForm :: 'View' NewContact ()+newContactForm = do+ row ~ pad 10 . gap 10 . border 1 $ do+ target Contacts () $ do+ contactForm AddUser (genFields :: ContactForm Maybe)+ col $ do+ space+ 'button' CloseForm ~ btnLight $ \"Cancel\"+@+-} class GenFields f (form :: (Type -> Type) -> Type) where genFields :: form f default genFields :: (Generic (form f), GFieldsGen (Rep (form f))) => form f genFields = to gFieldsGen -{- | Generate FieldNames for a form+{- ! Generate FieldNames for a form > #EMBED Example.Todos.Todo data TodoForm > > #EMBED Example.Todos.Todo todoForm -}++{- | Generate FieldNames for a form++> data TodoForm f = TodoForm+> { task :: Field f Text+> }+> deriving (Generic, FromFormF, GenFields FieldName)+>+> todoForm :: FilterTodo -> View AllTodos ()+> todoForm filt = do+> let f :: TodoForm FieldName = fieldNames+> row ~ border 1 $ do+> el ~ pad 8 $ do+> button (ToggleAll filt) Icon.chevronDown ~ width 32 . hover (color Primary)+> form SubmitTodo ~ grow $ do+> field f.task $ do+> input TextInput ~ pad 12 @ placeholder "What needs to be done?" . value ""+-} fieldNames :: forall form. (GenFields FieldName form) => form FieldName fieldNames = genFields @@ -186,12 +255,64 @@ deriving newtype (ViewId) -{- | Type-safe \<form\>. Calls (Action id) on submit+{- ! Type-safe \<form\>. Calls (Action id) on submit @ #EMBED Example.FormSimple formView @ -}++{- | Type-safe \<form\>. Calls (Action id) on submit++@+formView :: 'View' AddContact ()+formView = do+ form Submit ~ gap 15 . pad 10 . flexCol $ do+ 'el' ~ Style.h1 $ \"Add Contact\"++ -- Make sure these names match the field names used by FormParse / formData+ field \"name\" $ do+ label $ do+ text \"Contact Name\"+ input Username @ placeholder \"contact name\" ~ Style.input++ field \"age\" $ do+ label $ do+ text \"Age\"+ input Number @ placeholder \"age\" . value \"0\" ~ Style.input++ field \"isFavorite\" $ do+ label $ do+ row ~ gap 10 $ do+ checkbox False ~ width 32+ text \"Favorite?\"++ col ~ gap 5 $ do+ 'el' $ text \"Planet\"+ field \"planet\" $ do+ radioGroup Earth $ do+ planet Mercury+ planet Venus+ planet Earth+ planet Mars++ field \"moon\" $ do+ label $ do+ text \"Moon\"+ select Callisto ~ Style.input $ do+ option Titan \"Titan\"+ option Europa \"Europa\"+ option Callisto \"Callisto\"+ option Mimas \"Mimas\"++ submit \"Submit\" ~ btn+ where+ planet val =+ label ~ flexRow . gap 10 $ do+ radio val ~ width 32+ text (pack (show val))+@+-} form :: (ViewAction (Action id)) => Action id -> View (FormFields id) () -> View id () form a cnt = do tag "form" @ onSubmit a $ do@@ -331,7 +452,7 @@ -- VALIDATION ------------------------------------------------------------------------------ -{- | Validation results for a 'Form'. See 'validate'+{- ! Validation results for a 'Form'. See 'validate' @ #EMBED Example.FormValidation data UserForm@@ -341,6 +462,32 @@ #EMBED Example.FormValidation validateAge @ -}++{- | Validation results for a 'Form'. See 'validate'++@+data UserForm f = UserForm+ { user :: Field f User+ , age :: Field f Int+ , pass1 :: Field f Text+ , pass2 :: Field f Text+ }+ deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName)++validateForm :: UserForm Identity -> UserForm Validated+validateForm u =+ UserForm+ { user = validateUser u.user+ , age = validateAge u.age+ , pass1 = validatePass u.pass1 u.pass2+ , pass2 = NotInvalid+ }++validateAge :: Int -> Validated Int+validateAge a =+ validate (a < 20) \"User must be at least 20 years old\"+@+-} data Validated a = Invalid Text | NotInvalid | Valid deriving (Show) @@ -395,10 +542,19 @@ _ -> none -{- | specify a check for a 'Validation'+{- ! specify a check for a 'Validation' @ #EMBED Example.FormValidation validateAge+@+-}++{- | specify a check for a 'Validation'++@+validateAge :: Int -> Validated Int+validateAge a =+ validate (a < 20) \"User must be at least 20 years old\" @ -} validate :: Bool -> Text -> Validated a
src/Web/Hyperbole/HyperView/Hyper.hs view
@@ -13,12 +13,24 @@ import Web.Hyperbole.View.ViewId -{- | Embed a 'HyperView' into a page or another 'View'+{- ! Embed a 'HyperView' into a page or another 'View' @ #EMBED Example.Docs.Interactive page @ -}++{- | Embed a 'HyperView' into a page or another 'View'++@+page :: 'Page' es '[Message]+page = do+ pure $ do+ 'el' \"Unchanging Header\"+ 'hyper' Message1 $ messageView \"Hello\"+ 'hyper' Message2 $ messageView \"World\"+@+-} hyper :: forall id ctx . (HyperViewHandled id ctx, ViewId id, ViewState id ~ (), ConcurrencyValue (Concurrency id))@@ -28,10 +40,20 @@ hyper vid = hyperState vid () -{- | Embed a 'HyperView' into a page or another 'View' with a starting 'ViewState'+{- ! Embed a 'HyperView' into a page or another 'View' with a starting 'ViewState' @ #EMBED Example.State.ViewState page+@+-}++{- | Embed a 'HyperView' into a page or another 'View' with a starting 'ViewState'++@+page :: ('Hyperbole' :> es) => 'Page' es '[Counter]+page = do+ pure $ do+ hyperState CounterState 10 viewCount @ -} hyperState
src/Web/Hyperbole/HyperView/Input.hs view
@@ -15,23 +15,44 @@ import Web.Hyperbole.View -{- | \<button\> HTML tag which sends the action when pressed+{- ! \<button\> HTML tag which sends the action when pressed @ #EMBED Example.Simple messageView @ -}++{- | \<button\> HTML tag which sends the action when pressed++@+messageView :: Text -> 'View' Message ()+messageView msg = do+ 'button' (Louder msg) ~ border 1 $ text msg+@+-} button :: (ViewAction (Action id)) => Action id -> View id () -> View id () button action cnt = do tag "button" cnt @ onClick action -{- | Type-safe dropdown. Sends (opt -> Action id) when selected. The default will be selected.+{- ! Type-safe dropdown. Sends the action when selected. The default will be selected on load. @ #EMBED Example.DataLists.Filter familyDropdown @ -}++{- | Type-safe dropdown. Sends the action when selected. The default will be selected on load.++@+familyDropdown :: Filters -> 'View' Languages ()+familyDropdown filters =+ dropdown SetFamily filters.family ~ border 1 . pad 10 $ do+ option Nothing \"Any\"+ option (Just ObjectOriented) \"Object Oriented\"+ option (Just Functional) \"Functional\"+@+-} dropdown :: forall opt id . (ViewAction (Action id), FromJSON opt)@@ -83,10 +104,20 @@ type ViewState (Option id opt) = ViewState id -{- | A live search field. Set a DelayMs to avoid hitting the server on every keystroke+{- ! A live search field. Set a DelayMs to avoid hitting the server on every keystroke @ #EMBED Example.Errors viewSearchUsers+@+-}++{- | A live search field. Set a DelayMs to avoid hitting the server on every keystroke++@+viewSearchUsers :: 'View' Users ()+viewSearchUsers = do+ 'el' \"Search for a user by id\"+ search SearchUser 250 ~ border 1 . pad 10 @ placeholder \"2\" @ -} search :: (ViewAction (Action id)) => Action id -> DelayMs -> View id ()
src/Web/Hyperbole/HyperView/Types.hs view
@@ -16,7 +16,7 @@ -- HyperView -------------------------------------------- -{- | HyperViews are interactive subsections of a 'Page'+{- ! HyperViews are interactive subsections of a 'Page' 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) @@ -24,6 +24,25 @@ #EMBED Example.Simple data Message #EMBED Example.Simple instance HyperView Message es where+@+-}++{- | HyperViews are interactive subsections of a 'Page'++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 = Message1 | Message2+ deriving (Generic, 'ViewId')++instance 'HyperView' Message es where+ data 'Action' Message+ = Louder Text+ deriving (Generic, 'ViewAction')++ 'update' (Louder msg) = do+ let new = msg <> \"!\"+ pure $ messageView new @ -} class (ViewId id, ViewAction (Action id), ConcurrencyValue (Concurrency id)) => HyperView id es where
src/Web/Hyperbole/Page.hs view
@@ -10,21 +10,46 @@ import Web.Hyperbole.View (View) -{- | An application is divided into multiple [Pages](#g:pages). Each page module should have a 'Page' function, which returns a root 'View'+{- ! An application is divided into multiple [Pages](#g:pages). Each page module should have a 'Page' function, which returns a root 'View' @ #EMBED Example.Docs.MultiView page @ -}++{- | An application is divided into multiple [Pages](#g:pages). Each page module should have a 'Page' function, which returns a root 'View'++@+page :: 'Page' es [Message, Counter]+page = do+ pure $ do+ 'hyper' Message1 $ messageView \"Hello\"+ 'hyper' Message2 $ messageView \"World\"+ 'hyper' Counter $ viewCount 0+@+-} type Page es (views :: [Type]) = Eff (Reader (Root views) : es) (View (Root views) ()) -{- | Run a 'Page' and return a 'Response'+{- ! Run a 'Page' and return a 'Response' @ #EMBED Example.Docs.BasicPage main #EMBED Example.Docs.BasicPage page+@+-}++{- | Run a 'Page' and return a 'Response'++@+main :: IO ()+main = do+ 'run' 3000 $ 'liveApp' 'quickStartDocument' ('runPage' page)++page :: 'Page' es '[]+page = do+ pure $ 'el' \"Hello World\" @ -} runPage
src/Web/Hyperbole/Route.hs view
@@ -23,12 +23,32 @@ import Prelude hiding (dropWhile) -{- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns+{- ! Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns @ #EMBED Example.Docs.App data AppRoute #EMBED Example.Docs.App instance Route+@++>>> routeUri Main+/++>>> routeUri (User 9)+/user/9+-}++{- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns++@+data AppRoute+ = Main+ | Messages+ | User UserId+ deriving (Eq, Generic)++instance 'Route' AppRoute where+ baseRoute = Just Main @ >>> routeUri Main
src/Web/Hyperbole/View/CSS.hs view
@@ -3,10 +3,20 @@ import Web.Atomic.CSS -{- | Apply CSS only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1)+{- ! Apply CSS only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1) @ #EMBED Example.Contact contactEditView+@+-}++{- | Apply CSS only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1)++@+contactEditView :: User -> 'View' Contact ()+contactEditView u = do+ 'el' contactLoading ~ display None . whenLoading flexCol+ 'el' (contactEdit ViewContact Save u) ~ whenLoading (display None) @ -} whenLoading :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h
src/Web/Hyperbole/View/Embed.hs view
@@ -13,6 +13,7 @@ import Web.Atomic.CSS.Reset qualified as Atomic +-- | Required Javascript for Hyperbole to work. Remember to include it in your 'document'. It is included in the `quickStart`s scriptEmbed :: ByteString scriptEmbed = $(embedFile "client/dist/hyperbole.js")
src/Web/Hyperbole/View/Types.hs view
@@ -19,12 +19,21 @@ -- View ------------------------------------------------------------ -{- | 'View's are HTML fragments with a 'context'+{- ! 'View's are HTML fragments with a 'context' @ #EMBED Example.Docs.BasicPage helloWorld @ -}++{- | 'View's are HTML fragments with a 'context'++@+helloWorld :: 'View' context ()+helloWorld =+ 'el' \"Hello World\"+@+-} newtype View c a = View {html :: Eff '[Reader (c, ViewState c)] (Html a)} @@ -117,12 +126,30 @@ pure $ modCSS f h -{- | Access the 'viewId' in a 'View' or 'update'+{- ! Access the 'viewId' in a 'View' or 'update' @ #EMBED Example.Concurrency.LazyLoading data LazyData #EMBED Example.Concurrency.LazyLoading instance (Debug :> es, GenRandom :> es) => HyperView LazyData es where+@+-}++{- | Access the 'viewId' in a 'View' or 'update'++@+data LazyData = LazyData TaskId+ deriving (Generic, 'ViewId')++instance (Debug :> es, GenRandom :> es) => 'HyperView' LazyData es where+ data 'Action' LazyData+ = Details+ deriving (Generic, 'ViewAction')++ 'update' Details = do+ LazyData taskId <- 'viewId'+ task <- pretendLoadTask taskId+ pure $ viewTaskDetails task @ -} class HasViewId m view where
src/Web/Hyperbole/View/ViewAction.hs view
@@ -7,10 +7,24 @@ import Web.Hyperbole.Data.Encoded as Encoded -{- | Define every action possible for a given 'HyperView'+{- ! Define every action possible for a given 'HyperView' @ #EMBED Example.Simple instance HyperView Message+@+-}++{- | Define every action possible for a given 'HyperView'++@+instance 'HyperView' Message es where+ data 'Action' Message+ = Louder Text+ deriving (Generic, 'ViewAction')++ 'update' (Louder msg) = do+ let new = msg <> \"!\"+ pure $ messageView new @ -} class ViewAction a where
src/Web/Hyperbole/View/ViewId.hs view
@@ -7,10 +7,18 @@ import Web.Hyperbole.Data.Encoded as Encoded -{- | A unique identifier for a 'HyperView'+{- ! A unique identifier for a 'HyperView' @ #EMBED Example.Simple data Message+@+-}++{- | A unique identifier for a 'HyperView'++@+data Message = Message1 | Message2+ deriving (Generic, 'ViewId') @ -} class ViewId a where