diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/client/dist/hyperbole.js b/client/dist/hyperbole.js --- a/client/dist/hyperbole.js +++ b/client/dist/hyperbole.js @@ -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=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{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;eLe(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{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;eLe(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 diff --git a/docs/Docgen.hs b/docs/Docgen.hs --- a/docs/Docgen.hs +++ b/docs/Docgen.hs @@ -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 diff --git a/hyperbole.cabal b/hyperbole.cabal --- a/hyperbole.cabal +++ b/hyperbole.cabal @@ -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.* diff --git a/src/Web/Hyperbole/Application.hs b/src/Web/Hyperbole/Application.hs --- a/src/Web/Hyperbole/Application.hs +++ b/src/Web/Hyperbole/Application.hs @@ -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 diff --git a/src/Web/Hyperbole/Data/Encoded.hs b/src/Web/Hyperbole/Data/Encoded.hs --- a/src/Web/Hyperbole/Data/Encoded.hs +++ b/src/Web/Hyperbole/Data/Encoded.hs @@ -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) diff --git a/src/Web/Hyperbole/Data/QueryData.hs b/src/Web/Hyperbole/Data/QueryData.hs --- a/src/Web/Hyperbole/Data/QueryData.hs +++ b/src/Web/Hyperbole/Data/QueryData.hs @@ -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" diff --git a/src/Web/Hyperbole/Document.hs b/src/Web/Hyperbole/Document.hs --- a/src/Web/Hyperbole/Document.hs +++ b/src/Web/Hyperbole/Document.hs @@ -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| @@ -29,13 +35,28 @@ |] -{- | Create a custom \ to use with 'document'. Remember to include at least `scriptEmbed`! +{- ! Create a custom \ 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 \ 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) diff --git a/src/Web/Hyperbole/Effect/Client.hs b/src/Web/Hyperbole/Effect/Client.hs --- a/src/Web/Hyperbole/Effect/Client.hs +++ b/src/Web/Hyperbole/Effect/Client.hs @@ -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 () diff --git a/src/Web/Hyperbole/Effect/Query.hs b/src/Web/Hyperbole/Effect/Query.hs --- a/src/Web/Hyperbole/Effect/Query.hs +++ b/src/Web/Hyperbole/Effect/Query.hs @@ -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 () diff --git a/src/Web/Hyperbole/Effect/Response.hs b/src/Web/Hyperbole/Effect/Response.hs --- a/src/Web/Hyperbole/Effect/Response.hs +++ b/src/Web/Hyperbole/Effect/Response.hs @@ -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 diff --git a/src/Web/Hyperbole/Effect/Session.hs b/src/Web/Hyperbole/Effect/Session.hs --- a/src/Web/Hyperbole/Effect/Session.hs +++ b/src/Web/Hyperbole/Effect/Session.hs @@ -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 () diff --git a/src/Web/Hyperbole/HyperView/Event.hs b/src/Web/Hyperbole/HyperView/Event.hs --- a/src/Web/Hyperbole/HyperView/Event.hs +++ b/src/Web/Hyperbole/HyperView/Event.hs @@ -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 () diff --git a/src/Web/Hyperbole/HyperView/Forms.hs b/src/Web/Hyperbole/HyperView/Forms.hs --- a/src/Web/Hyperbole/HyperView/Forms.hs +++ b/src/Web/Hyperbole/HyperView/Forms.hs @@ -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 \. Calls (Action id) on submit +{- ! Type-safe \. Calls (Action id) on submit @ #EMBED Example.FormSimple formView @ -} + +{- | Type-safe \. 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 diff --git a/src/Web/Hyperbole/HyperView/Hyper.hs b/src/Web/Hyperbole/HyperView/Hyper.hs --- a/src/Web/Hyperbole/HyperView/Hyper.hs +++ b/src/Web/Hyperbole/HyperView/Hyper.hs @@ -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 diff --git a/src/Web/Hyperbole/HyperView/Input.hs b/src/Web/Hyperbole/HyperView/Input.hs --- a/src/Web/Hyperbole/HyperView/Input.hs +++ b/src/Web/Hyperbole/HyperView/Input.hs @@ -15,23 +15,44 @@ import Web.Hyperbole.View -{- | \ HTML tag which sends the action when pressed +{- ! \ HTML tag which sends the action when pressed @ #EMBED Example.Simple messageView @ -} + +{- | \ 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 () diff --git a/src/Web/Hyperbole/HyperView/Types.hs b/src/Web/Hyperbole/HyperView/Types.hs --- a/src/Web/Hyperbole/HyperView/Types.hs +++ b/src/Web/Hyperbole/HyperView/Types.hs @@ -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 diff --git a/src/Web/Hyperbole/Page.hs b/src/Web/Hyperbole/Page.hs --- a/src/Web/Hyperbole/Page.hs +++ b/src/Web/Hyperbole/Page.hs @@ -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 diff --git a/src/Web/Hyperbole/Route.hs b/src/Web/Hyperbole/Route.hs --- a/src/Web/Hyperbole/Route.hs +++ b/src/Web/Hyperbole/Route.hs @@ -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 diff --git a/src/Web/Hyperbole/View/CSS.hs b/src/Web/Hyperbole/View/CSS.hs --- a/src/Web/Hyperbole/View/CSS.hs +++ b/src/Web/Hyperbole/View/CSS.hs @@ -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 diff --git a/src/Web/Hyperbole/View/Embed.hs b/src/Web/Hyperbole/View/Embed.hs --- a/src/Web/Hyperbole/View/Embed.hs +++ b/src/Web/Hyperbole/View/Embed.hs @@ -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") diff --git a/src/Web/Hyperbole/View/Types.hs b/src/Web/Hyperbole/View/Types.hs --- a/src/Web/Hyperbole/View/Types.hs +++ b/src/Web/Hyperbole/View/Types.hs @@ -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 diff --git a/src/Web/Hyperbole/View/ViewAction.hs b/src/Web/Hyperbole/View/ViewAction.hs --- a/src/Web/Hyperbole/View/ViewAction.hs +++ b/src/Web/Hyperbole/View/ViewAction.hs @@ -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 diff --git a/src/Web/Hyperbole/View/ViewId.hs b/src/Web/Hyperbole/View/ViewId.hs --- a/src/Web/Hyperbole/View/ViewId.hs +++ b/src/Web/Hyperbole/View/ViewId.hs @@ -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