Repository: seanhess/hyperbole Branch: main Commit: d1ea5d43346f Files: 254 Total size: 539.1 KB Directory structure: gitextract_46835c3y/ ├── .dockerignore ├── .github/ │ └── workflows/ │ ├── haskell.yaml │ └── packcheck.yaml ├── .gitignore ├── .hlint.yaml ├── .packcheck.ignore ├── CHANGELOG.md ├── DOCTODO.md ├── Dockerfile ├── LICENSE ├── README.md ├── bin/ │ ├── dev │ ├── docgen │ └── release ├── cabal.project ├── client/ │ ├── declarations.d.ts │ ├── dist/ │ │ ├── action.d.ts │ │ ├── browser.d.ts │ │ ├── events.d.ts │ │ ├── http.d.ts │ │ ├── hyperbole.js │ │ ├── hyperview.d.ts │ │ ├── index.d.ts │ │ ├── lib.d.ts │ │ ├── message.d.ts │ │ ├── response.d.ts │ │ └── sockets.d.ts │ ├── package.json │ ├── src/ │ │ ├── action.ts │ │ ├── browser.ts │ │ ├── events.ts │ │ ├── http.ts │ │ ├── hyperview.ts │ │ ├── index.ts │ │ ├── lib.ts │ │ ├── message.ts │ │ ├── response.ts │ │ └── sockets.ts │ ├── tsconfig.json │ ├── util/ │ │ └── live-reload.js │ └── webpack.config.js ├── demo/ │ ├── .dockerignore │ ├── App/ │ │ ├── Cache.hs │ │ ├── Config.hs │ │ ├── Docs/ │ │ │ ├── Markdown.hs │ │ │ ├── Page.hs │ │ │ └── Snippet.hs │ │ ├── Docs.hs │ │ ├── Page/ │ │ │ ├── Application.hs │ │ │ ├── CSS.hs │ │ │ ├── Concurrency.hs │ │ │ ├── Examples.hs │ │ │ ├── Forms.hs │ │ │ ├── HyperboleEffect.hs │ │ │ ├── Hyperviews.hs │ │ │ ├── Interactivity.hs │ │ │ ├── Intro/ │ │ │ │ ├── Basics.hs │ │ │ │ └── Intro.hs │ │ │ ├── OAuth2.hs │ │ │ ├── SideEffects.hs │ │ │ ├── State.hs │ │ │ └── ViewFunctions.hs │ │ ├── Route.hs │ │ └── Style.hs │ ├── App.hs │ ├── Example/ │ │ ├── CSS/ │ │ │ ├── External.hs │ │ │ ├── Loading.hs │ │ │ ├── Tooltips.hs │ │ │ └── Transitions.hs │ │ ├── Chat.hs │ │ ├── Colors.hs │ │ ├── Concurrency/ │ │ │ ├── LazyLoading.hs │ │ │ ├── Overlap.hs │ │ │ ├── Polling.hs │ │ │ ├── Progress.hs │ │ │ └── Tasks.hs │ │ ├── Contact.hs │ │ ├── Contacts.hs │ │ ├── Counter.hs │ │ ├── Data/ │ │ │ └── ProgrammingLanguage.hs │ │ ├── DataLists/ │ │ │ ├── Autocomplete.hs │ │ │ ├── DataTable.hs │ │ │ ├── Filter.hs │ │ │ └── LoadMore.hs │ │ ├── Docs/ │ │ │ ├── App.hs │ │ │ ├── BasicPage.hs │ │ │ ├── CSS.hs │ │ │ ├── Client.hs │ │ │ ├── Component.hs │ │ │ ├── Encoding.hs │ │ │ ├── Interactive.hs │ │ │ ├── MultiPage.hs │ │ │ ├── MultiView.hs │ │ │ ├── Nested.hs │ │ │ ├── Nesting.hs │ │ │ ├── Page/ │ │ │ │ ├── Messages.hs │ │ │ │ └── Users.hs │ │ │ ├── Params.hs │ │ │ ├── QueryMessage.hs │ │ │ ├── Sessions.hs │ │ │ ├── SideEffects.hs │ │ │ ├── State.hs │ │ │ ├── UniqueViewId.hs │ │ │ └── ViewFunctions.hs │ │ ├── Document.hs │ │ ├── Effects/ │ │ │ ├── Debug.hs │ │ │ ├── Todos.hs │ │ │ └── Users.hs │ │ ├── Errors.hs │ │ ├── FormSimple.hs │ │ ├── FormValidation.hs │ │ ├── Interactivity/ │ │ │ ├── Events.hs │ │ │ └── Inputs.hs │ │ ├── Javascript.hs │ │ ├── Push.hs │ │ ├── Requests.hs │ │ ├── Scrollbars.hs │ │ ├── Simple.hs │ │ ├── State/ │ │ │ ├── Effects.hs │ │ │ ├── Query.hs │ │ │ ├── Sessions.hs │ │ │ ├── Stateless.hs │ │ │ └── ViewState.hs │ │ ├── Style/ │ │ │ └── Cyber.hs │ │ ├── Style.hs │ │ ├── Tags.hs │ │ ├── Test.hs │ │ ├── Todos/ │ │ │ ├── Todo.hs │ │ │ └── TodoCSS.hs │ │ ├── Trigger.hs │ │ └── View/ │ │ ├── Icon.hs │ │ ├── Inputs.hs │ │ ├── Layout.hs │ │ ├── Loader.hs │ │ ├── Menu.hs │ │ └── SortableTable.hs │ ├── Main.hs │ ├── README.md │ ├── demo.cabal │ ├── fourmolu.yaml │ ├── hie.yaml │ ├── package.yaml │ └── static/ │ ├── custom.js │ ├── cyber.css │ ├── docs.js │ ├── external.css │ ├── prism.css │ ├── prism.js │ ├── test.js │ └── todomvc.css ├── docs/ │ ├── Main.hs │ ├── app-document.md │ ├── app-effects.md │ ├── app-live.md │ ├── app-pages.md │ ├── app-routes.md │ ├── atomic.md │ ├── comparison.md │ ├── concurrency-overlap.md │ ├── dev.md │ ├── docgen.cabal │ ├── effectful.md │ ├── effects-custom.md │ ├── effects-other.md │ ├── forms-simple.md │ ├── forms-validated.md │ ├── hyperviews-intro.md │ ├── hyperviews-multi.md │ ├── hyperviews-nesting.md │ ├── hyperviews-unique.md │ ├── interactivity-events.md │ ├── interactivity-events2.md │ ├── interactivity-inputs.md │ ├── interactivity-javascript.md │ ├── interactivity-pushevent.md │ ├── intro-downsides.md │ ├── intro-links.md │ ├── intro.md │ ├── javascript_api.md │ ├── multi-same.md │ ├── nix.md │ ├── outline.md │ ├── package.yaml │ ├── pages.md │ ├── state-browser.md │ ├── state-effects.md │ ├── state-sessions.md │ ├── state-stateless.md │ ├── state-threading.md │ ├── state-viewstate.md │ ├── view-components.md │ ├── view-functions-end.md │ ├── view-functions-wrap.md │ └── view-functions.md ├── flake.nix ├── fourmolu.yaml ├── hie.yaml ├── hyperbole.cabal ├── package.yaml ├── src/ │ └── Web/ │ ├── Hyperbole/ │ │ ├── Application.hs │ │ ├── Data/ │ │ │ ├── Cookie.hs │ │ │ ├── Encoded.hs │ │ │ ├── JSON.hs │ │ │ ├── Param.hs │ │ │ ├── QueryData.hs │ │ │ └── URI.hs │ │ ├── Document.hs │ │ ├── Effect/ │ │ │ ├── Client.hs │ │ │ ├── GenRandom.hs │ │ │ ├── Hyperbole.hs │ │ │ ├── OAuth2.hs │ │ │ ├── Query.hs │ │ │ ├── Request.hs │ │ │ ├── Response.hs │ │ │ └── Session.hs │ │ ├── HyperView/ │ │ │ ├── Event.hs │ │ │ ├── Forms.hs │ │ │ ├── Handled.hs │ │ │ ├── Hyper.hs │ │ │ ├── Input.hs │ │ │ └── Types.hs │ │ ├── HyperView.hs │ │ ├── Page.hs │ │ ├── Route.hs │ │ ├── Server/ │ │ │ ├── Handler.hs │ │ │ ├── Message.hs │ │ │ ├── Options.hs │ │ │ ├── Socket.hs │ │ │ └── Wai.hs │ │ ├── TypeList.hs │ │ ├── Types/ │ │ │ ├── Client.hs │ │ │ ├── Event.hs │ │ │ ├── Request.hs │ │ │ └── Response.hs │ │ ├── View/ │ │ │ ├── CSS.hs │ │ │ ├── Embed.hs │ │ │ ├── Render.hs │ │ │ ├── Tag.hs │ │ │ ├── Types.hs │ │ │ ├── ViewAction.hs │ │ │ └── ViewId.hs │ │ └── View.hs │ └── Hyperbole.hs └── test/ ├── Spec.hs └── Test/ ├── EncodedSpec.hs ├── FormSpec.hs ├── ParamSpec.hs ├── QuerySpec.hs ├── RouteSpec.hs ├── SessionSpec.hs ├── URISpec.hs ├── ViewActionSpec.hs ├── ViewIdSpec.hs └── ViewSpec.hs ================================================ FILE CONTENTS ================================================ ================================================ FILE: .dockerignore ================================================ .git .stack-work client/node_modules Dockerfile dist-newstyle ================================================ FILE: .github/workflows/haskell.yaml ================================================ name: Haskell CI on: push: branches: [ "main", "ci" ] pull_request: branches: [ "main" ] permissions: contents: read jobs: build-cache: runs-on: ubuntu-latest container: image: haskell:9.8.2 steps: - uses: actions/checkout@v4 - name: Cache Cabal id: cache-cabal uses: actions/cache@v4 with: path: | /github/home/.cache /github/home/.config /github/home/.local key: ${{ runner.os }}-${{ hashFiles('**/cabal.project') }}-${{ hashFiles('**/*.cabal') }} # restore-keys: | # ${{ runner.os }}- - name: Install dependencies run: | cabal update - name: Build dependencies run: | cabal build --only-dependencies --enable-tests --enable-benchmarks - name: Install skeletest-preprocessor run: | cabal install skeletest --installdir=$HOME/.local/bin --install-method=copy --overwrite-policy=always - name: Check Cache run: | ls -ahl /github/home/ ls -ahl /github/home/.cache ls -ahl /github/home/.config ls -ahl /github/home/.local build-982: needs: build-cache runs-on: ubuntu-latest container: image: haskell:9.8.2 steps: - uses: actions/checkout@v4 - name: Cache Cabal Restore id: cache-cabal-restore uses: actions/cache@v4 with: path: | /github/home/.cache /github/home/.config /github/home/.local key: ${{ runner.os }}-${{ hashFiles('**/cabal.project') }}-${{ hashFiles('**/*.cabal') }} # restore-keys: | # ${{ runner.os }}-build-${{ env.cache-name }}- # ${{ runner.os }}-build- # ${{ runner.os }}- - name: Check Cache run: | ls -ahl /github/home/ ls -ahl /github/home/.cache ls -ahl /github/home/.config ls -ahl /github/home/.local - name: Source skeletest-preprocessor run: | echo "$HOME/.local/bin" >> $GITHUB_PATH - name: Build run: cabal build --enable-tests --enable-benchmarks all - name: Test run: cabal test # build-966: # runs-on: ubuntu-latest # container: # image: haskell:9.6.6 # steps: *cabal-test # - uses: actions/setup-haskell@v1 # with: # ghc-version: '9.6' # cabal-version: '3.2' # - name: Cache # uses: actions/cache@v3 # env: # cache-name: cache-cabal # with: # path: ~/.cabal # key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} # restore-keys: | # ${{ runner.os }}-build-${{ env.cache-name }}- # ${{ runner.os }}-build- # ${{ runner.os }}- ================================================ FILE: .github/workflows/packcheck.yaml ================================================ # packcheck-0.7.1 # You can use any of the options supported by packcheck as environment # variables here. See https://github.com/composewell/packcheck for all # options and their explanation. name: packcheck #----------------------------------------------------------------------------- # Events on which the build should be triggered #----------------------------------------------------------------------------- on: push: branches: [ "main", "ci" ] pull_request: #----------------------------------------------------------------------------- # Build matrix #----------------------------------------------------------------------------- jobs: build: name: >- ${{ matrix.name }} ${{ matrix.command }} ${{ matrix.runner }} ${{ matrix.ghc_version }} env: # ------------------------------------------------------------------------ # Common options # ------------------------------------------------------------------------ # GHC_OPTIONS: "-Werror" CABAL_REINIT_CONFIG: y LC_ALL: C.UTF-8 # ------------------------------------------------------------------------ # What to build # ------------------------------------------------------------------------ # DISABLE_TEST: "y" # DISABLE_BENCH: "y" # DISABLE_DOCS: "y" DISABLE_SDIST_BUILD: "y" # DISABLE_SDIST_GIT_CHECK: "y" # DISABLE_DIST_CHECKS: "y" # ------------------------------------------------------------------------ # Selecting tool versions # ------------------------------------------------------------------------ # For updating see: https://downloads.haskell.org/~ghcup/ GHCUP_VERSION: 0.1.40.0 GHCVER: ${{ matrix.ghc_version }} GHCUP_GHC_OPTIONS: ${{ matrix.ghcup_ghc_options }} # RESOLVER: ${{ matrix.stack_resolver }} # ------------------------------------------------------------------------ # stack options # ------------------------------------------------------------------------ # Note requiring a specific version of stack using STACKVER may fail due to # github API limit while checking and upgrading/downgrading to the specific # version. # STACKVER: "1.6.5" # STACK_UPGRADE: "y" # STACK_YAML: "stack.yaml" # ------------------------------------------------------------------------ # cabal options # ------------------------------------------------------------------------ CABAL_CHECK_RELAX: y CABAL_HACKAGE_MIRROR: "hackage.haskell.org:http://hackage.fpcomplete.com" CABAL_PROJECT: ${{ matrix.cabal_project }} # ------------------------------------------------------------------------ # Where to find the required tools # ------------------------------------------------------------------------ PATH: /opt/ghc/bin:/sbin:/usr/sbin:/bin:/usr/bin #TOOLS_DIR: /opt # ------------------------------------------------------------------------ # Location of packcheck.sh (the shell script invoked to perform CI tests ). # ------------------------------------------------------------------------ # You can either commit the packcheck.sh script at this path in your repo or # you can use it by specifying the PACKCHECK_REPO_URL option below in which # case it will be automatically copied from the packcheck repo to this path # during CI tests. In any case it is finally invoked from this path. PACKCHECK: "./packcheck.sh" # If you have not committed packcheck.sh in your repo at PACKCHECK # then it is automatically pulled from this URL. PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" PACKCHECK_GITHUB_COMMIT: "2856fb3010c7d0549537852cfa8500b4f1b58537" # ------------------------------------------------------------------------ # Final build variables # ------------------------------------------------------------------------ PACKCHECK_COMMAND: ${{ matrix.command }} ${{ matrix.pack_options }} # ubuntu seems to have better support than debian on CI systems runs-on: ${{ matrix.runner }} strategy: fail-fast: false matrix: include: - name: ci ghc_version: 9.12.1 command: cabal runner: ubuntu-latest cabal_project: cabal.project - name: ci ghc_version: 9.10.1 command: cabal runner: macos-latest cabal_project: cabal.project - name: ci-sdist ghc_version: 9.10.1 command: cabal runner: ubuntu-latest pack_options: >- DISABLE_SDIST_BUILD=n - name: ci command: cabal runner: ubuntu-latest ghc_version: 9.8.4 cabal_project: cabal.project - name: ci ghc_version: 9.6.6 command: cabal runner: macos-latest cabal_project: cabal.project # - name: ci # command: hlint # runner: ubuntu-latest # pack_options: >- # HLINT_VERSION=3.6.1 # HLINT_OPTIONS="lint" # HLINT_TARGETS="src test examples" steps: - uses: actions/checkout@v2 - uses: actions/cache@v3 name: Cache common directories with: path: | ~/.local ~/.cabal ~/.stack ~/.ghcup key: ${{ matrix.command }}-${{ matrix.ghc_version }}-${{ matrix.runner }} - name: Download packcheck run: | if test ! -e "$PACKCHECK" then if test -z "$PACKCHECK_GITHUB_COMMIT" then die "PACKCHECK_GITHUB_COMMIT is not specified." fi PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh curl --fail -sL -o "$PACKCHECK" $PACKCHECK_URL || exit 1 chmod +x $PACKCHECK elif test ! -x "$PACKCHECK" then chmod +x $PACKCHECK fi - name: Run packcheck run: | bash -c "$PACKCHECK $PACKCHECK_COMMAND" ================================================ FILE: .gitignore ================================================ dist-newstyle .DS_Store tags node_modules # Auto-generated pre-commit config .pre-commit-config.yaml # Nix output dir result .direnv client/dist/hyperbole.js.LICENSE.txt Session.vim .cabal.nix /package.json /package-lock.json ================================================ FILE: .hlint.yaml ================================================ - arguments: - -XOverloadedRecordDot - ignore: {name: "Use <$>"} - ignore: {name: "Use newtype instead of data"} # Hlint is not aware of OverloadedRecordDot # See https://github.com/ndmitchell/hlint/issues/1383 - ignore: { name: Redundant id } ================================================ FILE: .packcheck.ignore ================================================ client/*.d.ts client/src/ client/dist/*.d.ts client/package-lock.json client/webpack.config.js client/package.json client/tsconfig.json docs/ demo/ .dockerignore .github/workflows/haskell.yaml .github/workflows/packcheck.yaml .gitignore .hlint.yaml .packcheck.ignore DOCTODO.md Dockerfile bin/dev bin/docgen bin/release cabal.project flake.lock flake.nix fourmolu.yaml hie.yaml package.yaml ================================================ FILE: CHANGELOG.md ================================================ # Revision history for hyperbole ## 0.6.0 -- 2026-01-15 Improvements: * `ViewState` - built in threaded state, defaults to `()`, for folks who really miss Elm * `Concurrency` Controls - `Drop` vs `Replace` for overlapping updates * `pushUpdate` - server push an update to an arbitrary view * Long-running actions can be interrupted / cancelled * https://hyperbole.live now has inline documentation, code snippets, and live examples Breaking Changes: * A few functions now require state, such as `trigger` and `target` ## 0.5.0 -- 2025-09-26 Improvements * `trigger` actions in other views * Javascript FFI * `window.Hyperbole` - API available from custom JS. `runAction` allows JS to trigger actions * `pushEvent` - send events to JS from the server * Documents * Choose to configure with `View DocumentHead ()` instead of `ByteString` `->` `ByteString` * `quickStartDocument` * Live Reload * Websocket - ping keepalive * New form fields: `radio`, `select` * `Web.Hyperbole.Effect.OAuth2` - Authentication * `Web.Hyperbole.Effect.GenRandom` - Simple random effect used by OAuth2 * Error handling, custom errors * Examples * Many additions and improvements * External Stylesheet TodoMVC * OAuth2 example Breaking Changes / Improvements * `Web.Atomic.CSS` overhauled, and is now opt-in. Use new `@` and `~` operators to apply attributes and styles * `Web.Hyperbole.Data.Param` - unified param encoding for Forms, ViewId, ViewAction, Sessions, Queries * `Web.Hyperbole.Data.Encoding` - encoding for ViewId, ViewAction * `Web.Hyperbole.Data.URI` - Standardize on `Network.URI`, extra utilities to manage paths * `trigger`: required refactor of `Page` type alias to support type-checking: `Eff es (Page '[])` is now `Page es '[]` ## 0.4.3 -- 2025-01-31 * Bug fixes and improvements ## 0.4.2 -- 2025-01-21 * Cleaner HyperView class [(@cgeorgii)](https://github.com/cgeorgii) * data family Action * update * Type-safe resolution of HyperViews * Record-based Forms * textarea [(@tusharad)](https://github.com/tusharad) * High-level sessions and query params * Events: onLoad, onClick onInput, onSubmit, onDblClick, onKeyDown, onKeyUp * Major refactoring * Nix build and CI [(@Skyfold)](https://github.com/Skyfold) * New Examples Live: https://docs.hyperbole.live * New Examples Added: * TodoMVC * Forms - Simple * DataTable * Search - Filters * Search - Autocomplete ## 0.3.6 -- 2024-05-21 * First version. Released on an unsuspecting world. ================================================ FILE: DOCTODO.md ================================================ Documentation Outline ====================== ================================================ FILE: Dockerfile ================================================ FROM haskell:9.8.2 AS base WORKDIR /opt/build RUN cabal update RUN cabal install bytestring containers casing effectful text time string-interpolate file-embed http-api-data http-types wai warp wai-websockets network cookie string-conversions hpack websockets FROM haskell:9.8.2 AS dependencies WORKDIR /opt/build COPY --from=base /root/.cache /root/.cache COPY --from=base /root/.local /root/.local COPY --from=base /root/.config /root/.config # RUN apt-get update && apt-get install -y libpcre3 libpcre3-dev libcurl4-openssl-dev cron vim rsyslog ADD ./package.yaml . # ADD ./cabal.project . # ADD ./docs/docgen.cabal . # ADD ./demo/demo.cabal . RUN hpack RUN cabal update RUN cabal build --only-dependencies FROM haskell:9.8.2 AS build WORKDIR /opt/build COPY --from=dependencies /root/.cache /root/.cache COPY --from=dependencies /root/.local /root/.local COPY --from=dependencies /root/.config /root/.config ADD ./package.yaml . ADD ./cabal.project . ADD ./client ./client ADD ./test ./test ADD ./src ./src ADD ./demo ./demo ADD ./docs ./docs ADD *.md . ADD LICENSE . RUN hpack RUN hpack demo RUN hpack docs RUN cabal build demo RUN mkdir bin RUN cd demo && export EXEC=$(cabal list-bin demo | tail -n1); cp "$EXEC" /opt/build/bin/demo FROM ubuntu:24.04 AS app WORKDIR /opt/app RUN apt-get update RUN apt-get install -y --no-install-recommends ca-certificates RUN update-ca-certificates && rm -rf /var/lib/apt/lists/* COPY --from=build /opt/build/bin/demo ./bin/demo ADD ./client ./client ADD ./demo/static ./demo/static # ENV DYNAMO_LOCAL=False ENTRYPOINT ["/opt/app/bin/demo"] ================================================ FILE: LICENSE ================================================ Copyright (c) 2023, Sean Hess All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Sean Hess nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: README.md ================================================ ![Hyperbole](https://github.com/seanhess/hyperbole/raw/main/demo/static/logo-robot.png) [![Hackage Version](https://img.shields.io/hackage/v/hyperbole?color=success)](https://hackage.haskell.org/package/hyperbole) Create interactive HTML applications with type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView. [▶️ Simple Example](https://hyperbole.live/simple) ```haskell {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Main where import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole main :: IO () main = do run 3000 $ do liveApp quickStartDocument (runPage page) page :: (Hyperbole :> es) => Page es '[Message] page = do pure $ do hyper Message1 $ messageView "Hello" hyper Message2 $ messageView "World!" 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 messageView :: Text -> View Message () messageView msg = do button (Louder msg) ~ border 1 $ text msg ``` Documentation ------------- Visit [hyperbole.live](https://hyperbole.live) for documentation and live examples. Also see the [Hackage Documentation](https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html) Hyperbole Documentation Getting Started with Cabal -------------------------- Create a new application: $ mkdir myapp $ cd myapp $ cabal init Add hyperbole and text as dependencies to the `.cabal` file: ``` build-depends: base , hyperbole , text default-language: GHC2021 ``` Paste the above example into Main.hs, then run it: $ cabal run Visit http://localhost:3000 to view the application Learn More ---------- * [Local Development](./docs/dev.md) * [Comparison with Similar Frameworks](./docs/comparison.md) * [Using NIX](./docs/nix.md) In the Wild --------------------- National Solar Observatory The NSO uses Hyperbole to manage Level 2 Data pipelines for the [DKIST telescope](https://nso.edu/telescopes/dki-solar-telescope/). It uses complex user interfaces, workers, databases, and more. [The entire codebase is open source](https://github.com/DKISTDC/level2/). Contributors ------------ * [Sean Hess](seanhess) * [Kamil Figiela](https://github.com/kfigiela) * [Christian Georgii](https://github.com/cgeorgii) * [Pfalzgraf Martin](https://github.com/Skyfold) * [Tushar Adhatrao](https://github.com/tusharad) * [Benjamin Thomas](https://github.com/benjamin-thomas) * [Adithya Obilisetty](https://github.com/adithyaov) ================================================ FILE: bin/dev ================================================ #!/bin/bash package() { hpack hpack docs hpack demo } watch() { ghcid -c "cabal repl demo lib:hyperbole" -T App.run -W --reload=./client/dist/hyperbole.js } client() { cd client # npx webpack -w --mode=development npx webpack -w } # run tests once (so we don't forget!) cabal test (trap 'kill 0' SIGINT; client & package && watch) ================================================ FILE: bin/docgen ================================================ #!/bin/bash set -e hpack demo hpack docs cabal run docs cd /tmp/hyperbole cabal haddock ================================================ FILE: bin/release ================================================ #!/bin/bash # Make sure everything is working hpack cabal test # Compile the JS client cd client npm install npx webpack --mode=production cd .. # Compile the package cabal sdist # NEXT: Update branch release tags and push ================================================ FILE: cabal.project ================================================ tests: True multi-repl: True packages: . ./demo/ ./docs/ ================================================ FILE: client/declarations.d.ts ================================================ declare module 'omdomdom/lib/omdomdom.es.js' { export function create(node: any, ...args: any[]): any; export function patch(template: any, vNode: any, rootNode?: any): void; export function render(vNode: any, root: any): void; } ================================================ FILE: client/dist/action.d.ts ================================================ import { Meta, ViewId, RequestId, EncodedAction, ViewState } from "./message"; export type ActionMessage = { viewId: ViewId; action: EncodedAction; requestId: RequestId; state?: ViewState; meta: Meta[]; form: URLSearchParams | undefined; }; export declare function actionMessage(id: ViewId, action: EncodedAction, state: ViewState | undefined, reqId: RequestId, form?: FormData): ActionMessage; export declare function toSearch(form?: FormData): URLSearchParams | undefined; export declare function renderActionMessage(msg: ActionMessage): string; export declare function renderForm(form: URLSearchParams | undefined): string; export type Request = { requestId: RequestId; isCancelled: boolean; }; export declare function newRequest(): Request; export declare function encodedParam(action: string, param: string): string; ================================================ FILE: client/dist/browser.d.ts ================================================ export declare function setQuery(query: string): void; ================================================ FILE: client/dist/events.d.ts ================================================ import { HyperView } from './hyperview'; export type UrlFragment = string; export declare function listenKeydown(cb: (target: HyperView, action: string) => void): void; export declare function listenKeyup(cb: (target: HyperView, action: string) => void): void; export declare function listenKeyEvent(event: "keyup" | "keydown", cb: (target: HyperView, action: string) => void): void; export declare function listenBubblingEvent(event: string, cb: (_target: HyperView, action: string) => void): void; export declare function listenClick(cb: (target: HyperView, action: string) => void): void; export declare function listenDblClick(cb: (target: HyperView, action: string) => void): void; export declare function listenTopLevel(cb: (target: HyperView, action: string) => void): void; export declare function listenLoad(node: HTMLElement): void; export declare function listenMouseEnter(node: HTMLElement): void; export declare function listenMouseLeave(node: HTMLElement): void; export declare function listenChange(cb: (target: HyperView, action: string) => void): void; export declare function listenInput(startedTyping: (target: HyperView) => void, cb: (target: HyperView, action: string) => void): void; export declare function listenFormSubmit(cb: (target: HyperView, action: string, form: FormData) => void): void; ================================================ FILE: client/dist/http.d.ts ================================================ ================================================ FILE: client/dist/hyperbole.js ================================================ /*! For license information please see hyperbole.js.LICENSE.txt */ (()=>{var e={296:e=>{function t(e,t=100,n={}){if("function"!=typeof e)throw new TypeError(`Expected the first parameter to be a function, got \`${typeof e}\`.`);if(t<0)throw new RangeError("`wait` must not be negative.");const{immediate:o}="boolean"==typeof n?{immediate:n}:n;let r,i,a,s,c;function u(){const t=r,n=i;return r=void 0,i=void 0,c=e.apply(t,n),c}function l(){const e=Date.now()-s;e=0?a=setTimeout(l,t-e):(a=void 0,o||(c=u()))}const d=function(...e){if(r&&this!==r&&Object.getPrototypeOf(this)===Object.getPrototypeOf(r))throw new Error("Debounced method called with different contexts of the same prototype.");r=this,i=e,s=Date.now();const n=o&&!a;return a||(a=setTimeout(l,t)),n&&(c=u()),c};return Object.defineProperty(d,"isPending",{get:()=>void 0!==a}),d.clear=()=>{a&&(clearTimeout(a),a=void 0)},d.flush=()=>{a&&d.trigger()},d.trigger=()=>{c=u(),d.clear()},d}e.exports.debounce=t,e.exports=t},147:e=>{"use strict";e.exports=JSON.parse('{"name":"web-ui","version":"0.6.0","description":"Development -----------","main":"index.js","directories":{"client":"client"},"scripts":{"build":"npx webpack"},"author":"","license":"ISC","devDependencies":{"ts-loader":"^9.4.1","typescript":"^4.8.3","uglify":"^0.1.5","webpack":"^5.88.2","webpack-cli":"^4.10.0"},"dependencies":{"omdomdom":"^0.3.2","debounce":"^2.2.0"}}')}},t={};function n(o){var r=t[o];if(void 0!==r)return r.exports;var i=t[o]={exports:{}};return e[o](i,i.exports,n),i.exports}(()=>{"use strict";var e=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},t=function(e,t){var n=e.length,o=-1;if(n)for(;++oe.length)&&(t=e.length);for(var n=0,o=new Array(t);n0)for(;d>0;)r.node.removeChild(r.node.childNodes[l-1]),l--,d--}}(r,i,n)}},y=function n(o){var r,i=arguments.length>1&&void 0!==arguments[1]&&arguments[1];"string"==typeof o&&(r=o.trim().replace(/\s+\s+/g,">"),o=(new DOMParser).parseFromString(r,"text/html").body);var a="BODY"===o.tagName,s=o.childNodes,c=s?s.length:0;if(a){if(c>1)throw new Error("[OmDomDom]: Your element should not have more than one root node.");if(0===c)throw new Error("[OmDomDom]: Your element should have at least one root node.");return n(s[0])}var l=3===o.nodeType?"text":8===o.nodeType?"comment":o.tagName.toLowerCase(),d=i||"svg"===l,f=1===o.nodeType?function(t){var n=function(t){return Array.prototype.reduce.call(t.attributes,(function(t,n){return e(u,n.name)||(t[n.name]=n.value),t}),{})}(t);return function(e,t){for(var n in u){var o=u[n].propName,r=e.getAttribute(n);n===u.style.attrName?t[n]=e.style[o]:"string"==typeof r&&(t[n]=r)}}(t,n),n}(o):{},v=c>0?null:o.textContent,m=Array(c);return t(s,(function(e,t){m[t]=n(e,d)})),{type:l,attributes:f,children:m,content:v,node:o,isSVGContext:d}};function g(e,t){var n=[];for(var o of t){let t=e(o);if(!t)break;n.push(t)}return n}function w(e){return{cookies:e.filter((e=>"Cookie"==e.key)).map((e=>e.value)),error:b("Error",e),query:b("Query",e),pageTitle:b("PageTitle",e),events:I("Event",e).map(k),actions:I("Trigger",e).map(q)}}function E(e){return w(g(C,e.trim().split("\n")))}function b(e,t){return t.find((t=>t.key==e))?.value}function I(e,t){return t.filter((t=>t.key==e)).map((e=>e.value))}function C(e){let t=e.match(/^(\w+)\: (.*)$/);if(t)return{key:t[1],value:t[2]}}function k(e){let[t,n]=T(e);return{name:t,detail:JSON.parse(n)}}function q(e){let[t,n]=T(e);return[t,n]}function T(e){let t=e.indexOf("|");if(-1===t){let t=new Error("Bad Encoding, Expected Segment");throw t.message=e,t}return[e.slice(0,t),e.slice(t+1)]}function L(e){if(!e)return;const t=new URLSearchParams;return e.forEach(((e,n)=>{t.append(n,e)})),t}let S=0;function A(e,t){return e+" "+function(e){return""==e?"|":e.replace(/_/g,"\\_").replace(/\s+/g,"_")}(t)}const M=`${"https:"===window.location.protocol?"wss:":"ws:"}//${window.location.host}${window.location.pathname}`;class x extends Error{constructor(e,t){super(e+"\n"+t),this.name="ProtocolError"}}var R=n(296);const D=e=>void 0!==e?.runAction;function O(e){let t=new Event("hyp-content",{bubbles:!0});e.dispatchEvent(t)}function N(e,t){e.querySelectorAll("[id]").forEach((n=>{n.runAction=function(e){return t(n,e)},n.concurrency=n.dataset.concurrency||"Drop",n.cancelActiveRequest=function(){n.activeRequest&&!n.activeRequest?.isCancelled&&(n.activeRequest.isCancelled=!0)},O(e)}))}function H(e,t){document.addEventListener(e,(function(n){if(!(n.target instanceof HTMLElement))return void console.warn("listenKeyEvent received event with non HTMLElment as EventTarget: %o",n);let o=n.target,r="on"+e+n.key,i=o.dataset[r];if(!i)return;n.preventDefault();const a=Q(o);a?t(a,i):console.error("Missing target: ",o)}))}function V(e,t){document.addEventListener(e,(function(n){if(!(n.target instanceof HTMLElement))return void console.warn("listenBubblingEvent received an event with non HTMLElment as EventTarget: %o",n);let o=n.target.closest("[data-on"+e+"]");if(!o)return;n.preventDefault();let r=Q(o);if(!r)return void console.error("Missing target: ",o);const i=o.dataset["on"+e];void 0!==i?t(r,i):console.error("Missing action: ",o,e)}))}function j(e){e.querySelectorAll("[data-onload]").forEach((e=>{let t=parseInt(e.dataset.delay||"")||0,n=e.dataset.onload;setTimeout((()=>{let t=Q(e);if(e.dataset.onload!=n)return;const o=new CustomEvent("hyp-load",{bubbles:!0,detail:{target:t,onLoad:n}});e.dispatchEvent(o)}),t)}))}function P(e){e.querySelectorAll("[data-onmouseenter]").forEach((e=>{let t=e.dataset.onmouseenter,n=U(e);e.onmouseenter=()=>{const o=new CustomEvent("hyp-mouseenter",{bubbles:!0,detail:{target:n,onMouseEnter:t}});e.dispatchEvent(o)}}))}function B(e){e.querySelectorAll("[data-onmouseleave]").forEach((e=>{let t=e.dataset.onmouseleave,n=U(e);e.onmouseleave=()=>{const o=new CustomEvent("hyp-mouseleave",{bubbles:!0,detail:{target:n,onMouseLeave:t}});e.dispatchEvent(o)}}))}function Q(e){const t=U(e);if(D(t))return t;console.error("Non HyperView target: ",t)}function U(e){let t=function(e){let t=e.closest("[data-target]");return t?.dataset.target||e.closest("[id]")?.id}(e),n=t&&document.getElementById(t);if(n)return n;console.error("Cannot find target: ",t,e)}let W,$=n(147);console.log("Hyperbole "+$.version+"b");let F=new Set;async function _(e,t,n){if(e.activeRequest&&!e.activeRequest?.isCancelled&&"Drop"==e.concurrency)return void console.warn("Drop action overlapping with active request ("+e.activeRequest+")",t);e._timeout=window.setTimeout((()=>{e.classList.add("hyp-loading")}),100);let o=e.dataset.state,r={requestId:++S,isCancelled:!1},i=function(e,t,n,o,r){return{viewId:e,action:t,state:n,requestId:o,meta:[{key:"Cookie",value:decodeURI(document.cookie)},{key:"Query",value:window.location.search}],form:L(r)}}(e.id,t,o,r.requestId,n);e.activeRequest=r,z.sendAction(i)}function G(e){let t=e.targetViewId||e.viewId,n=document.getElementById(t);if(!D(n))return void console.error("Missing Update HyperView Target: ",t,e);if(n.activeRequest?.requestId&&e.requestId{let t=e.getAttribute("value");null!==t&&(e.value=t)})),e.querySelectorAll("input[type=checkbox]").forEach((e=>{let t="True"==e.dataset.checked;e.checked=t}))}(c),N(c,_),n):(console.warn("Target Missing: ",n.id),n)}function J(e){e.forEach((e=>{console.log("SetCookie: ",e),document.cookie=e}))}function K(e,t){null!=e.query&&function(e){if(e!=function(){const e=window.location.search;return e.startsWith("?")?e.substring(1):e}()){""!=e&&(e="?"+e);let t=location.pathname+e;window.history.replaceState({},"",t)}}(e.query),null!=e.pageTitle&&(document.title=e.pageTitle),e.events?.forEach((e=>{Y(e,t)})),e.actions?.forEach((([e,t])=>{X(e,t)}))}function Y(e,t){setTimeout((()=>{let n=new CustomEvent(e.name,{bubbles:!0,detail:e.detail});(t||document).dispatchEvent(n)}),10)}function X(e,t){setTimeout((()=>{let n=window.Hyperbole?.hyperView(e);n&&_(n,t)}),10)}document.addEventListener("DOMContentLoaded",(function(){K(E(document.getElementById("hyp.metadata")?.innerText??""),null);const e=document.body.querySelector("style");var t;null!==e?W=e:(console.warn("rootStyles missing from page, creating..."),W=document.createElement("style"),W.type="text/css",document.body.appendChild(W)),t=async function(e,t){_(e,t)},document.addEventListener("hyp-load",(function(e){let n=e.detail.onLoad,o=e.detail.target;t(o,n)})),document.addEventListener("hyp-mouseenter",(function(e){let n=e.detail.onMouseEnter,o=e.detail.target;t(o,n)})),document.addEventListener("hyp-mouseleave",(function(e){let n=e.detail.onMouseLeave,o=e.detail.target;t(o,n)})),j(document.body),P(document.body),B(document.body),N(document.body,_),V("click",(async function(e,t){_(e,t)})),V("dblclick",(async function(e,t){_(e,t)})),H("keydown",(async function(e,t){_(e,t)})),H("keyup",(async function(e,t){_(e,t)})),document.addEventListener("submit",(function(e){if(!(e.target instanceof HTMLFormElement))return void console.warn("listenFormSubmit received an event with non HTMLElment as EventTarget: %o",e);let t=e.target;if(!t.dataset.onsubmit)return void console.error("Missing onSubmit: ",t);e.preventDefault();let n=Q(t);const o=new FormData(t);n?async function(e,t,n){_(e,t,n)}(n,t.dataset.onsubmit,o):console.error("Missing target: ",t)})),document.addEventListener("change",(function(e){if(!(e.target instanceof HTMLElement))return void console.warn("listenChange received an event with non HTMLElment as EventTarget: %o",e);let t=e.target.closest("[data-onchange]");if(!t)return;if(e.preventDefault(),null===t.value)return void console.error("Missing input value:",t);let n=Q(t);n?t.dataset.onchange?async function(e,t){_(e,t)}(n,A(t.dataset.onchange,t.value)):console.error("Missing onchange: ",t):console.error("Missing target: listenChange")})),document.addEventListener("input",(function(e){if(!(e.target instanceof HTMLElement))return void console.warn("listenInput received an event with non HTMLElment as EventTarget: %o",e);const t=e.target.closest("[data-oninput]");if(!t)return;let n=parseInt(t.dataset.delay||"")||250;n<250&&console.warn("Input delay < 250 can result in poor performance."),e.preventDefault();const o=Q(t);o?(function(e){"Replace"==e.concurrency&&e.cancelActiveRequest()}(o),t.debouncedCallback||(t.debouncedCallback=R((()=>{if(!t.dataset.oninput)return void console.error("Missing onInput: ",t);const e=A(t.dataset.oninput,t.value);!async function(e,t){_(e,t)}(o,e)}),n)),t.debouncedCallback()):console.error("Missing target: ",t)}))}));const z=new class{constructor(e=M){this.hasEverConnected=!1,this.isConnected=!1,this.reconnectDelay=0,this.queue=[],this.events=new EventTarget;const t=new WebSocket(e);this.socket=t}connect(e=M,t=!1){const n=t?new WebSocket(e):this.socket;function o(e){console.error("Connect Error",e)}function r(e){console.error("Socket Error",e)}this.socket=n,n.addEventListener("error",o),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",o),n.addEventListener("error",r),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",r),this.hasEverConnected&&(console.log("Reconnecting in "+this.reconnectDelay/1e3+"s"),setTimeout((()=>this.connect(e,!0)),this.reconnectDelay)),n.removeEventListener("error",r)})),n.addEventListener("message",(e=>this.onMessage(e)))}async sendAction(e){if(this.isConnected){let t=function(e){let t=["|ACTION|","ViewId: "+e.viewId,"Action: "+e.action];return e.state&&t.push("State: "+e.state),t.push("RequestId: "+e.requestId),[t.join("\n"),(o=e.meta,o.map((e=>e.key+": "+e.value)).join("\n"))].join("\n")+((n=e.form)?"\n\n"+n:"");var n,o}(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:o}=function(e){let t=e.split("\n"),n=t[0],o=g(C,t.slice(1));return{command:n,metas:o,rest:function(e,t){let n=0;for(;n{G(e.detail)})),z.addEventListener("response",(e=>function(e){let t=G(e);t&&(delete t.activeRequest,clearTimeout(t._timeout),t.classList.remove("hyp-loading"))}(e.detail))),z.addEventListener("redirect",(e=>{return t=e.detail,console.log("REDIRECT",t),J(t.meta.cookies??[]),void(window.location.href=t.url);var t})),z.addEventListener("trigger",(e=>{var t;X((t=e.detail).targetViewId,t.targetAction)})),z.addEventListener("event",(e=>function(e){let t=document.getElementById(e.viewId);Y(e.event,t)}(e.detail))),window.Hyperbole={runAction:_,parseMetadata:E,action:function(e,...t){return t.reduce(((e,t)=>e+" "+JSON.stringify(t)),e)},hyperView:function(e){let t=document.getElementById(e);if(D(t))return t;console.error("Element id="+e+" was not a HyperView")},socket:z}})()})(); //# sourceMappingURL=hyperbole.js.map ================================================ FILE: client/dist/hyperview.d.ts ================================================ import { type Request } from "./action"; export interface HyperView extends HTMLElement { runAction(action: string): Promise; activeRequest?: Request; cancelActiveRequest(): void; concurrency: ConcurrencyMode; _timeout?: number; } export declare const isHyperView: (ele: any) => ele is HyperView; export type ConcurrencyMode = string; export declare function dispatchContent(node: HTMLElement): void; export declare function enrichHyperViews(node: HTMLElement, runAction: (target: HyperView, action: string, form?: FormData) => Promise): void; ================================================ FILE: client/dist/index.d.ts ================================================ import { SocketConnection } from './sockets'; import { ViewId, Metadata } from './message'; import { HyperView } from "./hyperview"; declare global { interface Window { Hyperbole?: HyperboleAPI; } interface DocumentEventMap { "hyp-load": CustomEvent; "hyp-mouseenter": CustomEvent; "hyp-mouseleave": CustomEvent; } } export interface HyperboleAPI { runAction(target: HTMLElement, action: string, form?: FormData): Promise; action(con: string, ...params: any[]): string; hyperView(viewId: ViewId): HyperView | undefined; parseMetadata(input: string): Metadata; socket: SocketConnection; } ================================================ FILE: client/dist/lib.d.ts ================================================ export declare function takeWhileMap(pred: (val: T) => A | undefined, lines: T[]): A[]; export declare function dropWhile(pred: (val: T) => A | undefined, lines: T[]): T[]; ================================================ FILE: client/dist/message.d.ts ================================================ export type Meta = { key: string; value: string; }; export type ViewId = string; export type RequestId = number; export type EncodedAction = string; export type ViewState = string; export type RemoteEvent = { name: string; detail: unknown; }; export declare function renderMetas(meta: Meta[]): string; export type Metadata = { cookies?: string[]; error?: string; query?: string; events?: RemoteEvent[]; actions?: [ViewId, EncodedAction][]; pageTitle?: string; }; export declare function toMetadata(meta: Meta[]): Metadata; export declare function parseMetadata(input: string): Metadata; export declare function metaValue(key: string, metas: Meta[]): string | undefined; export declare function metaValuesAll(key: string, metas: Meta[]): string[]; export type SplitMessage = { command: string; metas: Meta[]; rest: string[]; }; export declare function splitMessage(message: string): SplitMessage; export declare function parseMeta(line: string): Meta | undefined; export declare function parseRemoteEvent(input: string): RemoteEvent; export declare function parseAction(input: string): [ViewId, string]; ================================================ FILE: client/dist/response.d.ts ================================================ import { ViewId, Metadata } from './message'; export type Response = { meta: Metadata; body: ResponseBody; }; export type ResponseBody = string; export declare function parseResponse(res: ResponseBody): LiveUpdate; export type LiveUpdate = { content: HTMLElement | null; css: HTMLStyleElement | null; }; export declare class FetchError extends Error { viewId: ViewId; body: string; constructor(viewId: ViewId, msg: string, body: string); } ================================================ FILE: client/dist/sockets.d.ts ================================================ import { ActionMessage } from './action'; import { ResponseBody } from "./response"; import { ViewId, RequestId, EncodedAction, Metadata, RemoteEvent } from "./message"; interface SocketConnectionEventMap { "update": CustomEvent; "response": CustomEvent; "redirect": CustomEvent; "trigger": CustomEvent; "event": CustomEvent; } export declare class SocketConnection { socket: WebSocket; hasEverConnected: Boolean; isConnected: Boolean; reconnectDelay: number; queue: ActionMessage[]; events: EventTarget; constructor(addr?: string); connect(addr?: string, createSocket?: boolean): void; sendAction(action: ActionMessage): Promise; private runQueue; private onMessage; addEventListener(e: K, cb: (ev: SocketConnectionEventMap[K]) => void): void; dispatchEvent(e: SocketConnectionEventMap[K]): void; disconnect(): void; } export type Update = { requestId: RequestId; meta: Metadata; viewId: ViewId; targetViewId?: ViewId; action: EncodedAction; body: ResponseBody; }; export type Redirect = { requestId: RequestId; meta: Metadata; url: string; }; export type Trigger = { requestId: RequestId; meta: Metadata; viewId: ViewId; action: EncodedAction; targetViewId: ViewId; targetAction: string; }; export type JSEvent = { requestId: RequestId; meta: Metadata; viewId: ViewId; action: EncodedAction; event: RemoteEvent; }; export type MessageType = string; export declare class ProtocolError extends Error { constructor(description: string, body: string); } export {}; ================================================ FILE: client/package.json ================================================ { "name": "web-ui", "version": "0.6.0", "description": "Development -----------", "main": "index.js", "directories": { "client": "client" }, "scripts": { "build": "npx webpack" }, "author": "", "license": "ISC", "devDependencies": { "ts-loader": "^9.4.1", "typescript": "^4.8.3", "uglify": "^0.1.5", "webpack": "^5.88.2", "webpack-cli": "^4.10.0" }, "dependencies": { "omdomdom": "^0.3.2", "debounce": "^2.2.0" } } ================================================ FILE: client/src/action.ts ================================================ import { takeWhileMap } from "./lib" import { Meta, ViewId, RequestId, EncodedAction, ViewState } from "./message" import * as message from "./message" export type ActionMessage = { viewId: ViewId action: EncodedAction requestId: RequestId state?: ViewState meta: Meta[] form: URLSearchParams | undefined } export function actionMessage(id: ViewId, action: EncodedAction, state: ViewState | undefined, reqId: RequestId, form?: FormData): ActionMessage { let meta: Meta[] = [ { key: "Cookie", value: decodeURI(document.cookie) }, { key: "Query", value: window.location.search } ] return { viewId: id, action, state, requestId: reqId, meta, form: toSearch(form) } } export function toSearch(form?: FormData): URLSearchParams | undefined { if (!form) return undefined const params = new URLSearchParams() form.forEach((value, key) => { params.append(key, value as string) }) return params } export function renderActionMessage(msg: ActionMessage): string { let header = [ "|ACTION|", "ViewId: " + msg.viewId, "Action: " + msg.action, ] if (msg.state) { header.push("State: " + msg.state) } header.push("RequestId: " + msg.requestId) return [ header.join('\n'), message.renderMetas(msg.meta), ].join('\n') + renderForm(msg.form) } export function renderForm(form: URLSearchParams | undefined): string { if (!form) return "" return "\n\n" + form } let globalRequestId: RequestId = 0 export type Request = { requestId: RequestId isCancelled: boolean } export function newRequest(): Request { let requestId = ++globalRequestId return { requestId, isCancelled: false } } // Sanitized Encoding ------------------------------------ export function encodedParam(action: string, param: string): string { return action + ' ' + sanitizeParam(param) } function sanitizeParam(param: string): string { if (param == "") { return "|" } return param.replace(/_/g, "\\_").replace(/\s+/g, "_") } ================================================ FILE: client/src/browser.ts ================================================ export function setQuery(query: string) { if (query != currentQuery()) { if (query != "") query = "?" + query let url = location.pathname + query // console.log("history.replaceState(", url, ")") window.history.replaceState({}, "", url) } } function currentQuery(): string { const query = window.location.search; return query.startsWith('?') ? query.substring(1) : query; } ================================================ FILE: client/src/events.ts ================================================ import * as debounce from 'debounce' import { encodedParam } from './action' import { HyperView, isHyperView } from './hyperview' export type UrlFragment = string export function listenKeydown(cb: (target: HyperView, action: string) => void): void { listenKeyEvent("keydown", cb) } export function listenKeyup(cb: (target: HyperView, action: string) => void): void { listenKeyEvent("keyup", cb) } export function listenKeyEvent(event: "keyup" | "keydown", cb: (target: HyperView, action: string) => void): void { document.addEventListener(event, function(e: KeyboardEvent) { if (!(e.target instanceof HTMLElement)) { console.warn("listenKeyEvent received event with non HTMLElment as EventTarget: %o", e) return } let source = e.target let datasetKey = "on" + event + e.key let action = source.dataset[datasetKey] if (!action) return e.preventDefault() const target = nearestHyperViewTarget(source) if (!target) { console.error("Missing target: ", source) return } cb(target, action) }) } export function listenBubblingEvent(event: string, cb: (_target: HyperView, action: string) => void): void { document.addEventListener(event, function(e) { if (!(e.target instanceof HTMLElement)) { console.warn("listenBubblingEvent received an event with non HTMLElment as EventTarget: %o", e) return } let el = e.target // clicks can fire on internal elements. Find the parent with a click handler let source = el.closest("[data-on" + event + "]") if (!source) return e.preventDefault() let target = nearestHyperViewTarget(source) if (!target) { console.error("Missing target: ", source) return } const action = source.dataset["on" + event] if (action === undefined) { console.error("Missing action: ", source, event) return } cb(target, action) }) } export function listenClick(cb: (target: HyperView, action: string) => void): void { listenBubblingEvent("click", cb) } export function listenDblClick(cb: (target: HyperView, action: string) => void): void { listenBubblingEvent("dblclick", cb) } export function listenTopLevel(cb: (target: HyperView, action: string) => void): void { document.addEventListener("hyp-load", function(e: CustomEvent) { let action = e.detail.onLoad let target = e.detail.target cb(target, action) }) document.addEventListener("hyp-mouseenter", function(e: CustomEvent) { let action = e.detail.onMouseEnter let target = e.detail.target cb(target, action) }) document.addEventListener("hyp-mouseleave", function(e: CustomEvent) { let action = e.detail.onMouseLeave let target = e.detail.target cb(target, action) }) } export function listenLoad(node: HTMLElement): void { // it doesn't really matter WHO runs this except that it should have target node.querySelectorAll("[data-onload]").forEach((load) => { let delay = parseInt(load.dataset.delay || "") || 0 let onLoad = load.dataset.onload // console.log("load start", load.dataset.onLoad) // load no longer exists! // we should clear the timeout or back out if the dom is replaced in the interem setTimeout(() => { let target = nearestHyperViewTarget(load) // console.log("load go", load.dataset.onLoad) if (load.dataset.onload != onLoad) { // the onLoad no longer exists return } const event = new CustomEvent("hyp-load", { bubbles: true, detail: { target, onLoad } }) load.dispatchEvent(event) }, delay) }) } export function listenMouseEnter(node: HTMLElement): void { node.querySelectorAll("[data-onmouseenter]").forEach((node) => { let onMouseEnter = node.dataset.onmouseenter let target = nearestAnyTarget(node) node.onmouseenter = () => { const event = new CustomEvent("hyp-mouseenter", { bubbles: true, detail: { target, onMouseEnter } }) node.dispatchEvent(event) } }) } export function listenMouseLeave(node: HTMLElement): void { node.querySelectorAll("[data-onmouseleave]").forEach((node) => { let onMouseLeave = node.dataset.onmouseleave let target = nearestAnyTarget(node) node.onmouseleave = () => { const event = new CustomEvent("hyp-mouseleave", { bubbles: true, detail: { target, onMouseLeave } }) node.dispatchEvent(event) } }) } export function listenChange(cb: (target: HyperView, action: string) => void): void { document.addEventListener("change", function(e) { if (!(e.target instanceof HTMLElement)) { console.warn("listenChange received an event with non HTMLElment as EventTarget: %o", e) return } let el = e.target let source = el.closest("[data-onchange]") if (!source) return e.preventDefault() if (source.value === null) { console.error("Missing input value:", source) return } let target = nearestHyperViewTarget(source) if (!target) { console.error("Missing target: listenChange") return } if (!source.dataset.onchange) { console.error("Missing onchange: ", source) return } let action = encodedParam(source.dataset.onchange, source.value) cb(target, action) }) } interface LiveInputElement extends HTMLInputElement { debouncedCallback?: Function; } export function listenInput(startedTyping: (target: HyperView) => void, cb: (target: HyperView, action: string) => void): void { document.addEventListener("input", function(e) { if (!(e.target instanceof HTMLElement)) { console.warn("listenInput received an event with non HTMLElment as EventTarget: %o", e) return } let el = e.target const source = el.closest("[data-oninput]") if (!source) return let delay = parseInt(source.dataset.delay || "") || 250 if (delay < 250) { console.warn("Input delay < 250 can result in poor performance.") } e.preventDefault() const target = nearestHyperViewTarget(source) if (!target) { console.error("Missing target: ", source) return } // I want to CANCEL the active request as soon as we start typing startedTyping(target) if (!source.debouncedCallback) { source.debouncedCallback = debounce(() => { if (!source.dataset.oninput) { console.error("Missing onInput: ", source) return } const action = encodedParam(source.dataset.oninput, source.value) cb(target, action) }, delay) } source.debouncedCallback() }) } export function listenFormSubmit(cb: (target: HyperView, action: string, form: FormData) => void): void { document.addEventListener("submit", function(e) { if (!(e.target instanceof HTMLFormElement)) { console.warn("listenFormSubmit received an event with non HTMLElment as EventTarget: %o", e) return } let form = e.target if (!form.dataset.onsubmit) { console.error("Missing onSubmit: ", form) return } e.preventDefault() let target = nearestHyperViewTarget(form) const formData = new FormData(form) if (!target) { console.error("Missing target: ", form) return } cb(target, form.dataset.onsubmit, formData) }) } function nearestTargetId(node: HTMLElement): string | undefined { let targetData = node.closest("[data-target]") return targetData?.dataset.target || node.closest("[id]")?.id } function nearestHyperViewTarget(node: HTMLElement): HyperView | undefined { const target = nearestAnyTarget(node) if (!isHyperView(target)) { console.error("Non HyperView target: ", target) return } return target } function nearestAnyTarget(node: HTMLElement): HTMLElement | undefined { let targetId = nearestTargetId(node) let target = targetId && document.getElementById(targetId) if (!target) { console.error("Cannot find target: ", targetId, node) return } return target } ================================================ FILE: client/src/http.ts ================================================ // import { ActionMessage, ParsedResponse } from './action' // import { Response, FetchError } from "./response" // export async function sendActionHttp(msg: ActionMessage): Promise { // // console.log("HTTP sendAction", msg.url.toString()) // let url = window.location.href // let res = await fetch(url, { // method: "POST", // headers: // { // 'Accept': 'text/html', // 'Content-Type': 'application/x-www-form-urlencoded', // 'Hyp-RequestId': msg.requestId, // 'Hyp-ViewId': msg.viewId, // 'Hyp-Action': msg.action // }, // body: msg.form, // // we never want this to be redirected // redirect: "manual" // }) // // let body = await res.text() // let { metadata, rest } = parseMetadataHttp(body) // // if (!res.ok) { // throw new FetchError(msg.viewId, body, body) // } // // let response: Response = { // meta: metadata, // body: rest.join('\n') // } // // return response // } // export function parseMetadataHttp(inp: string): ParsedResponse { // let lines = inp.split("\n") // // drop the end line and 2x whitespace // return { metadata, rest: rest.slice(2) } // } // // ================================================ FILE: client/src/hyperview.ts ================================================ import { type Request } from "./action"; export interface HyperView extends HTMLElement { runAction(action: string): Promise; activeRequest?: Request; cancelActiveRequest(): void; concurrency: ConcurrencyMode; _timeout?: number; } export const isHyperView = (ele: any): ele is HyperView => { return ele?.runAction !== undefined; }; export type ConcurrencyMode = string; export function dispatchContent(node: HTMLElement): void { let event = new Event("hyp-content", { bubbles: true }) node.dispatchEvent(event) } export function enrichHyperViews(node: HTMLElement, runAction: (target: HyperView, action: string, form?: FormData) => Promise): void { // enrich all the hyperviews node.querySelectorAll("[id]").forEach((element) => { element.runAction = function(action: string) { return runAction(element, action) } element.concurrency = element.dataset.concurrency || "Drop" element.cancelActiveRequest = function() { if (element.activeRequest && !element.activeRequest?.isCancelled) { element.activeRequest.isCancelled = true } } dispatchContent(node) }) } ================================================ FILE: client/src/index.ts ================================================ import { patch, create } from "omdomdom/lib/omdomdom.es.js" import { SocketConnection, Update, Redirect, Trigger, JSEvent } from './sockets' import { listenChange, listenClick, listenDblClick, listenFormSubmit, listenLoad, listenTopLevel, listenInput, listenKeydown, listenKeyup, listenMouseEnter, listenMouseLeave } from './events' import { actionMessage, newRequest } from './action' import { ViewId, Metadata, parseMetadata, RemoteEvent, EncodedAction } from './message' import { setQuery } from "./browser" import { parseResponse, LiveUpdate } from './response' import { dispatchContent, enrichHyperViews, HyperView, isHyperView } from "./hyperview" let PACKAGE = require('../package.json'); // console.log("VERSION 2", INIT_PAGE, INIT_STATE) console.log("Hyperbole " + PACKAGE.version + "b") let rootStyles: HTMLStyleElement; let addedRulesIndex = new Set(); // Run an action in a given HyperView async function runAction(target: HyperView, action: string, form?: FormData) { if (target.activeRequest && !target.activeRequest?.isCancelled) { // Active Request! if (target.concurrency == "Drop") { console.warn("Drop action overlapping with active request (" + target.activeRequest + ")", action) return } } target._timeout = window.setTimeout(() => { // add loading after 100ms, not right away // if it runs shorter than that we probably don't want to show the user any loading feedback target.classList.add("hyp-loading") }, 100) let state = target.dataset.state let req = newRequest() let msg = actionMessage(target.id, action, state, req.requestId, form) // Set the requestId target.activeRequest = req sock.sendAction(msg) } function handleTrigger(trigger: Trigger) { runTrigger(trigger.targetViewId, trigger.targetAction) } function handleEvent(ev: JSEvent) { let target = document.getElementById(ev.viewId) runRemoteEvent(ev.event, target) } // TODO: redirect concurrency function handleRedirect(red: Redirect) { console.log("REDIRECT", red) // the other metdata doesn't apply, they are all specific to the page applyCookies(red.meta.cookies ?? []) window.location.href = red.url } // in-process update function handleResponse(res: Update) { // console.log("Handle Response", res) let target = handleUpdate(res) if (!target) return // clean up the request delete target.activeRequest clearTimeout(target._timeout) target.classList.remove("hyp-loading") } function handleUpdate(res: Update): HyperView | undefined { // console.log("|UPDATE|", res) let targetViewId = res.targetViewId || res.viewId let target = document.getElementById(targetViewId) if (!isHyperView(target)) { console.error("Missing Update HyperView Target: ", targetViewId, res) return } if (target.activeRequest?.requestId && res.requestId < target.activeRequest.requestId) { // this should only happen on Replace, since other requests should be dropped // but it's safe to assume we never want to apply an old requestId console.warn("Ignore Stale Action (" + res.requestId + ") vs (" + target.activeRequest.requestId + "): " + res.action) return target } else if (target.activeRequest?.isCancelled) { console.warn("Cancelled request", target.activeRequest?.requestId) delete target.activeRequest return target } let update: LiveUpdate = parseResponse(res.body) if (!update.content) { console.error("Empty Response!", res.body) return target } // First, update the stylesheet addCSS(update.css) // Patch the node const old: VNode = create(target) let next: VNode = create(update.content) let atts = next.attributes if (!res.meta.error && atts["id"] != target.id) { console.error("Mismatched ViewId in update - ", atts["id"], " target:", target.id) return } let state = atts["data-state"] next.attributes = old.attributes patch(next, old) // Emit relevant events let newTarget = document.getElementById(target.id) if (!newTarget) { console.warn("Target Missing: ", target.id) return target } dispatchContent(newTarget) // re-add state attribute if (state === undefined || state == "()") delete newTarget.dataset.state else newTarget.dataset.state = state // execute the metadata, anything that doesn't interrupt the dom update runMetadata(res.meta, newTarget) applyCookies(res.meta.cookies ?? []) // now way for these to bubble) listenLoad(newTarget) listenMouseEnter(newTarget) listenMouseLeave(newTarget) fixInputs(newTarget) enrichHyperViews(newTarget, runAction) return target } // catch (err) { // console.error("Caught Error in HyperView (" + target.id + "):\n", err) // // // Hyperbole catches handler errors, and the server controls what to display to the user on an error // // but if you manage to crash your parent server process somehow, the response may be empty // target.innerHTML = err.body || "
Hyperbole Internal Error
" // } function applyCookies(cookies: string[]) { cookies.forEach((cookie: string) => { console.log("SetCookie: ", cookie) document.cookie = cookie }) } function runMetadata(meta: Metadata, target: HTMLElement | null) { if (meta.query != null) { setQuery(meta.query) } if (meta.pageTitle != null) { document.title = meta.pageTitle } meta.events?.forEach((remoteEvent) => { runRemoteEvent(remoteEvent, target) }) meta.actions?.forEach(([viewId, action]) => { runTrigger(viewId, action) }) } function runRemoteEvent(remoteEvent: RemoteEvent, target: HTMLElement | null) { setTimeout(() => { let event = new CustomEvent(remoteEvent.name, { bubbles: true, detail: remoteEvent.detail }) let eventTarget = target || document eventTarget.dispatchEvent(event) }, 10) } function runTrigger(viewId: ViewId, action: EncodedAction) { setTimeout(() => { let view = window.Hyperbole?.hyperView(viewId) if (view) { runAction(view, action) } }, 10) } function fixInputs(target: HTMLElement) { let focused = target.querySelector("[autofocus]") if (focused?.focus) { focused.focus() } target.querySelectorAll("input[value]").forEach((input) => { let val = input.getAttribute("value") if (val !== null) { input.value = val } }) target.querySelectorAll("input[type=checkbox]").forEach((checkbox) => { let checked = checkbox.dataset.checked == "True" checkbox.checked = checked }) } function addCSS(src: HTMLStyleElement | null) { if (!src) return; const rules = src.sheet?.cssRules if (!rules) return; for (let i = 0; i < rules.length; i++) { const rule = rules.item(i) if (rule && addedRulesIndex.has(rule.cssText) == false && rootStyles.sheet) { rootStyles.sheet.insertRule(rule.cssText); addedRulesIndex.add(rule.cssText); } } } function init() { // metadata attached to initial page loads need to be executed let meta = parseMetadata(document.getElementById("hyp.metadata")?.innerText ?? "") // runMetadataImmediate(meta) runMetadata(meta, null) const style = document.body.querySelector('style') if (style !== null) { rootStyles = style } else { console.warn("rootStyles missing from page, creating...") rootStyles = document.createElement("style") rootStyles.type = "text/css" document.body.appendChild(rootStyles) } listenTopLevel(async function(target: HyperView, action: string) { runAction(target, action) }) listenLoad(document.body) listenMouseEnter(document.body) listenMouseLeave(document.body) enrichHyperViews(document.body, runAction) listenClick(async function(target: HyperView, action: string) { // console.log("CLICK", target.id, action) runAction(target, action) }) listenDblClick(async function(target: HyperView, action: string) { // console.log("DBLCLICK", target.id, action) runAction(target, action) }) listenKeydown(async function(target: HyperView, action: string) { // console.log("KEYDOWN", target.id, action) runAction(target, action) }) listenKeyup(async function(target: HyperView, action: string) { // console.log("KEYUP", target.id, action) runAction(target, action) }) listenFormSubmit(async function(target: HyperView, action: string, form: FormData) { // console.log("FORM", target.id, action, form) runAction(target, action, form) }) listenChange(async function(target: HyperView, action: string) { runAction(target, action) }) function onStartedTyping(target: HyperView) { if (target.concurrency == "Replace") { target.cancelActiveRequest() } } listenInput(onStartedTyping, async function(target: HyperView, action: string) { runAction(target, action) }) } document.addEventListener("DOMContentLoaded", init) const sock = new SocketConnection() // Should we connect to the socket or not? sock.connect() sock.addEventListener("update", (ev: CustomEvent) => { handleUpdate(ev.detail) }) sock.addEventListener("response", (ev: CustomEvent) => handleResponse(ev.detail)) sock.addEventListener("redirect", (ev: CustomEvent) => handleRedirect(ev.detail)) sock.addEventListener("trigger", (ev: CustomEvent) => handleTrigger(ev.detail)) sock.addEventListener("event", (ev: CustomEvent) => handleEvent(ev.detail)) type VNode = { // One of three value types are used: // - The tag name of the element // - "text" if text node // - "comment" if comment node type: string // An object whose key/value pairs are the attribute // name and value, respectively attributes: { [key: string]: string | undefined } // Is set to `true` if a node is an `svg`, which tells // Omdomdom to treat it, and its children, as such isSVGContext: Boolean // The content of a "text" or "comment" node content: string // An array of virtual node children children: Array // The real DOM node node: Node } declare global { interface Window { Hyperbole?: HyperboleAPI; } interface DocumentEventMap { "hyp-load": CustomEvent; "hyp-mouseenter": CustomEvent; "hyp-mouseleave": CustomEvent; } } export interface HyperboleAPI { runAction(target: HTMLElement, action: string, form?: FormData): Promise action(con: string, ...params: any[]): string hyperView(viewId: ViewId): HyperView | undefined parseMetadata(input: string): Metadata socket: SocketConnection } window.Hyperbole = { runAction: runAction, parseMetadata: parseMetadata, action: function(con, ...params: any[]) { return params.reduce((str, param) => str + " " + JSON.stringify(param), con); }, hyperView: function(viewId) { let element = document.getElementById(viewId) if (!isHyperView(element)) { console.error("Element id=" + viewId + " was not a HyperView") return } return element }, socket: sock } ================================================ FILE: client/src/lib.ts ================================================ export function takeWhileMap(pred: (val: T) => A | undefined, lines: T[]): A[] { var output = [] for (var line of lines) { let a = pred(line) if (a) output.push(a) else break; } return output } export function dropWhile(pred: (val: T) => A | undefined, lines: T[]): T[] { let index = 0; while (index < lines.length && pred(lines[index])) { index++; } return lines.slice(index); } ================================================ FILE: client/src/message.ts ================================================ import { takeWhileMap, dropWhile } from "./lib" export type Meta = { key: string, value: string } export type ViewId = string export type RequestId = number export type EncodedAction = string export type ViewState = string export type RemoteEvent = { name: string, detail: unknown } export function renderMetas(meta: Meta[]): string { return meta.map(m => m.key + ": " + m.value).join('\n') } export type Metadata = { cookies?: string[] // redirect?: string error?: string query?: string events?: RemoteEvent[] actions?: [ViewId, EncodedAction][], pageTitle?: string } export function toMetadata(meta: Meta[]): Metadata { return { cookies: meta.filter(m => m.key == "Cookie").map(m => m.value), // redirect: metaValue("Redirect", meta), error: metaValue("Error", meta), query: metaValue("Query", meta), pageTitle: metaValue("PageTitle", meta), events: metaValuesAll("Event", meta).map(parseRemoteEvent), actions: metaValuesAll("Trigger", meta).map(parseAction), } } // viewId: meta.find(m => m.key == "VIEW-ID")?.value, export function parseMetadata(input: string): Metadata { let metas = takeWhileMap(parseMeta, input.trim().split("\n")) return toMetadata(metas) } export function metaValue(key: string, metas: Meta[]): string | undefined { return metas.find(m => m.key == key)?.value } export function metaValuesAll(key: string, metas: Meta[]): string[] { return metas.filter(m => m.key == key).map(m => m.value) } export type SplitMessage = { command: string, metas: Meta[], rest: string[] } export function splitMessage(message: string): SplitMessage { let lines = message.split("\n") let command: string = lines[0] let metas: Meta[] = takeWhileMap(parseMeta, lines.slice(1)) // console.log("Split Metadata", lines.length) // console.log(" [0]", lines[0]) // console.log(" [1]", lines[1]) let rest = dropWhile(l => l == "", lines.slice(metas.length + 1)) return { command, metas, rest } } export function parseMeta(line: string): Meta | undefined { let match = line.match(/^(\w+)\: (.*)$/) if (match) { return { key: match[1], value: match[2] } } } export function parseRemoteEvent(input: string): RemoteEvent { let [name, data] = breakNextSegment(input) return { name, detail: JSON.parse(data) } } export function parseAction(input: string): [ViewId, string] { let [viewId, action] = breakNextSegment(input) return [viewId, action] } function breakNextSegment(input: string): [string, string] { let ix = input.indexOf('|') if (ix === -1) { let err = new Error("Bad Encoding, Expected Segment") err.message = input throw err } return [input.slice(0, ix), input.slice(ix + 1)] } ================================================ FILE: client/src/response.ts ================================================ import { ViewId, Metadata } from './message' export type Response = { meta: Metadata body: ResponseBody } export type ResponseBody = string export function parseResponse(res: ResponseBody): LiveUpdate { const parser = new DOMParser() const doc = parser.parseFromString(res, 'text/html') const css = doc.querySelector("style") const content = doc.querySelector("div") return { content: content, css: css } } export type LiveUpdate = { content: HTMLElement | null css: HTMLStyleElement | null } export class FetchError extends Error { viewId: ViewId body: string constructor(viewId: ViewId, msg: string, body: string) { super(msg) this.viewId = viewId this.name = "Fetch Error" this.body = body } } ================================================ FILE: client/src/sockets.ts ================================================ import { ActionMessage, renderActionMessage } from './action' import { ResponseBody } from "./response" import * as message from "./message" import { ViewId, RequestId, EncodedAction, metaValue, Metadata, RemoteEvent } from "./message" const protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:'; const defaultAddress = `${protocol}//${window.location.host}${window.location.pathname}` interface SocketConnectionEventMap { "update": CustomEvent; "response": CustomEvent; "redirect": CustomEvent; "trigger": CustomEvent; "event": CustomEvent; } export class SocketConnection { socket: WebSocket hasEverConnected: Boolean = false isConnected: Boolean = false reconnectDelay: number = 0 queue: ActionMessage[] = [] events: EventTarget constructor(addr = defaultAddress) { this.events = new EventTarget() const sock = new WebSocket(addr) this.socket = sock } connect(addr = defaultAddress, createSocket = false) { const sock = createSocket ? new WebSocket(addr) : this.socket this.socket = sock function onConnectError(ev: Event) { console.error("Connect Error", ev) } function onSocketError(ev: Event) { console.error("Socket Error", ev) } // initial connection errors sock.addEventListener('error', onConnectError) sock.addEventListener('open', (_event) => { console.log("Websocket Connected") if (this.hasEverConnected) { document.dispatchEvent(new Event("hyp-socket-reconnect")) } this.isConnected = true this.hasEverConnected = true this.reconnectDelay = 1000 sock.removeEventListener('error', onConnectError) sock.addEventListener('error', onSocketError) document.dispatchEvent(new Event("hyp-socket-connect")) this.runQueue() }) sock.addEventListener('close', _ => { console.log("CLOSE SOCKET") if (this.isConnected) { document.dispatchEvent(new Event("hyp-socket-disconnect")) } this.isConnected = false sock.removeEventListener('error', onSocketError) // attempt to reconnect in 1s if (this.hasEverConnected) { console.log("Reconnecting in " + (this.reconnectDelay / 1000) + "s") setTimeout(() => this.connect(addr, true), this.reconnectDelay) } sock.removeEventListener('error', onSocketError) }) sock.addEventListener('message', ev => this.onMessage(ev)) } async sendAction(action: ActionMessage) { if (this.isConnected) { let msg = renderActionMessage(action) this.socket.send(msg) } else { this.queue.push(action) } } private runQueue() { // send all messages queued while disconnected let next: ActionMessage | undefined = this.queue.pop() if (next) { console.log("runQueue: ", next) this.sendAction(next) this.runQueue() } } // full responses will never be sent over! private onMessage(event: MessageEvent) { let { command, metas, rest } = message.splitMessage(event.data) // console.log("MESSAGE", command, metas, rest) let requestId = parseInt(requireMeta("RequestId"), 0) function requireMeta(key: string): string { let val = metaValue(key, metas) if (!val) throw new ProtocolError("Missing Required Metadata: " + key, event.data) return val } function parseResponse(rest: string[]): Update { let viewId = requireMeta("ViewId") let action = requireMeta("Action") return { requestId, targetViewId: undefined, viewId, action, meta: message.toMetadata(metas), body: rest.join("\n"), } } function parseUpdate(rest: string[]): Update { let up = parseResponse(rest) // add the TargetViewId up.targetViewId = metaValue("TargetViewId", metas) return up } function parseRedirect(rest: string[]): Redirect { let url = rest[0] return { requestId, meta: message.toMetadata(metas), url } } function parseTrigger(rest: string[]): Trigger { let { requestId, meta, viewId, action } = parseResponse(rest) let [targetViewId, targetAction] = message.parseAction(requireMeta("Trigger")) return { requestId, meta, viewId, action, targetViewId, targetAction } } function parseEvent(rest: string[]): JSEvent { let { requestId, meta, viewId, action } = parseResponse(rest) let event = message.parseRemoteEvent(requireMeta("Event")) return { requestId, meta, viewId, action, event } } switch (command) { case "|UPDATE|": return this.dispatchEvent(new CustomEvent("update", { detail: parseUpdate(rest) })) case "|RESPONSE|": return this.dispatchEvent(new CustomEvent("response", { detail: parseResponse(rest) })) case "|REDIRECT|": return this.dispatchEvent(new CustomEvent("redirect", { detail: parseRedirect(rest) })) case "|TRIGGER|": return this.dispatchEvent(new CustomEvent("trigger", { detail: parseTrigger(rest) })) case "|EVENT|": return this.dispatchEvent(new CustomEvent("event", { detail: parseEvent(rest) })) default: throw new ProtocolError("Unknown Server Command: " + command, event.data) } } // so what if they send remote events in the page? trigger, redirect, page title, etc... // we aren't connected yet on a page thing // private async waitMessage(reqId: RequestId, id: ViewId): Promise { // return new Promise((resolve, reject) => { // const onMessage = (event: MessageEvent) => { // let data: string = event.data // let lines = data.split("\n").slice(1) // drop the command line // // let parsed = splitMetadata(lines) // let metadata: Metadata = parsed.metadata // // if (!metadata.requestId) { // console.error("Missing RequestId!", metadata, event.data) // return // } // // if (metadata.requestId != reqId) { // // skip, it's not us! // return // } // // // // We have found our message. Remove the listener // this.socket.removeEventListener('message', onMessage) // // // set the cookies. These happen automatically in http // metadata.cookies.forEach((cookie: string) => { // document.cookie = cookie // }) // // if (metadata.error) { // reject(new FetchError(id, metadata.error, parsed.rest.join('\n'))) // return // } // // resolve(parsed) // } // // this.socket.addEventListener('message', onMessage) // this.socket.addEventListener('error', reject) // }) // } addEventListener(e: K, cb: (ev: SocketConnectionEventMap[K]) => void) { this.events.addEventListener(e, // @ts-ignore: HACK cb ) } dispatchEvent(e: SocketConnectionEventMap[K]) { this.events.dispatchEvent(e) } disconnect() { this.isConnected = false this.hasEverConnected = false this.socket.close() } } export type Update = { requestId: RequestId meta: Metadata viewId: ViewId targetViewId?: ViewId action: EncodedAction body: ResponseBody } export type Redirect = { requestId: RequestId meta: Metadata url: string } export type Trigger = { requestId: RequestId meta: Metadata viewId: ViewId action: EncodedAction targetViewId: ViewId targetAction: string } export type JSEvent = { requestId: RequestId meta: Metadata viewId: ViewId action: EncodedAction event: RemoteEvent } export type MessageType = string // PARSING MESSAGE --------------------------------------- export class ProtocolError extends Error { constructor(description: string, body: string) { super(description + "\n" + body) this.name = "ProtocolError" } } ================================================ FILE: client/tsconfig.json ================================================ { "compilerOptions": { "outDir": "./dist/", "sourceMap": true, "noImplicitAny": true, "module": "ES2020", "target": "ES2020", "lib": ["ES2020","DOM"], "allowJs": true, "moduleResolution": "node", "declaration": true, "strict": true // "skipLibCheck": true /*"declarationMap": true*/ }, "include": [ "./src/**/*", "./declarations.d.ts" ] } ================================================ FILE: client/util/live-reload.js ================================================ // This isn't magic. If you want custom behavior, copy and modify this however you like. // // As with any custom js, add to a single page via the `script` combinator // page = do // pure $ do // el "This is my page" // script "custom.js" // // or to the entire app by adding a script tag to your document function. See Example.App.toDocument // // Consider conditionally adding it based on ENV console.log("Live Reload enabled") function showNotification(message) { const notification = document.createElement('div'); notification.classList.add("live-reload") notification.innerHTML = message; jackIn(notification.style) notification.addEventListener('click', function() { notification.remove() }) document.body.appendChild(notification); } document.addEventListener("hyp-socket-disconnect", () => { showNotification("DISCONNECTED - will reload on reconnect") }) document.addEventListener("hyp-socket-reconnect", () => { setTimeout(() => { location.reload() }, 0) }) // duplicate cyber style stuff here so the default live reload is fun function jackIn(style) { style.position = 'fixed'; style.bottom = '15px'; style.left = '15px'; style.right = '15px'; style.backgroundColor = 'rgba(160, 63, 56, 1.0)'; style.color = '#fff'; style.borderTop = 'solid #EC6458 4px'; style.padding = '15px'; style.zIndex = '1000'; style.clipPath = 'polygon(0 0, 100% 0, 100% calc(100% - 16px), calc(100% - 16px) 100%, 0 100%)'; } ================================================ FILE: client/webpack.config.js ================================================ const path = require('path'); // var PACKAGE = require('./package.json'); // var version = PACKAGE.version; module.exports = { entry: "./src/index.ts", target: "web", devtool: "source-map", mode: "production", module: { rules: [ { test: /\.tsx?$/, use: 'ts-loader', exclude: /node_modules/, }, ], }, resolve: { mainFields: ['browser', 'module', 'main'], extensions: ['.tsx', '.ts', '.js'], }, output: { // filename: `hyperbole-${version}.js`, filename: "hyperbole.js", path: path.resolve(__dirname, 'dist'), }, // devServer: { // contentBase: path.join(__dirname, 'dist'), // compress: true, // port: 9000, // }, } ================================================ FILE: demo/.dockerignore ================================================ dist-newstyle .git ================================================ FILE: demo/App/Cache.hs ================================================ module App.Cache where import Network.HTTP.Types (Header) import Network.Wai.Middleware.Static clientCache :: IO Options clientCache = do container <- initCaching PublicStaticCaching -- container <- initCaching (CustomCaching customCache) pure $ defaultOptions{cacheContainer = container} -- for testing if caching is working customCache :: FileMeta -> [Header] customCache (FileMeta lm etag _file) = do [("Cache-Control", "no-transform,public,max-age=30"), ("Last-Modified", lm), ("Etag", etag)] ================================================ FILE: demo/App/Config.hs ================================================ {-# LANGUAGE QuasiQuotes #-} module App.Config where import Data.Maybe (fromMaybe, isNothing) import Effectful import Effectful.Environment import Effectful.Exception import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client.TLS qualified as HTTPS import Network.URI (parseURI) import Web.Hyperbole.Data.URI import Web.Hyperbole.Effect.OAuth2 (Config (..), Token (..)) import Web.Hyperbole.Effect.OAuth2 qualified as OAuth2 data App data AppConfig = AppConfig { endpoint :: Endpoint App , manager :: HTTP.Manager , oauth :: OAuth2.Config , devMode :: Bool } getAppConfigEnv :: (IOE :> es, Environment :> es) => Eff es AppConfig getAppConfigEnv = do endpoint <- lookupEnvEndpoint "APP_ENDPOINT" -- default to localhost manager <- HTTPS.newTlsManager pure $ AppConfig { endpoint = fromMaybe (Endpoint [uri|http://localhost:3000|]) endpoint , manager , oauth = dummyOAuthConfig , devMode = isNothing endpoint -- in dev mode if APP_ENDPOINT is not set (localhost) } type Key = String data ConfigError = BadEnv Key deriving (Show, Exception) lookupEnvEndpoint :: (Environment :> es) => Key -> Eff es (Maybe (Endpoint a)) lookupEnvEndpoint k = do mstr <- lookupEnv k pure $ parseEndpoint mstr where parseEndpoint mstr = do input <- mstr url <- parseURI input pure $ Endpoint url -- In a real app this would be read from ENV. See OAuth2.initConfigEnv dummyOAuthConfig :: OAuth2.Config dummyOAuthConfig = Config { clientId = Token "dummy client id" , clientSecret = Token "dummy client secret" , authorize = Endpoint [uri|https://oauth-mock.mock.beeceptor.com/oauth/authorize|] , token = Endpoint [uri|https://oauth-mock.mock.beeceptor.com/oauth/token/github|] } ================================================ FILE: demo/App/Docs/Markdown.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} module App.Docs.Markdown ( markdocs , markdump , nodeToView , embedFile ) where import App.Docs.Snippet import App.Route import CMark import Data.Char (isSpace) import Data.Set import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Example.Colors (magenta) import Example.Style qualified as Style import Example.Style.Cyber qualified as Cyber import Language.Haskell.TH import Language.Haskell.TH.Syntax import Web.Atomic.CSS import Web.Hyperbole.Data.URI import Web.Hyperbole.HyperView.Input (route) import Web.Hyperbole.Route import Web.Hyperbole.View markdocs :: Text -> View c () markdocs md = do nodeToView $ commonmarkToNode [] $ cs md markdump :: Text -> View c () markdump md = do code $ cs $ show $ commonmarkToNode [] $ cs md nodeToView :: Node -> View c () nodeToView (Node _mpos typ childs) = do let inner = mapM_ nodeToView childs case typ of -- DOCUMENT -> mapM nodeToView childs -- THEMATIC_BREAK -> _ -- PARAGRAPH -> _ -- BLOCK_QUOTE -> _ -- HTML_BLOCK Text -> _ -- CUSTOM_BLOCK OnEnter OnExit -> _ -- CODE_BLOCK Info Text -> _ -- HEADING Level -> _ -- LIST ListAttributes -> _ -- ITEM -> _ -- TEXT Text -> _ -- SOFTBREAK -> _ -- LINEBREAK -> _ -- HTML_INLINE Text -> _ -- CUSTOM_INLINE OnEnter OnExit -> _ -- CODE Text -> _ -- EMPH -> _ -- STRONG -> _ -- LINK url title -> _ -- IMAGE url title -> _ PARAGRAPH -> el inner TEXT t -> text t CODE t -> do inlineCode t HEADING lvl -> el ~ bold . headerLevel lvl $ inner LINK url _title -> case matchRoute @AppRoute (path url) of Nothing -> do case parseURIReference (cs url) of Nothing -> text $ "INVALID URI: " <> url Just u -> link u ~ Style.link @ att "target" "_blank" $ inner Just r -> route r ~ Style.link $ inner LIST (ListAttributes ORDERED_LIST _ _ _) -> tag "ol" ~ list Decimal . pad (L 32) $ inner LIST (ListAttributes BULLET_LIST _ _ _) -> tag "ul" ~ list Disc . pad (L 32) $ inner ITEM -> tag "li" inner DOCUMENT -> inner CODE_BLOCK _info t -> snippet $ raw t BLOCK_QUOTE -> el ~ Cyber.quote $ inner HTML_BLOCK t -> raw t SOFTBREAK -> inner EMPH -> tag' True "span" ~ italic $ inner STRONG -> tag' True "span" ~ bold $ inner x -> -- inner raw $ cs $ show x where headerLevel lvl = case lvl of 1 -> fontSize 24 2 -> fontSize 20 _ -> fontSize 16 hackageDocsURI :: URI hackageDocsURI = [uri|https://hackage-content.haskell.org/package/hyperbole/docs/Web-Hyperbole.html|] inlineCode :: Text -> View c () inlineCode cd | cd `elem` typeKeywords = linkSymbolDocs cd typeFrag ~ color hackageSymbolColor | cd `elem` valueKeywords = linkSymbolDocs cd valFrag ~ color hackageSymbolColor | otherwise = tag' True "code" ~ color magenta $ text cd where typeFrag t = "#t:" <> cs t valFrag v = "#v:" <> cs v hackageSymbolColor :: HexColor hackageSymbolColor = "#9e358f" linkSymbolDocs :: Text -> (Text -> String) -> View c () linkSymbolDocs sym frag = do link (hackageDocsURI{uriFragment = frag sym}) @ att "target" "_blank" $ do tag' True "code" $ text sym typeKeywords :: Set Text typeKeywords = [ "Page" , "View" , "HyperView" , "ViewId" , "ViewAction" , "ViewState" , "Action" , "Hyperbole" , "Effect" , "Query" , "Session" , "Require" , "Client" , "Request" , "Document" , "Path" , "Route" , "Eff" , "Page" , "Response" , "FromForm" , "Validated" , "Concurrency" , "Replace" , "Drop" ] valueKeywords :: Set Text valueKeywords = [ "context" , "update" , "form" , "validate" , "hyper" , "request" , "viewId" , "viewState" , "trigger" , "target" , "hyperState" , "runPage" , "document" , "routeRequest" , "matchRoute" , "liveApp" , "pushUpdate" , "onLoad" , "session" , "query" , "setQuery" , "setParam" , "param" , "modifyQuery" , "saveSession" , "deleteSession" , "quickStartDocument" , "search" , "loading" , "whenLoading" , "dropdown" , "option" , "button" , "onClick" , "onKeyDown" , "onKeyUp" , "onMouseEnter" , "onMouseLeave" , "onInput" ] embedFile :: FilePath -> Q Exp embedFile p = do addDependentFile p lns :: [Text] <- runIO $ T.lines <$> T.readFile p exps :: [Exp] <- traverse expandLine lns e :: Exp <- listE (fmap pure exps) [|T.unlines $(pure e)|] expandLine :: Text -> Q Exp expandLine l = do let whitespace = T.takeWhile isSpace l case parseLineEmbed l of Just (mn, tld) -> do e <- embedSource' mn (isTopLevel tld) (isCurrentDefinition tld) [|T.stripEnd $ T.unlines $ fmap (whitespace <>) $(pure e)|] Nothing -> do t <- expandText l lift t expandText :: (MonadFail m) => Text -> m Text expandText t = do let segs = T.splitOn "[[" t es :: [Text] <- mapM checkLink segs pure $ mconcat es where checkLink :: (MonadFail m) => Text -> m Text checkLink l = do case T.breakOn "]]" l of (txt, "") -> pure txt (lnk, rest) -> do mdlnk <- routeLink lnk pure $ mdlnk <> T.dropWhile (== ']') rest routeLink :: (MonadFail m) => Text -> m Text routeLink l = case matchRoute @AppRoute (path l) of Nothing -> error $ "Could not find page link: " <> cs l <> " " <> show (path l) Just r -> pure $ "[" <> routeTitle r <> "](" <> uriToText (routeUri r) <> ")" ================================================ FILE: demo/App/Docs/Page.hs ================================================ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} module App.Docs.Page ( PageAnchor (..) , sourceLink , example , example' , section , section' , camelTitle , Cyber.embed , Cyber.quote ) where import App.Docs.Snippet (ModuleSource (..)) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T import Example.Colors (AppColor (..)) import Example.Style qualified as Style import Example.Style.Cyber qualified as Cyber import Text.Casing (fromHumps, toWords) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Data.URI class PageAnchor n where pageAnchor :: n -> Text default pageAnchor :: n -> Text pageAnchor = T.toLower . T.replace " " "-" . sectionTitle sectionTitle :: n -> Text default sectionTitle :: (Show n) => n -> Text sectionTitle = camelTitle navEntry :: n -> Text default navEntry :: n -> Text navEntry = sectionTitle subnav :: [n] default subnav :: (Enum n, Bounded n) => [n] subnav = [minBound .. maxBound] instance PageAnchor () where subnav = [] camelTitle :: (Show a) => a -> Text camelTitle = cs . toWords . fromHumps . show -- Sections ---------------------------------------------------------------------- sourceLink :: Path -> View c () sourceLink p = link sourceUrl ~ fontSize 14 @ att "target" "_blank" $ do text " Source" where sourceUrlBase = [uri|https://github.com/seanhess/hyperbole/blob/main/demo/|] sourceUrl = sourceUrlBase ./. p example :: ModuleSource -> View c () -> View c () example (ModuleSource e) = example' (path $ cs e) example' :: Path -> View c () -> View c () example' p cnt = do el ~ stack . Cyber.font $ do col ~ Cyber.embed $ cnt sourceLink p ~ popup (TR (-10) 0) . pad (XY 8 2) . bg PrimaryLight . color White . hover (bg Primary) -- . pad (TRBL 0 20 0 10) . border (L 3) . borderColor PrimaryLight . Cyber.clip 10 -- section :: AppRoute -> View c () -> View c () -- section r = section' (routeTitle r) section' :: Text -> View c () -> View c () section' t cnt = do tag "section" ~ gap 10 . flexCol $ do row $ do el ~ bold . fontSize 28 . Cyber.font . Style.uppercase $ text t cnt section :: (PageAnchor n) => n -> View c () -> View c () section n = section' (sectionTitle n) @ att "id" (pageAnchor n) -- type Fragment = String -- -- hackage :: Fragment -> Text -> View c () -- hackage uriFragment txt = do -- let docs = [uri|https://hackage-content.haskell.org/package/hyperbole/docs/Web-Hyperbole.html|] -- link docs{uriFragment} @ att "target" "_blank" ~ Style.link $ do -- el ~ iconInline $ do -- Icon.bookOpen -- text txt ================================================ FILE: demo/App/Docs/Snippet.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Docs.Snippet where import Control.Monad (unless) import Data.Char (isSpace) import Data.List qualified as L import Data.String (IsString) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Language.Haskell.TH import Language.Haskell.TH.Syntax import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (normalise, ()) import Web.Atomic.CSS import Web.Hyperbole.View snippet :: View c () -> View c () snippet cnt = do tag' True "pre" ~ bg (HexColor "#F2F2F3") $ do tag' True "code" @ class_ "language-haskell" $ do cnt codeblock :: Text -> View c () codeblock t = tag' True "pre" ~ monoline $ do tag' True "code" $ do raw t where monoline = utility "monoline" [ "line-height" :. "1" ] rawMulti :: [Text] -> View c () rawMulti = raw . T.stripEnd . T.unlines embedLines :: FilePath -> Int -> Int -> Q Exp embedLines path start end = do addDependentFile path contents <- runIO (T.readFile path) let selected = T.unlines . take (end - start + 1) . drop (start - 1) . T.lines $ contents lift (T.unpack selected) newtype TopLevelDefinition = TopLevelDefinition Text deriving newtype (Show, Eq, IsString) newtype SourceCode = SourceCode {lines :: [Text]} newtype ModuleName = ModuleName Text deriving newtype (Show, Eq, IsString) modulePath :: ModuleName -> FilePath modulePath (ModuleName mn) = cs $ "demo/" <> T.replace "." "/" mn <> ".hs" {- | A top-level definition as text > snippet $(topLevel "demo/Example/Page/Concurrency.hs" "instance (Debug :> es) => HyperView Polling") -} embedTopLevel :: ModuleName -> TopLevelDefinition -> Q Exp embedTopLevel mn tld = do embedSource mn (isTopLevel tld) (isCurrentDefinition tld) embedSource :: ModuleName -> (Text -> Bool) -> (Text -> Bool) -> Q Exp embedSource mn isStart isCurrent = do e <- embedSource' mn isStart isCurrent [|T.unlines $(pure e)|] embedSource' :: ModuleName -> (Text -> Bool) -> (Text -> Bool) -> Q Exp embedSource' mn isStart isCurrent = do path <- runIO $ localFile $ modulePath mn addDependentFile path s <- runIO $ readSourceCode path let lns = selectLines isStart isCurrent s case lns of [] -> fail $ "Missing embed in: " ++ show mn _ -> lift lns readSnippet :: FilePath -> TopLevelDefinition -> IO [Text] readSnippet path tld = do s <- readSourceCode path pure $ findTopLevel tld s readSourceCode :: FilePath -> IO SourceCode readSourceCode path = SourceCode . T.lines <$> T.readFile path -- returns lines of a top-level definition findTopLevel :: TopLevelDefinition -> SourceCode -> [Text] findTopLevel tld = selectLines (isTopLevel tld) (isCurrentDefinition tld) -- isBlankLine line = T.null $ T.strip line isCurrentDefinition :: TopLevelDefinition -> Text -> Bool isCurrentDefinition tld line = isTopLevel tld line || not (isFullyOutdented line) isTopLevel :: TopLevelDefinition -> Text -> Bool isTopLevel (TopLevelDefinition def) line = if "^" `T.isPrefixOf` def then T.isPrefixOf (T.drop 1 def) line else T.isPrefixOf def $ T.dropWhile (== ' ') line selectLines :: (Text -> Bool) -> (Text -> Bool) -> SourceCode -> [Text] selectLines isStart isCurrent s = let rest = dropWhile (not . isStart) s.lines in dropWhileEnd isEmpty $ takeWhile isCurrent rest where isEmpty = T.null dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p as = reverse $ dropWhile p $ reverse as isFullyOutdented :: Text -> Bool isFullyOutdented line = case cs (T.take 1 line) of "" -> False [c] -> not $ isSpace c _ -> False -- #EMBED Example.Docs.Interactive instance HyperView Titler parseLineEmbed :: Text -> Maybe (ModuleName, TopLevelDefinition) parseLineEmbed l = do rest <- T.stripPrefix "#EMBED " (T.stripStart l) (mn : tld) <- pure $ T.words rest pure (ModuleName mn, TopLevelDefinition $ T.unwords tld) -- start with a relative OR absolute path, end up with a path to the file -- works with any working directory localFile :: FilePath -> IO FilePath localFile p = do current <- getCurrentDirectory let lpath = addRelativeDemo current $ stripDir "demo" $ stripDir current p b <- doesFileExist lpath unless b $ do fail $ "Could not find file: " <> show lpath <> " in working dir: " <> current pure lpath where addRelativeDemo wd rp | "demo" `L.isSuffixOf` wd = rp | otherwise = "demo" rp stripDir :: FilePath -> FilePath -> FilePath stripDir dir p = maybe p (dropWhile (== '/')) (L.stripPrefix dir p) newtype ModuleSource = ModuleSource FilePath deriving newtype (Show, Eq, IsString) moduleSource :: Q Exp moduleSource = do loc <- location let path = normalise $ loc_filename loc fp <- runIO $ localFile path lift fp moduleSourceNamed :: ModuleName -> Q Exp moduleSourceNamed mn = do fp <- runIO $ localFile $ modulePath mn lift fp ================================================ FILE: demo/App/Docs.hs ================================================ module App.Docs ( module App.Docs.Markdown , module App.Docs.Page , module App.Docs.Snippet ) where import App.Docs.Markdown import App.Docs.Page import App.Docs.Snippet ================================================ FILE: demo/App/Page/Application.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module App.Page.Application where import App.Docs import App.Route (AppRoute (Application)) import Effectful import Example.CSS.External qualified as External import Example.CSS.Transitions as Transitions import Example.Interactivity.Events as Events import Example.View.Layout import Web.Hyperbole data Sections = LiveApp | Document | Pages | TypeSafeRoutes | RunningEffects deriving (Eq, Generic, Show, Enum, Bounded, PageAnchor) page :: (Hyperbole :> es) => Page es '[Animate, External.Items, Boxes] page = do pure $ layoutSubnav @Sections Application $ do section LiveApp $ do markdocs $(embedFile "docs/app-live.md") section Document $ do markdocs $(embedFile "docs/app-document.md") section Pages $ do -- markdocs $(embedFile "docs/app-pages.md") section TypeSafeRoutes $ do markdocs $(embedFile "docs/app-routes.md") section RunningEffects $ do markdocs $(embedFile "docs/app-effects.md") ================================================ FILE: demo/App/Page/CSS.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module App.Page.CSS where import App.Docs import App.Route (AppRoute (CSS)) import Effectful import Example.CSS.External qualified as External import Example.CSS.Loading as Loading import Example.CSS.Tooltips as Tooltips import Example.CSS.Transitions as Transitions import Example.Docs.CSS qualified as CSS import Example.Interactivity.Events as Events import Example.View.Layout import Example.View.Loader as Loader import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.HyperView.Types (Root (..)) import Web.Hyperbole.Page (subPage) data CSSExample = Factoring | Transitions | Tooltips | Loading | External deriving (Eq, Generic, Show, Enum, Bounded) instance PageAnchor CSSExample where sectionTitle = \case Factoring -> "Atomic CSS" Transitions -> "CSS Transitions" Tooltips -> "Tooltips" Loading -> "Loading" External -> "External Stylesheets" page :: (Hyperbole :> es) => Page es '[Animate, External.Items, Boxes, Loader] page = do ext <- subPage External.page pure $ layoutSubnav @CSSExample CSS $ do style Loader.css section Factoring $ do markdocs $(embedFile "docs/atomic.md") CSS.example ~ embed section Transitions $ do markdocs "If an update changes the `transition` property of a view, it will automatically animate with CSS Transitions, avoiding having the server compute animation frames." snippet $ do raw $(embedTopLevel "Example.CSS.Transitions" "viewSmall") raw "\n" raw $(embedTopLevel "Example.CSS.Transitions" "viewBig") example Transitions.source $ hyper Animate viewSmall section Tooltips $ do markdocs "For immediate feedback, create interactivity via Atomic CSS whenever possible." example Tooltips.source tooltips section Loading $ do markdocs "Use `whenLoading` to provide feedback while an `Action` is being processed" snippet $ do raw $(embedTopLevel "Example.CSS.Loading" "viewLoaders") example $(moduleSourceNamed "Example.CSS.Loading") $ do hyper Loader $ viewLoaders "..." section External $ do markdocs "You can opt-out of Atomic CSS and use external classes with `class_`" snippet $ do raw $(embedTopLevel "Example.CSS.External" "page") snippet $ do raw $(embedTopLevel "Example.CSS.External" "itemsView") example External.source $ do runViewContext Root () ext ================================================ FILE: demo/App/Page/Concurrency.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module App.Page.Concurrency where import App.Docs import App.Route qualified as Route import Control.Monad (forM_) import Effectful import Example.Concurrency.LazyLoading as Lazy import Example.Concurrency.Overlap as Overlap import Example.Concurrency.Polling as Polling import Example.Concurrency.Progress as Progress import Example.Concurrency.Tasks import Example.Effects.Debug import Example.Push qualified as Push import Example.Style.Cyber (btn, font) import Example.View.Layout (layoutSubnav) import Example.View.Loader as Loader import Web.Atomic.CSS import Web.Hyperbole data Section = Concurrency | OverlappingRequests | LazyLoading | Polling | PushUpdates deriving (Show, Eq, Enum, Bounded, PageAnchor) page :: (Hyperbole :> es, Debug :> es) => Page es '[Poller, LazyData, Progress, Push.Tasks, OverlapDrop, OverlapReplace, LazyAll] page = do pure $ layoutSubnav @Section Route.Concurrency $ do style Loader.css section Concurrency $ do markdocs "While individual `HyperView`s can only have one update in progress at a time, multiple `HyperView`s can overlap updates without issue" example Progress.source ~ font $ do hyper (Progress 1) $ viewProgressLoad 6 hyper (Progress 2) $ viewProgressLoad 4 hyper (Progress 3) $ viewProgressLoad 2 -- hyper (Progress 4 200) viewProgressLoad -- hyper (Progress 5 250) viewProgressLoad section OverlappingRequests $ do markdocs $(embedFile "docs/concurrency-overlap.md") example $(moduleSourceNamed "Example.Concurrency.Overlap") $ do hyper OverlapDrop $ viewTimeDrop Nothing hyper OverlapReplace $ viewTimeReplace Nothing section LazyLoading $ do markdocs "Instead of preloading everything in our `Page`, a `HyperView` can load itself using `onLoad`" snippet $ raw $(embedTopLevel "Example.Concurrency.LazyLoading" "viewTaskLoad") example Lazy.source $ do hyper LazyAll viewLazyAll section Polling $ do markdocs "By including an `onLoad` in every view update, we can poll the server after a given delay" snippet $ raw $(embedTopLevel "Example.Concurrency.Polling" "viewPoll") example Polling.source $ do hyper Poller viewInit section PushUpdates $ do markdocs "Actions can call `pushUpdate` to send an intermediate update to the view. This can be simpler than polling." snippet $ raw $(embedTopLevel "Example.Push" "update") example Push.source $ do hyper Push.Tasks $ Push.taskView 0 data LazyAll = LazyAll deriving (Generic, ViewId) instance HyperView LazyAll es where data Action LazyAll = ReloadAll deriving (Generic, ViewAction) type Require LazyAll = '[LazyData] update _ = do pure viewLazyAll viewLazyAll :: View LazyAll () viewLazyAll = do col ~ gap 10 $ do row ~ flexWrap Wrap . font . gap 10 $ do forM_ pretendTasks $ \taskId -> do el ~ border 1 . width 120 . pad 5 $ do hyper (LazyData taskId) viewTaskLoad row $ button ReloadAll ~ btn $ "Reload" ================================================ FILE: demo/App/Page/Examples.hs ================================================ module App.Page.Examples where import App.Docs import App.Route as Route import Example.Style as Style (link) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[] page = do pure $ layout (Examples OtherExamples) $ do section' "Data Lists" $ do col ~ gap 10 $ do card (Data SortableTable) "Sort by column, demonstrates view functions" card (Data Autocomplete) "Incremental search using only hyperbole" card (Data Filter) "Faceted search, live filtering of lists " card (Data LoadMore) "Progressively load more items" section' "UI Demos" $ do col ~ gap 10 $ do card (Examples Tags) $ markdocs "Add and remove \"tags\" with an ``" card (Examples Chat) "Demonstrates server pushes and concurrency. Open in multiple tabs" card (Examples Scrollbars) "Layouts with internal scrollbars" section' "Other Features" $ do card (Examples OAuth2) "Demonstration of OAuth2" section' "Reference Implementations" $ do card (Examples Todos) "using Atomic CSS" card (Examples TodosCSS) "using external classes" where card r cnt = do row ~ gap 5 $ do route r ~ Style.link $ do text $ routeTitle r el $ text "-" el cnt -- cardBtn :: (Styleable h) => CSS h -> CSS h -- cardBtn = -- bgAnimated -- . bgGradient White -- . hover bgzero -- . clip 10 -- . shadow () -- -- grid :: (Styleable h) => CSS h -> CSS h -- grid = -- utility -- "grid-ex" -- [ "display" :. "grid" -- , "grid-template-columns" :. "repeat(auto-fit, minmax(200px, 1fr))" -- ] -- -- tile :: (Styleable h) => CSS h -> CSS h -- tile = -- utility -- "tile" -- [ "aspect-ratio" :. "16 / 9" -- ] -- section Effectful $ do -- markdocs $(embedFile "docs/effectful.md") -- example SideEffects.source $ do -- hyper Titler titleView -- -- section Other $ do -- markdocs $(embedFile "docs/effects-other.md") -- example SideEffects.source $ do -- hyper SlowReader $ messageView "..." -- -- section Custom $ do -- markdocs $(embedFile "docs/effects-custom.md") ================================================ FILE: demo/App/Page/Forms.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Page.Forms where import App.Docs import App.Route import Example.FormSimple (AddContact (..)) import Example.FormSimple qualified as FormSimple import Example.FormValidation (Signup (..)) import Example.FormValidation qualified as FormValidation import Example.View.Layout import Web.Hyperbole data Sections = BasicForms | Validation deriving (Generic, Show, Bounded, Enum, PageAnchor) page :: (Hyperbole :> es) => Page es '[Signup, AddContact] page = do pure $ layoutSubnav @Sections (Forms FormSimple) $ do section BasicForms $ do markdocs $(embedFile "docs/forms-simple.md") example FormSimple.source $ do hyper AddContact FormSimple.formView' section Validation $ do markdocs $(embedFile "docs/forms-validated.md") example FormValidation.source $ do -- hyper Signup $ FormValidation.formView genFields ================================================ FILE: demo/App/Page/HyperboleEffect.hs ================================================ module App.Page.HyperboleEffect where import App.Route as Route hiding (Response, UserId) import App.Docs import Effectful import Example.Errors (Errors (..), Users (..), viewCustom, viewExceptions, viewKnownUsers, viewSearchUsers) import Example.Errors qualified as Errors import Example.Requests (CheckRequest (..), ControlClient (..), ControlResponse (..)) import Example.Requests qualified as Requests import Example.View.Layout (layoutSubnav) import Web.Hyperbole hiding (Response) data Sections = Requests | Response | ExceptionHandling | EdgeCases | HandleInViews | CustomErrorViews deriving (Show, Enum, Bounded, PageAnchor) page :: (Hyperbole :> es) => Page es '[CheckRequest, ControlResponse, ControlClient, Errors, Users] page = do r <- request pure $ layoutSubnav @Sections Route.HyperboleEffect $ do section Requests $ do markdocs "The `Hyperbole` `Effect` allows us to skip the normal update cycle to directly access the `Request` or manipulate the `Client`" example Requests.source $ do hyper CheckRequest $ Requests.viewRequest r example Requests.source $ do hyper ControlClient Requests.viewClient section Response $ do el "It also allows us to directly affect the response and the javascript client" example Requests.source $ hyper ControlResponse Requests.responseView section ExceptionHandling $ do el "Any uncaught exceptions thrown from a handler will be displayed in a bright red box inline in the corresponding HyperView" example Errors.source $ do hyper Exceptions viewExceptions section EdgeCases $ do el "You can use the same mechanism to exit execution early and display an application error to handle edge cases" example Errors.source $ do hyper KnownUsers viewKnownUsers section HandleInViews $ do el "Handle any expected errors in your view function, by making it accept a Maybe or Either" example Errors.source $ do hyper SearchUsers viewSearchUsers section CustomErrorViews $ do el "You can also exit execution early and display a custom view from application code or from caught execptions" example Errors.source $ do hyper Customs viewCustom ================================================ FILE: demo/App/Page/Hyperviews.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Page.Hyperviews where import App.Docs import App.Route qualified as Route (AppRoute (..)) import Example.Counter (Counter (..)) import Example.Docs.MultiView qualified as Multi import Example.Docs.Nesting qualified as Nesting import Example.Docs.UniqueViewId qualified as UniqueViewId import Example.Push as Push import Example.Simple (Message (..)) import Example.Trigger as Trigger import Example.View.Layout (layoutSubnav) import Web.Hyperbole import Web.Hyperbole.HyperView.Types (Root (..)) import Web.Hyperbole.Page (subPage) data HyperSectuions = IndependentUpdates | UniqueViewid | Nesting | TargetingOtherHyperviews deriving (Show, Enum, Bounded, PageAnchor) page :: (Hyperbole :> es) => Page es '[Counter, Message, UniqueViewId.Item, Nesting.ItemList, Targeted, Controls, Tasks] page = do mlt <- subPage Multi.page uvd <- subPage UniqueViewId.page nst <- subPage Nesting.page pure $ layoutSubnav @HyperSectuions Route.Hyperviews $ do section IndependentUpdates $ do markdocs $(embedFile "docs/hyperviews-multi.md") example $(moduleSourceNamed "Example.Docs.MultiView") $ do runViewContext Root () mlt section UniqueViewid $ do markdocs $(embedFile "docs/hyperviews-unique.md") example $(moduleSourceNamed "Example.Docs.UniqueViewId") $ do runViewContext Root () uvd section Nesting $ do markdocs $(embedFile "docs/hyperviews-nesting.md") example $(moduleSourceNamed "Example.Docs.Nesting") $ do runViewContext Root () nst section TargetingOtherHyperviews $ do markdocs "Sometimes nesting isn't enough, and we need to directly communicate to other `HyperView`s. Below, we have an independent `HyperView` which displays a message, and two ways to control it:" example Trigger.source $ do hyper Targeted $ targetedView "..." markdocs "Use `trigger` to tell another `HyperView` to run an action" snippet $ do raw $(embedTopLevel "Example.Trigger" "instance HyperView Controls") example Trigger.source $ do hyper Controls controlView markdocs "You can use `target` in a `View` to use `Action`s from another `HyperView`" snippet $ do raw $(embedTopLevel "Example.Trigger" "targetView") example Trigger.source $ do hyper Controls targetView markdocs "Alternatively, you can use `pushUpdate` to directly update another view:" example Push.source $ do hyper Tasks $ taskView 0 ================================================ FILE: demo/App/Page/Interactivity.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Page.Interactivity where import App.Docs import App.Route hiding (Javascript) import Example.Interactivity.Events import Example.Interactivity.Inputs import Example.Javascript as Javascript import Example.View.Layout import Web.Hyperbole data Sections = Inputs | Events | Javascript deriving (Show, Bounded, Enum, PageAnchor) page :: (Hyperbole :> es) => Page es '[Boxes, JBoxes, Message, TryEvents, Dropper] page = do pure $ layoutSubnav @Sections Interactivity $ do -- NOTE: only include javascript on the pages you need it script "custom.js" section Inputs $ do markdocs $(embedFile "docs/interactivity-inputs.md") example $(moduleSourceNamed "Example.Interactivity.Inputs") $ hyper Dropper (selectPlanet Nothing) section Events $ do markdocs $(embedFile "docs/interactivity-events.md") example $(moduleSourceNamed "Example.Interactivity.Events") $ hyper TryEvents (viewEvents "") markdocs $(embedFile "docs/interactivity-events2.md") example $(moduleSourceNamed "Example.Interactivity.Events") $ hyper Boxes (viewBoxes Nothing) section Javascript $ do markdocs $(embedFile "docs/interactivity-javascript.md") example Javascript.source $ do hyper JBoxes $ viewJBoxes Nothing markdocs $(embedFile "docs/interactivity-pushevent.md") example Javascript.source $ do hyper Message viewMessage ================================================ FILE: demo/App/Page/Intro/Basics.hs ================================================ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module App.Page.Intro.Basics where import App.Docs import App.Route import Data.String.Interpolate (i) import Example.Counter (Counter) import Example.Docs.Interactive qualified as Interactive import Example.Docs.ViewFunctions qualified as ViewFunctions import Example.Simple as Simple import Example.View.Layout (layoutSubnav) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.HyperView.Types (Root (..)) import Web.Hyperbole.Page (subPage) data Basics = GetRunning | HtmlViews | Interactive deriving (Show, Enum, Bounded) instance PageAnchor Basics where sectionTitle Interactive = "Interactive HyperViews" sectionTitle a = camelTitle a navEntry Interactive = "HyperViews" navEntry a = sectionTitle a page :: (Hyperbole :> es) => Page es '[Message, Counter, ViewFunctions.Message] page = do int <- subPage Interactive.page -- mlt <- subPage Multi.page pure $ layoutSubnav @Basics Basics $ do section GetRunning getRunning section HtmlViews htmlViews -- section Styles $ do -- markdocs $(embedFile "docs/atomic.md") -- CSS.example ~ embed -- markdocs "See [Styles](/css) for more info" section Interactive $ do markdocs $(embedFile "docs/hyperviews-intro.md") example $(moduleSourceNamed "Example.Simple") $ do runViewContext Root () int where getRunning = do markdocs "Hyperbole applications are divided into top-level `Page`s, which run side effects, then return an HTML `View`" snippet $ raw $ $(embedTopLevel "Example.Docs.BasicPage" "hello") markdocs "Run an Application via [Warp](https://hackage.haskell.org/package/warp) and [WAI](https://hackage.haskell.org/package/wai). This runs on port 3000 and responds to everything with \"Hello World\"" snippet $ do raw $ $(embedTopLevel "Example.Docs.BasicPage" "main") col ~ embed $ do "Hello World" htmlViews = do markdocs "`View`s are HTML fragments with a `context`" snippet $ raw $ $(embedTopLevel "Example.Docs.BasicPage" "helloWorld") -- WARNING: this doesn't render properly when embedded in markdown snippet $ text [i|>>> renderText helloWorld "
Hello World
"|] markdocs "We can factor `View`s into reusable functions:" snippet $ do rawMulti [ $(embedTopLevel "Example.Docs.BasicPage" "messageView") , $(embedTopLevel "Example.Docs.BasicPage" "page") ] col ~ embed $ do "Hello World" markdocs "Using [atomic-css](/css) we can use functions to factor styles as well" ================================================ FILE: demo/App/Page/Intro/Intro.hs ================================================ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module App.Page.Intro.Intro where import App.Docs import App.Route import Data.String.Interpolate (i) import Example.Colors import Example.Counter (Counter) import Example.Simple (Message) import Example.Simple qualified as Simple import Example.Style.Cyber qualified as Cyber import Example.View.Layout (layout) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.HyperView.Types import Web.Hyperbole.Page (subPage) page :: (Hyperbole :> es) => Page es '[Message, Counter] page = do simple <- subPage Simple.page pure $ layout Intro $ do col ~ gap 20 $ do row ~ color cyan . bg Dark . pad 20 $ do space col ~ gap 10 . overflow Hidden $ do row $ do space codeblock ~ scaleText $ do [i|╔═════════════════════════════════════════════════════════════════════════════╗ ║ ║ ║ ██╗ ██╗██╗ ██╗██████╗ ███████╗██████╗ ██████╗ ██████╗ ██╗ ███████╗ ║ ║ ██║ ██║╚██╗ ██╔╝██╔══██╗██╔════╝██╔══██╗██╔══██╗██╔═══██╗██║ ██╔════╝ ║ ║ ███████║ ╚████╔╝ ██████╔╝█████╗ ██████╔╝██████╔╝██║ ██║██║ █████╗ ║ ║ ██╔══██║ ╚██╔╝ ██╔═══╝ ██╔══╝ ██╔══██╗██╔══██╗██║ ██║██║ ██╔══╝ ║ ║ ██║ ██║ ██║ ██║ ███████╗██║ ██║██████╔╝╚██████╔╝███████╗███████╗ ║ ║ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚══════╝╚═╝ ╚═╝╚═════╝ ╚═════╝ ╚══════╝╚══════╝ ║ ╚═════════════════════════════════════════════════════════════════════════════╝ |] space el ~ fontSize 18 . Cyber.font . bold . textAlign AlignCenter $ do el "Create interactive HTML applications with type-safe serverside Haskell." el "Inspired by HTMX, Elm, and Phoenix LiveView" space col ~ gap 10 $ do example $(moduleSourceNamed "Example.Simple") $ do runViewContext Root () simple snippet $ do raw $(embedTopLevel "Example.Simple" "{-# LANGUAGE") raw "\nmodule Main where\n\n" raw $(embedSource "Example.Simple" (isTopLevel "import") (const True)) section' "But Why?" $ do markdocs $(embedFile "docs/intro.md") section' "When not to use Hyperbole?" $ do markdocs $(embedFile "docs/intro-downsides.md") section' "Documentation" $ do markdocs $(embedFile "docs/intro-links.md") where scaleText :: (Styleable h) => CSS h -> CSS h scaleText = utility "scale-text" [ "font-size" :. "clamp(0.4rem, 1.5vw, 1rem)" , "max-width" :. "100%" ] ================================================ FILE: demo/App/Page/OAuth2.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module App.Page.OAuth2 where import App.Config (AppConfig (..)) import App.Docs import App.Route qualified as Route import Data.Aeson (eitherDecode) import Data.String.Conversions (cs) import Data.Text (Text, pack) import Effectful import Effectful.Reader.Dynamic import Example.Style.Cyber as Cyber (btn, font) import Example.View.Layout import Network.HTTP.Client qualified as HTTP import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Data.URI (Endpoint (..), (./.)) import Web.Hyperbole.Effect.OAuth2 (Access, OAuth2, Token (..)) import Web.Hyperbole.Effect.OAuth2 qualified as OAuth2 import Web.Hyperbole.Types.Response (ResponseError (ErrAuth)) -------------------------------------------------------------------------------- -- App Specific Login -------------------------------------------------------------------------------- -- This code belongs in an application-wide module -- This example uses a mock OAuth2 server: https://app.beeceptor.com/mock-server/oauth-mock data UserSession = UserSession { auth :: OAuth2.Authenticated , email :: Text } deriving (Generic, ToEncoded, FromEncoded) instance Session UserSession where -- we want it to work on any page, not just this one cookiePath = Just [] openLogin :: (Hyperbole :> es, OAuth2 :> es, Reader AppConfig :> es) => Eff es a openLogin = do Endpoint appRoot <- (.endpoint) <$> ask @AppConfig let redirectUrl = appRoot ./. routePath (Route.Examples Route.OAuth2Authenticate) u <- OAuth2.authUrl redirectUrl "email" redirect u logout :: (Hyperbole :> es) => Eff es () logout = deleteSession @UserSession -- | Target of the redirect after the user logs in via OAuth2 handleRedirect :: (Hyperbole :> es, OAuth2 :> es, Reader AppConfig :> es, IOE :> es) => Eff es Response handleRedirect = do authCode <- OAuth2.validateCode auth <- OAuth2.exchangeAuth authCode info <- fetchUserInfo auth.accessToken saveSession @UserSession $ UserSession auth info.email redirect $ routeUri (Route.Examples Route.OAuth2) data GithubUserInfo = GithubUserInfo { email :: Text } deriving (Generic, FromJSON, Show) -- | Example authenticated request using an oauth access token. in a real app, this should be in an external effect, not IOE fetchUserInfo :: (IOE :> es, Reader AppConfig :> es, Hyperbole :> es) => Token Access -> Eff es GithubUserInfo fetchUserInfo (Token accessTok) = do app <- ask @AppConfig req <- HTTP.parseRequest "https://oauth-mock.mock.beeceptor.com/userinfo/github" res <- liftIO (HTTP.httpLbs (HTTP.applyBearerAuth (cs accessTok) req) app.manager) case eitherDecode @GithubUserInfo (HTTP.responseBody res) of Left e -> respondError $ ErrAuth $ "Could not parse user info: " <> pack (show e) Right info -> do liftIO $ putStrLn "GOT" liftIO $ print info pure info -------------------------------------------------------------------------------- -- Page / Views -------------------------------------------------------------------------------- page :: (Hyperbole :> es, OAuth2 :> es, Reader AppConfig :> es) => Page es '[Contents] page = do muser <- lookupSession @UserSession pure $ layout (Route.Examples Route.OAuth2) $ do col ~ gap 10 $ do el "Hyperbole provides some helpers to make OAuth2 easier. This is done in 2 steps:" el "1. Initiate the login via the OAuth provider given a redirect url" el "2. After the redirect, the library validates the response and fetches an access token from the oauth provider." el "The developer can then make authenticated requests, and store a user session" example $(moduleSource) $ do hyper Contents $ viewContents muser data Contents = Contents deriving (Generic, ViewId) instance (OAuth2 :> es, Reader AppConfig :> es) => HyperView Contents es where data Action Contents = Logout | Login deriving (Generic, ViewAction) update Login = do openLogin update Logout = do logout pure $ viewContents Nothing viewContents :: Maybe UserSession -> View Contents () viewContents mt = do col ~ gap 10 $ do maybe viewUnauthorized viewAuthorized mt viewUnauthorized :: View Contents () viewUnauthorized = do message "Logged Out!" col ~ gap 5 $ do button Login "Login" ~ btn viewAuthorized :: UserSession -> View Contents () viewAuthorized user = do let auth = user.auth message "Successfully Logged In!" el ~ pad 5 . grid' . gap 10 $ do dataItem "Email" user.email dataItem "Token Type" $ pack $ show auth.tokenType dataItem "Access Token" auth.accessToken.value dataItem "Expires In" $ pack $ show auth.expiresIn dataItem "Refresh Token" $ pack $ show auth.refreshToken dataItem "Scope" $ pack $ show auth.scope button Logout "Logout" ~ btn where dataItem :: Text -> Text -> View c () dataItem lbl cnt = do el ~ bold $ do text lbl el ~ overflow Hidden $ text cnt grid' :: (Styleable h) => CSS h -> CSS h grid' = utility "grid" [ "display" :. "grid" , "grid-template-columns" :. "max-content auto" , "align-items" :. "center" ] message :: View c () -> View c () message x = el x ~ pad 10 . Cyber.font . border 1 ================================================ FILE: demo/App/Page/SideEffects.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Page.SideEffects where import App.Docs import App.Route as Route (AppRoute (SideEffects)) import Example.Counter (Counter (..)) import Example.Docs.SideEffects as SideEffects import Example.View.Layout (layoutSubnav) import Web.Hyperbole data EffectsSection = Effectful | Other | Custom deriving (Show, Enum, Bounded) instance PageAnchor EffectsSection where sectionTitle Other = "Reader and More" sectionTitle Custom = "Databases and Custom Effects" sectionTitle a = camelTitle a page :: (Hyperbole :> es) => Page es '[Counter, SlowReader, Titler] page = do pure $ layoutSubnav @EffectsSection Route.SideEffects $ do section Effectful $ do markdocs $(embedFile "docs/effectful.md") example SideEffects.source $ do hyper Titler titleView section Other $ do markdocs $(embedFile "docs/effects-other.md") example SideEffects.source $ do hyper SlowReader $ messageView "..." section Custom $ do markdocs $(embedFile "docs/effects-custom.md") ================================================ FILE: demo/App/Page/State.hs ================================================ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module App.Page.State where import App.Docs import App.Route (AppRoute (State)) import Effectful.Concurrent import Effectful.Concurrent.STM (TVar) import Effectful.Reader.Dynamic import Example.Counter as Threaded import Example.State.Effects as Effects import Example.State.Query (QueryPrefs (..)) import Example.State.Query qualified as Query import Example.State.Sessions qualified as Session import Example.State.Stateless import Example.State.ViewState qualified as ViewState import Example.View.Layout (layoutSubnav) import Web.Hyperbole data StateSection = Stateless | ActionThreading | ViewState | BrowserQuery | BrowserSessions | WithEffects deriving (Show, Enum, Bounded) instance PageAnchor StateSection page :: (Hyperbole :> es, Reader (TVar Int) :> es, Concurrent :> es) => Page es '[Threaded.Counter, Swapper, QueryPrefs, Session.Contents, Effects.Counter, ViewState.Counter] page = do ssn <- session @Session.Preferences qry <- query @Query.Preferences cnt <- getCount pure $ layoutSubnav @StateSection State $ do section Stateless $ do markdocs $(embedFile "docs/state-stateless.md") example $(moduleSourceNamed "Example.State.Stateless") $ do hyper Swapper viewSwap section ActionThreading $ do markdocs $(embedFile "docs/state-threading.md") example $(moduleSourceNamed "Example.Counter") $ do hyper Threaded.Counter $ Threaded.viewCount 0 section ViewState $ do markdocs $(embedFile "docs/state-viewstate.md") example $(moduleSourceNamed "Example.State.ViewState") $ do hyperState ViewState.CounterState 0 ViewState.viewCount section BrowserQuery $ do markdocs $(embedFile "docs/state-browser.md") example $(moduleSourceNamed "Example.State.Query") $ do hyper QueryPrefs $ Query.viewPreferences qry section BrowserSessions $ do markdocs $(embedFile "docs/state-sessions.md") example $(moduleSourceNamed "Example.State.Sessions") $ do hyper Session.Contents $ Session.viewContent ssn section WithEffects $ do markdocs $(embedFile "docs/state-effects.md") example $(moduleSourceNamed "Example.State.Effects") $ do hyper Effects.Counter $ Effects.viewCount cnt ================================================ FILE: demo/App/Page/ViewFunctions.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module App.Page.ViewFunctions where import App.Docs import App.Route qualified as Route import Example.Docs.ViewFunctions as VF import Example.Push qualified as Push import Example.View.Layout (layoutSubnav) import Web.Atomic.CSS import Web.Hyperbole data Basics = ViewFunctions | NotComponents deriving (Show, Enum, Bounded) instance PageAnchor Basics page :: (Hyperbole :> es) => Page es '[Message, Toggler, Progress, Push.Tasks] page = do pure $ layoutSubnav @Basics Route.ViewFunctions $ do section ViewFunctions $ do markdocs $(embedFile "docs/view-functions.md") example VF.source $ do hyper VFMessage $ messageView "Hello" section NotComponents $ do markdocs $(embedFile "docs/view-components.md") example VF.source $ do hyper Toggler $ toggler False col ~ pad (T 20) . gap 10 $ do markdocs $(embedFile "docs/view-functions-wrap.md") example VF.source $ do -- hyper Push.Tasks $ Push.taskView 0 hyper Progress $ workingHard 0.1 col ~ pad (T 20) . gap 10 $ do markdocs $(embedFile "docs/view-functions-end.md") ================================================ FILE: demo/App/Route.hs ================================================ {-# LANGUAGE OverloadedLists #-} module App.Route where import Data.String.Conversions (cs) import Data.Text (Text, unpack) import Text.Casing (fromHumps, toWords) import Text.Read (readMaybe) import Web.Hyperbole import Web.Hyperbole.Data.URI import Web.Hyperbole.Route type UserId = Int data AppRoute = Main | Intro | Basics | CSS | Simple | Hello Hello | Contacts ContactRoute | Interactivity | SideEffects | Hyperviews | State | Counter | Forms FormRoute | HyperboleEffect | Response | Concurrency | Data DataRoute | Examples ExamplesRoute | Errors | Javascript | Test TestRoute | ViewFunctions | Application deriving (Eq, Generic, Show) instance Route AppRoute where baseRoute = Just Main -- -- View Route -- data IntroRoute -- = IntroMain -- | Pages -- | Views -- | HyperViews -- | ViewFunctions -- | CSS CSSRoute -- deriving (Eq, Generic, Show) -- instance Route IntroRoute where -- baseRoute = Just IntroMain data FormRoute = FormSimple | FormValidation deriving (Eq, Generic, Show) instance Route FormRoute where baseRoute = Just FormSimple data DataRoute = DataLists | SortableTable | Autocomplete | Filter | LoadMore deriving (Eq, Generic, Show) instance Route DataRoute where baseRoute = Just DataLists -- data StateRoute -- = StateRoot -- | Actions -- | StateView -- | Effects -- | Query -- | Sessions -- deriving (Eq, Generic, Show) -- instance Route StateRoute where -- baseRoute = Just StateRoot data ContactRoute = ContactsAll | Contact UserId deriving (Eq, Generic, Show) instance Route ContactRoute where baseRoute = Just ContactsAll matchRoute [contactId] = do cid <- readMaybe $ unpack contactId pure $ Contact cid matchRoute [] = pure ContactsAll matchRoute other = genMatchRoute other.segments routePath (Contact uid) = routePath uid routePath ContactsAll = [] data ExamplesRoute = OtherExamples | Todos | TodosCSS -- A version using the CSS from TodoMVC project | Tags | OAuth2Authenticate | OAuth2 | Chat | Scrollbars deriving (Eq, Generic, Show) instance Route ExamplesRoute where baseRoute = Just OtherExamples data TestRoute = TestMain | TestState deriving (Eq, Generic, Show) instance Route TestRoute where baseRoute = Just TestMain data Hello = Greet Text | Redirected | RedirectNow deriving (Eq, Generic, Route, Show) routeTitle :: AppRoute -> Text routeTitle (Hello _) = "Hello World" routeTitle CSS = "Styles" -- routeTitle (Intro IntroMain) = "Intro" -- routeTitle (Intro (CSS _)) = "Atomic CSS" -- routeTitle (Intro r) = defaultTitle r routeTitle (Contacts ContactsAll) = "Contacts" routeTitle State = "Managing State" routeTitle Hyperviews = "More HyperViews" -- routeTitle (State StateRoot) = "State" -- routeTitle (State StateView) = "Built-in State" -- routeTitle (State Actions) = "Managing State" -- routeTitle (State Query) = "Query" -- routeTitle (State Sessions) = "Sessions" routeTitle (Forms FormSimple) = "Forms" routeTitle (Forms FormValidation) = "Form Validation" routeTitle (Data d) = defaultTitle d routeTitle Errors = "Error Handling" routeTitle (Examples Todos) = "TodoMVC" routeTitle (Examples TodosCSS) = "TodoMVC (CSS version)" routeTitle (Examples OAuth2) = "OAuth2" routeTitle (Examples OtherExamples) = "Examples" routeTitle (Examples e) = defaultTitle e routeTitle r = defaultTitle r defaultTitle :: (Show r) => r -> Text defaultTitle = cs . toWords . fromHumps . show ================================================ FILE: demo/App/Style.hs ================================================ module App.Style where import Example.Colors import Web.Atomic.CSS -- btn :: (Styleable h) => CSS h -> CSS h -- btn = btn' Primary -- -- btn' :: (Styleable h) => AppColor -> CSS h -> CSS h -- btn' clr = -- bg clr -- . hover (bg (hovClr clr)) -- . color (txtClr clr) -- . pad 10 -- . shadow () -- . rounded 3 -- where -- hovClr Primary = PrimaryLight -- hovClr c = c -- txtClr _ = White btnLight :: (Styleable h) => CSS h -> CSS h btnLight = base . border 2 . borderColor Secondary . color Secondary . hover (borderColor SecondaryLight . color SecondaryLight) where base = pad (XY 15 8) h1 :: (Styleable h) => CSS h -> CSS h h1 = bold . fontSize 32 invalid :: (Styleable h) => CSS h -> CSS h invalid = color Danger success :: (Styleable h) => CSS h -> CSS h success = color Success link :: (Styleable h) => CSS h -> CSS h link = color Primary . underline input :: (Styleable h) => CSS h -> CSS h input = border 1 . pad 8 strikethrough :: (Styleable h) => CSS h -> CSS h strikethrough = utility "strike" ["text-decoration" :. "line-through"] uppercase :: (Styleable h) => CSS h -> CSS h uppercase = utility "upper" ["text-transform" :. "uppercase"] ================================================ FILE: demo/App.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} module App where import App.Cache (clientCache) import App.Config import App.Docs.Page import App.Page.Application qualified as Application import App.Page.CSS qualified as CSS import App.Page.Concurrency qualified as Concurrency import App.Page.Examples qualified as Examples import App.Page.Forms qualified as Forms import App.Page.HyperboleEffect qualified as Hyp import App.Page.Hyperviews qualified as Hyperviews import App.Page.Interactivity qualified as Interactivity import App.Page.Intro.Basics qualified as Basics import App.Page.Intro.Intro qualified as Intro import App.Page.OAuth2 qualified as OAuth2 import App.Page.SideEffects qualified as SideEffects import App.Page.State qualified as State import App.Page.ViewFunctions qualified as ViewFunctions import App.Route as Route import Control.Concurrent ( MVar , ThreadId , forkFinally , killThread , newEmptyMVar , putMVar , takeMVar ) import Control.Monad (forever, when, (>=>)) import Data.ByteString.Lazy qualified as BL import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.String.Interpolate (i) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as L import Data.Text.Lazy.Encoding qualified as L import Data.Version (showVersion) import Effectful import Effectful.Concurrent.STM import Effectful.Dispatch.Dynamic import Effectful.Environment (runEnvironment) import Effectful.Reader.Dynamic import Effectful.State.Static.Local import Example.Chat qualified as Chat import Example.Colors import Example.Contact qualified as Contact import Example.Contacts qualified as Contacts import Example.Counter qualified as Counter import Example.DataLists.Autocomplete qualified as Autocomplete import Example.DataLists.DataTable qualified as DataTable import Example.DataLists.Filter qualified as Filter import Example.DataLists.LoadMore qualified as LoadMore import Example.Effects.Debug as Debug import Example.Effects.Todos (Todos, runTodosSession) import Example.Effects.Users as Users import Example.Scrollbars qualified as Scrollbars import Example.State.Effects qualified as Effects import Example.State.Query qualified as Query import Example.State.Sessions qualified as Sessions import Example.State.ViewState qualified as ViewState import Example.Style qualified as Style import Example.Style.Cyber qualified as Cyber import Example.Tags qualified as Tags import Example.Test qualified as Test import Example.Todos.Todo qualified as Todo import Example.Todos.TodoCSS qualified as TodoCSS import Example.View.Layout as Layout (layout) import Foreign.Store (Store (..), lookupStore, readStore, storeAction, withStore) import GHC.Generics (Generic) import GHC.Word (Word32) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client.TLS qualified as HTTPS import Network.HTTP.Types (Header, Method, QueryItem, hCacheControl, methodPost, status200, status404) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Middleware.Static as Static (CacheContainer, CachingStrategy (..), Options (..), addBase) import Network.Wai.Middleware.Static qualified as Static import Network.WebSockets (Connection, PendingConnection, acceptRequest, defaultConnectionOptions) import Paths_demo (version) import Paths_demo qualified as Pt import Safe (readMay) import System.Environment qualified as SE import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Application import Web.Hyperbole.Effect.GenRandom import Web.Hyperbole.Effect.OAuth2 (OAuth2, runOAuth2) import Web.Hyperbole.Effect.OAuth2 qualified as OAuth2 import Web.Hyperbole.Server.Options (defaultError) import Web.Hyperbole.Types.Response run :: IO () run = do hSetBuffering stdout LineBuffering port <- do mStr <- SE.lookupEnv "PORT" pure $ fromMaybe 3000 (readMay =<< mStr) putStrLn $ "Starting Examples on http://localhost:" <> show port users <- Users.initUsers (count, room, config) <- runEff $ runEnvironment $ do c <- runConcurrent Effects.initCounter room <- runConcurrent Chat.initChatRoom a <- getAppConfigEnv pure (c, room, a) cache <- clientCache Warp.run port $ Static.staticPolicyWithOptions cache (addBase "client/dist") $ Static.staticPolicy (addBase "demo/static") $ do devReload config $ exampleApp config users count room where devReload :: AppConfig -> Application -> Application devReload config | config.devMode = Wai.modifyResponse $ Wai.mapResponseHeaders $ \hs -> ("Connection", "Close") : hs | otherwise = id exampleApp :: AppConfig -> UserStore -> TVar Int -> Chat.Room -> Application exampleApp config users count chats = do liveAppWith (ServerOptions (document documentHead) serverError) (runApp . routeRequest $ router) where runApp :: (Hyperbole :> es, IOE :> es) => Eff (OAuth2 : GenRandom : Concurrent : Debug : Users : Todos : Reader AppConfig : es) a -> Eff es a runApp = runReader config . runTodosSession . runUsersIO users . runDebugIO . runConcurrent . runRandom . runOAuth2 config.oauth config.manager router :: forall es. (Hyperbole :> es, OAuth2 :> es, Todos :> es, Users :> es, Debug :> es, Concurrent :> es, IOE :> es, GenRandom :> es, Reader AppConfig :> es) => AppRoute -> Eff es Response router Counter = runPage Counter.page router (Hello h) = runPage $ hello h router (Contacts (Contact uid)) = Contact.response uid router (Contacts ContactsAll) = runPage Contacts.page router Concurrency = runPage Concurrency.page router (Data r) = case r of DataLists -> redirect $ routeUri (Data SortableTable) SortableTable -> runPage DataTable.page Autocomplete -> runPage Autocomplete.page Filter -> runPage Filter.page LoadMore -> runPage LoadMore.page router Errors = redirect (routeUri HyperboleEffect) router (Forms _) = runPage Forms.page router HyperboleEffect = runPage Hyp.page router Hyperviews = runPage Hyperviews.page router Route.Response = redirect (routeUri HyperboleEffect) router State = runReader count $ runPage State.page router SideEffects = runReader @Text "Secret Message!" $ runPage SideEffects.page router Intro = runPage Intro.page router Basics = runPage Basics.page router Application = runPage Application.page router ViewFunctions = runPage ViewFunctions.page -- router (Intro HyperViews) = runPage IntroHyperViews.page -- router (Intro Pages) = runPage IntroPages.page -- router (Intro ViewFunctions) = runPage IntroViewFunctions.page router CSS = runPage CSS.page router Interactivity = runPage Interactivity.page router (Examples Chat) = runReader chats $ runPage Chat.page router (Examples OtherExamples) = runPage Examples.page router (Examples Todos) = runPage Todo.page router (Examples Tags) = runPage Tags.page router (Examples TodosCSS) = runPage TodoCSS.page router Javascript = redirect (routeUri Interactivity) router (Examples OAuth2) = runPage OAuth2.page router (Examples OAuth2Authenticate) = OAuth2.handleRedirect router (Examples Scrollbars) = runPage Scrollbars.page router Simple = redirect (routeUri Intro) -- router Counter = redirect (routeUri $ State StateRoot) router (Test TestMain) = runPage Test.page router (Test TestState) = runPage ViewState.page router Main = do redirect (routeUri Intro) -- Nested Router hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es '[] hello RedirectNow = do redirect (routeUri $ Hello Redirected) hello (Greet who) = do pure $ layout (Hello $ Greet who) $ do row ~ gap 6 . pad 10 $ do el "Hello:" el $ text who hello Redirected = do pure $ layout HyperboleEffect $ do col ~ pad 10 . gap 10 $ do el "You were redirected" route HyperboleEffect ~ Style.link $ "Go Back" -- Use the embedded version for real applications (see quickStartDocument). -- The link to /hyperbole.js here is just to make local development easier documentHead :: View DocumentHead () documentHead = do title "Hyperbole Examples" mobileFriendly stylesheet "/cyber.css" script "/hyperbole.js" stylesheet "/prism.css" script "/prism.js" @ att "defer" "" script "/docs.js" @ att "defer" "" style "html { scroll-behavior: smooth; }\n body { background-color: #e0e7f1; font-family: font-family: -apple-system, BlinkMacSystemFont, \"Segoe UI\", \"Noto Sans\", Helvetica, Arial, sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\") }, button { font-family: 'Share Tech Mono'}" style cssEmbed when config.devMode $ do script' scriptLiveReload serverError :: ResponseError -> ServerError -- serverError NotFound = ServerError "NotFound" $ Cyber.cyberError "Custom Not Found!" serverError (ErrCustom s) = s serverError err = let msg = defaultErrorMessage err in ServerError { message = msg , body = Cyber.cyberError $ Cyber.glitch msg } {- | Made for local development - - ghcid --setup=Main.update --command="cabal repl exe:examples lib:hyperbole test" --run=Main.update --warnings - - Start or restart the server. newStore is from foreign-store. A Store holds onto some data across ghci reloads -} update :: IO () update = do mtidStore <- lookupStore tidStoreNum case mtidStore of -- no server running Nothing -> do done <- storeAction doneStore newEmptyMVar tid <- start done _ <- storeAction (Store tidStoreNum) (newIORef tid) return () -- server is already running Just tidStore -> do restartAppInNewThread tidStore where -- callCommand "xmonadctl refreshFirefox" doneStore :: Store (MVar ()) doneStore = Store 0 -- shut the server down with killThread and wait for the done signal restartAppInNewThread :: Store (IORef ThreadId) -> IO () restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do killThread tid withStore doneStore takeMVar readStore doneStore >>= start -- \| Start the server in a separate thread. start :: MVar () -- \^ Written to when the thread is killed. -> IO ThreadId start done = do forkFinally App.run -- Note that this implies concurrency -- between shutdownApp and the next app that is starting. -- Normally this should be fine (\_ -> putMVar done ()) tidStoreNum :: Word32 tidStoreNum = 1 modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () modifyStoredIORef store f = withStore store $ \ref -> do v <- readIORef ref f v >>= writeIORef ref cacheMiddleware :: Application -> Application cacheMiddleware = Wai.modifyResponse addCache where addCache = Wai.mapResponseHeaders ((hCacheControl, "private, max-age=60") :) ================================================ FILE: demo/Example/CSS/External.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.CSS.External where import Data.Text (Text) import App.Docs import Web.Hyperbole source :: ModuleSource source = $(moduleSource) main :: IO () main = do run 3000 $ do liveApp quickStartDocument (runPage page) page :: (Hyperbole :> es) => Page es '[Items] page = do pure $ do -- you can choose to include a stylesheet only on pages -- that use it or load it globally in your document function stylesheet "external.css" hyper Items $ itemsView "one" data Items = Items deriving (Generic, ViewId) instance HyperView Items es where data Action Items = Select Text deriving (Generic, ViewAction) update (Select t) = do pure $ itemsView t itemsView :: Text -> View Items () itemsView sel = do el @ class_ "parent" $ do item "one" item "two" item "three" item "four" item "five" where selected i = if sel == i then class_ "selected" else id item i = -- the class_ attribute MERGES classes if you set it more than once button (Select i) @ class_ "item" . selected i $ text i ================================================ FILE: demo/Example/CSS/Loading.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.CSS.Loading where import Data.Text (Text) import Example.Effects.Debug import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole data Loader = Loader deriving (Generic, ViewId) instance (Debug :> es) => HyperView Loader es where data Action Loader = LoadSlow deriving (Generic, ViewAction) update LoadSlow = do delay 1000 pure $ viewLoaders "OK!" viewLoaders :: Text -> View Loader () viewLoaders status = do col ~ gap 10 $ do row ~ gap 10 . whenLoading flexRow . display None $ do loadingBars el "Loading..." el ~ whenLoading (display None) $ text status button LoadSlow ~ btn . whenLoading (opacity 0.5) $ "Load Slow" loadingBars :: View c () loadingBars = el ~ cls "loader" $ none ================================================ FILE: demo/Example/CSS/Tooltips.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.CSS.Tooltips where import App.Docs import Example.Colors import Web.Atomic.CSS import Web.Hyperbole source :: ModuleSource source = $(moduleSource) tooltips :: View c () tooltips = do col ~ pad 10 . gap 10 . width 300 $ do mapM_ viewItemRow ["One", "Two", "Three", "Four", "Five", "Six"] where viewItemRow item = do col ~ stack . showTooltips . hover (color Primary) . pointer $ do el ~ border 1 . bg White . pad 5 $ text item el ~ cls "tooltip" . popup (TR 10 10) . zIndex 1 . visibility Hidden $ do col ~ border 2 . gap 5 . bg White . pad 5 $ do el ~ bold $ "DETAILS" el $ text item el "details about this item" showTooltips = css "tooltips" ".tooltips:hover > .tooltip" (declarations (visibility Visible)) ================================================ FILE: demo/Example/CSS/Transitions.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.CSS.Transitions where import App.Docs import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole source :: ModuleSource source = $(moduleSource) data Animate = Animate deriving (Generic, ViewId) instance HyperView Animate es where data Action Animate = Expand | Collapse deriving (Generic, ViewAction) update Expand = do pure viewBig update Collapse = do pure viewSmall viewSmall :: View Animate () viewSmall = do col ~ gap 10 . transition 300 (Width 200) $ do el "Small" button Expand "Expand" ~ btn viewBig :: View Animate () viewBig = col ~ gap 10 . transition 300 (Width 400) $ do el "Expanded" button Collapse "Collapse" ~ btn ================================================ FILE: demo/Example/Chat.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Chat where import App.Route import Control.Monad (forM_, forever) import Data.Text (Text) import Effectful import Effectful.Concurrent import Effectful.Concurrent.STM import Effectful.Reader.Dynamic import Effectful.State.Dynamic (modify) import Example.Colors import Example.Style qualified as Style import Example.Style.Cyber (embed) import Example.Style.Cyber as Cyber (btn, font) import Example.View.Layout (layout) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Data.Encoded (Encoded (..), FromEncoded (..), ToEncoded (..)) page :: (Hyperbole :> es, Concurrent :> es, Reader Room :> es) => Page es '[Content, Chats, NewMessage] page = do pure $ layout (Examples Chat) $ do el "Demonstrates server pushes and concurrency. Open in two tabs with different usernames to test." col ~ embed . Cyber.font $ do hyper Content $ contentView Nothing type Username = Text data Content = Content deriving (Generic, ViewId) instance HyperView Content es where data Action Content = Login | Logout deriving (Generic, ViewAction) type Require Content = '[Chats, NewMessage] update Login = do LoginForm u <- formData pure $ contentView (Just u) update Logout = pure $ contentView Nothing data LoginForm = LoginForm { username :: Text } deriving (Generic, FromForm) contentView :: Maybe Username -> View Content () contentView mu = do case mu of Nothing -> do form Login ~ flexRow . gap 10 $ do field "username" $ do input Username @ placeholder "Username" . autofocus ~ Style.input submit "Login" ~ btn Just u -> do col ~ gap 10 $ do row ~ gap 10 $ do el "Welcome " el ~ bold $ text u space button Logout ~ btn $ "logout" hyperState Chats mempty $ chatsLoad u hyper (NewMessage u) messageView -- Chat Room ------------------------------------- data Message = Message { sender :: Username , body :: Text } deriving (Generic, ToParam, FromParam) newtype Room = Room (TChan Message) newtype Subscription = Subscription (TChan Message) initChatRoom :: (Concurrent :> es) => Eff es Room initChatRoom = Room <$> newBroadcastTChanIO subscribeChatRoom :: (Concurrent :> es) => Room -> Eff es Subscription subscribeChatRoom (Room chan) = fmap Subscription <$> atomically $ dupTChan chan waitMessage :: (Concurrent :> es) => Subscription -> Eff es Message waitMessage (Subscription chan) = atomically $ readTChan chan sendMessage :: (Concurrent :> es) => Room -> Message -> Eff es () sendMessage (Room chan) msg = atomically $ writeTChan chan msg -- Encoding for message history since starting newtype AllMessages = AllMessages [Message] deriving newtype (Semigroup, Monoid) instance ToEncoded AllMessages where toEncoded (AllMessages ms) = Encoded "" (fmap toParam ms) instance FromEncoded AllMessages where parseEncoded (Encoded _ ps) = AllMessages <$> mapM parseParam ps --- Chat Updates --------------------------------------------- data Chats = Chats deriving (Generic) instance ViewId Chats where type ViewState Chats = AllMessages instance (Concurrent :> es, Reader Room :> es, IOE :> es) => HyperView Chats es where data Action Chats = Stream Username deriving (Generic, ViewAction) update (Stream u) = do room <- ask sub <- subscribeChatRoom room sendMessage room $ Message u "I have arrived!" forever (streamChats sub) where streamChats room = do -- Block until we receive a message from the duplicated channel msg <- waitMessage room -- store all the messages we've seen in our view state modify $ addMessage msg -- update the view pushUpdate $ chatsView u addMessage :: Message -> AllMessages -> AllMessages addMessage msg (AllMessages ms) = AllMessages $ msg : ms allMessages :: View Chats AllMessages allMessages = do AllMessages ms <- viewState pure $ AllMessages $ reverse ms chatsLoad :: Username -> View Chats () chatsLoad user = el @ onLoad (Stream user) 100 $ "..." chatsView :: Username -> View Chats () chatsView _user = do AllMessages chats <- allMessages col ~ gap 5 . pad 5 . minHeight 400 . border 1 . bg GrayLight $ do forM_ chats $ \chat -> do el $ do text chat.sender text ": " text chat.body --- New Message Form ------------------------------ data NewMessage = NewMessage Username deriving (Generic, ViewId) instance (Concurrent :> es, Reader Room :> es, IOE :> es) => HyperView NewMessage es where data Action NewMessage = SendMessage deriving (Generic, ViewAction) update SendMessage = do room <- ask NewMessage user <- viewId MessageForm msg <- formData sendMessage room $ Message user msg -- NOTE: this doesn't show an update at all, but we are subscribed to the channel and will get a push like everyone else pure messageView data MessageForm = MessageForm { message :: Text } deriving (Generic, FromForm) messageView :: View NewMessage () messageView = do form SendMessage ~ flexRow . gap 10 $ do field "message" $ do input TextInput @ placeholder "type your message here" . value "" . autofocus ~ Style.input . grow submit "Send" ~ btn ================================================ FILE: demo/Example/Colors.hs ================================================ {-# LANGUAGE LambdaCase #-} module Example.Colors where import Web.Atomic.CSS import Web.Hyperbole data AppColor = White | Light | GrayLight | GrayDark | Dark | DarkHighlight | Success | Danger | Warning | Primary | PrimaryLight | Secondary | SecondaryLight deriving (Show, Read, Eq, Generic, ToJSON, FromJSON, ToParam, FromParam) instance Default AppColor where def = White instance ToColor AppColor where colorValue White = "#FFF" colorValue Light = "#F2F2F3" colorValue GrayLight = "#E3E5E9" colorValue GrayDark = "#2С3С44" -- colorValue Dark = "#2E3842" -- "#232C41" colorValue Dark = "#121726" -- "#232C41" colorValue DarkHighlight = "#343945" -- "#232C41" colorValue Primary = "#4171b7" colorValue PrimaryLight = "#6D9BD3" -- colorValue PrimaryLight = "#e2ebf6" colorValue Secondary = "#5D5A5C" colorValue SecondaryLight = "#9D999C" -- colorValue Success = "67C837" colorValue Success = "#149e5a" colorValue Danger = midRed colorValue Warning = "#e1c915" lightRed :: HexColor lightRed = HexColor "#EC6458" midRed :: HexColor midRed = HexColor "#A03F38" darkRed :: HexColor darkRed = HexColor "#722C2A" cyan :: HexColor cyan = "#0FF" magenta :: HexColor magenta = "#E44072" light :: AppColor -> HexColor light PrimaryLight = "#a8c3e5" light Primary = colorValue PrimaryLight -- light Danger = "#ef8379" light Danger = lightRed light c = colorValue c hoverColor :: AppColor -> HexColor hoverColor = \case White -> colorValue Light c -> light c contrastColor :: AppColor -> HexColor contrastColor = \case Primary -> colorValue White PrimaryLight -> colorValue White Danger -> colorValue White _ -> colorValue Dark ================================================ FILE: demo/Example/Concurrency/LazyLoading.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Concurrency.LazyLoading where import App.Docs import Effectful import Example.Colors import Example.Concurrency.Tasks import Example.Effects.Debug import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Effect.GenRandom ----------------------------------------------------------- -- Lazy Loading Expensive Data ----------------------------------------------------------- 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 viewTaskLoad :: View LazyData () viewTaskLoad = do -- 100ms after rendering, get the details el @ onLoad Details 100 ~ bg GrayLight . textAlign AlignCenter $ do text "..." viewTaskDetails :: Task -> View LazyData () viewTaskDetails task = do el ~ color Success . textAlign AlignCenter $ do text task.details source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Concurrency/Overlap.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Concurrency.Overlap where import App.Docs import Data.Text (Text, pack) import Effectful import Example.Effects.Debug import Example.Style.Cyber (btn) import Example.View.Loader as Loader import Web.Atomic.CSS import Web.Hyperbole -- Concurrency = Drop --------------------------- data OverlapDrop = OverlapDrop deriving (Generic, ViewId) instance (Debug :> es) => HyperView OverlapDrop es where data Action OverlapDrop = GetTimeDrop deriving (Generic, ViewAction) -- this is the default, not necessary to specify -- type Concurrency OverlapDrop = Drop update GetTimeDrop = do t <- getTimeSlowly pure $ viewTimeDrop (Just t) viewTimeDrop :: Maybe UTCTime -> View OverlapDrop () viewTimeDrop = viewTime GetTimeDrop "Drop" -- Concurrency = Replace -------------------------- data OverlapReplace = OverlapReplace deriving (Generic, ViewId) instance (Debug :> es) => HyperView OverlapReplace es where data Action OverlapReplace = GetTimeReplace deriving (Generic, ViewAction) type Concurrency OverlapReplace = Replace update GetTimeReplace = do t <- getTimeSlowly pure $ viewTimeReplace (Just t) viewTimeReplace :: Maybe UTCTime -> View OverlapReplace () viewTimeReplace = viewTime GetTimeReplace "Replace" -- Utilities ----------------------------------------------- getTimeSlowly :: (Debug :> es) => Eff es UTCTime getTimeSlowly = do delay 2000 systemTime viewTime :: (ViewAction (Action id)) => Action id -> Text -> Maybe UTCTime -> View id () viewTime runTime loadLbl mtime = do row ~ gap 10 $ do button runTime ~ btn $ text loadLbl Loader.loading case mtime of Nothing -> none Just t -> el ~ whenLoading (display None) $ text $ pack $ show t source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Concurrency/Polling.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Concurrency.Polling where import App.Docs import Data.Text (pack) import Effectful import Example.Effects.Debug import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole ----------------------------------------------------------- -- Simple Polling ----------------------------------------------------------- data Poller = Poller deriving (Generic, ViewId) instance (Debug :> es) => HyperView Poller es where data Action Poller = Reload Int | Stop | Pause Int deriving (Generic, ViewAction) -- to stop, return a view without an onLoad update (Pause n) = do pure $ viewPaused n update Stop = do pure viewStopped update (Reload n) = do pure $ viewPoll n viewInit :: View Poller () viewInit = do row $ do button (Reload 1) "Start Polling" ~ btn viewStopped :: View Poller () viewStopped = do row $ do button (Reload 1) "Restart Polling" ~ btn viewPaused :: Int -> View Poller () viewPaused n = do col ~ gap 10 $ do row $ do button (Reload n) "Resume" ~ btn viewStatus n viewPoll :: Int -> View Poller () viewPoll n = do -- reload every 200ms + round trip delay col @ onLoad (Reload (n + 1)) 250 ~ gap 10 $ do row ~ gap 5 $ do button (Pause n) "Pause" ~ btn button Stop "Stop" ~ btn viewStatus n viewStatus :: Int -> View Poller () viewStatus n = do el $ do text "Polling... " text $ pack $ show n source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Concurrency/Progress.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Concurrency.Progress where import App.Docs import Control.Monad (when) import Data.Text (pack) import Effectful import Example.Colors import Example.Concurrency.Tasks import Example.Effects.Debug import Example.View.Inputs (progressBar) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.Effect.GenRandom ----------------------------------------------------------- -- Overlapping Progress Bars ----------------------------------------------------------- type PercentPerTick = Int data Progress = Progress TaskId deriving (Generic, ViewId) instance (Debug :> es, GenRandom :> es) => HyperView Progress es where data Action Progress = GoProgress PercentPerTick deriving (Generic, ViewAction) update (GoProgress progPerTick) = do _ <- tick 0 pure $ viewProgress 100 where tick current = do -- pretend we did some work -- this will not block other hyperviews from updating delay 50 let total = current + progPerTick when (total < 100) $ do pushUpdate $ viewProgress total tick total viewProgressLoad :: PercentPerTick -> View Progress () viewProgressLoad p = el @ onLoad (GoProgress p) 50 $ none viewProgress :: Int -> View Progress () viewProgress prg | prg >= 100 = viewComplete | otherwise = viewUpdating where viewComplete = do row ~ bg Success . color White . pad 5 $ "Complete" viewUpdating = do let pct = fromIntegral prg / 100 Progress taskId <- viewId progressBar pct $ do el ~ grow $ text $ "Task" <> pack (show taskId) source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Concurrency/Tasks.hs ================================================ module Example.Concurrency.Tasks where import Data.Text (Text, pack) import Effectful import Example.Effects.Debug import Web.Hyperbole.Effect.GenRandom -- Fake Tasks Effect ---------------------------------------- type TaskId = Int data Task = Task { taskId :: TaskId , details :: Text } pretendLoadTask :: (Debug :> es, GenRandom :> es) => TaskId -> Eff es Task pretendLoadTask taskId = do randomDelay <- genRandom (100, 1000) delay randomDelay pure $ Task taskId $ pack (show taskId) pretendTasks :: [TaskId] pretendTasks = [1 .. 30] ================================================ FILE: demo/Example/Contact.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Contact where import App.Route (UserId) import App.Route qualified as Route import Data.Maybe (fromMaybe) import Data.String.Conversions import Data.Text (Text, pack) import App.Docs import Effectful import Effectful.Reader.Dynamic import Example.Colors import Example.Effects.Debug import Example.Effects.Users (User (..), Users) import Example.Effects.Users qualified as Users import Example.Style qualified as Style import Example.Style.Cyber (btn) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole -- Example adding a reader context to the page, based on an argument from the AppRoute response :: (Hyperbole :> es, Users :> es, Debug :> es) => UserId -> Eff es Response response uid = runReader uid $ runPage page -- The page assumes all effects have been added page :: forall es . (Hyperbole :> es, Users :> es, Debug :> es, Reader UserId :> es) => Page es '[Contact] page = do uid <- ask u <- Users.find uid pure $ layout (Route.Contacts Route.ContactsAll) $ do section' "Contact" $ do hyper (Contact uid) $ contactView u -- Contact ---------------------------------------------------- data Contact = Contact UserId deriving (Generic, ViewId) instance (Users :> es, Debug :> es) => HyperView Contact es where data Action Contact = Edit | Save | ViewContact deriving (Generic, ViewAction) update action = do -- No matter which action we are performing, let's look up the user to make sure it exists Contact uid <- viewId u <- Users.find uid case action of ViewContact -> do pure $ contactView u Edit -> do pure $ contactEditView u Save -> do delay 1000 unew <- parseUser uid Users.save unew pure $ contactView unew data ContactForm f = ContactForm { firstName :: Field f Text , lastName :: Field f Text , age :: Field f Int , info :: Field f Text } deriving (Generic, FromFormF, GenFields FieldName, GenFields Maybe) parseUser :: (Hyperbole :> es) => Int -> Eff es User parseUser uid = do ContactForm{firstName, lastName, age, info} <- formData @(ContactForm Identity) pure User{id = uid, isActive = True, firstName, lastName, age, info} contactView :: User -> View Contact () contactView = contactView' Edit contactView' :: (ViewId c, ViewAction (Action c)) => Action c -> User -> View c () contactView' edit u = do col ~ gap 10 $ do row ~ fld $ do el (text "First Name:") text u.firstName row ~ fld $ do el (text "Last Name:") text u.lastName row ~ fld $ do el (text "Age:") text (cs $ show u.age) row ~ fld $ do el (text "Info:") text u.info row ~ fld $ do el (text "Active:") text (cs $ show u.isActive) button edit "Edit" ~ btn where fld = gap 10 contactEditView :: User -> View Contact () contactEditView u = do el contactLoading ~ display None . whenLoading flexCol el (contactEdit ViewContact Save u) ~ whenLoading (display None) contactEdit :: (ViewId c, ViewAction (Action c)) => Action c -> Action c -> User -> View c () contactEdit onView onSave u = do col ~ gap 10 $ do contactForm onSave contactFromUser button onView (text "Cancel") ~ Style.btnLight where contactFromUser :: ContactForm Maybe contactFromUser = ContactForm { firstName = Just u.firstName , lastName = Just u.lastName , age = Just u.age , info = Just u.info } contactForm :: (ViewId id, ViewAction (Action id)) => Action id -> ContactForm Maybe -> View id () contactForm onSubmit c = do let f = fieldNames @ContactForm form onSubmit ~ gap 10 $ do field f.firstName ~ fld $ do label $ do text "First Name:" input Name @ value (fromMaybe "" c.firstName) ~ Style.input field f.lastName ~ fld $ do label $ do text "Last Name:" input Name @ value (fromMaybe "" c.lastName) ~ Style.input field f.info ~ fld $ do label $ do text "Info:" textarea c.info @ value (fromMaybe "" c.info) ~ Style.input field f.age ~ fld $ do label $ do text "Age:" input Number @ value (maybe "" (pack . show) c.age) ~ inp submit "Submit" ~ btn where fld :: (Styleable a) => CSS a -> CSS a fld = flexRow . gap 10 inp = Style.input contactLoading :: View id () contactLoading = el ~ (bg Warning . pad 10) $ "Loading..." ================================================ FILE: demo/Example/Contacts.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Contacts where import App.Docs import App.Route (UserId) import App.Route qualified as Route import Control.Monad (forM_) import Effectful import Example.Colors import Example.Contact (ContactForm, contactForm, contactLoading, contactView', parseUser) import Example.Contact qualified as Contact import Example.Effects.Debug import Example.Effects.Users (User (..), Users) import Example.Effects.Users qualified as Users import Example.Style qualified as Style import Example.Style.Cyber (btn, btn', btnLight) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole page :: forall es . (Hyperbole :> es, Users :> es, Debug :> es) => Page es '[Contacts, InlineContact, NewContact] page = do us <- Users.all pure $ layout (Route.Contacts Route.ContactsAll) $ do example $(moduleSource) $ do hyper Contacts $ allContactsView Nothing us -- Contacts ---------------------------------------------- data Contacts = Contacts deriving (Generic, ViewId) data Filter = Active | Inactive deriving (Eq, Show, Read, Generic, ToJSON, FromJSON, ToParam, FromParam) instance (Users :> es, Debug :> es) => HyperView Contacts es where data Action Contacts = Reload (Maybe Filter) | AddUser | DeleteUser UserId deriving (Generic, ViewAction) type Require Contacts = '[InlineContact, NewContact] update = \case Reload mf -> do us <- Users.all pure $ allContactsView mf us AddUser -> do uid <- Users.nextId u <- parseUser uid Users.save u us <- Users.all pure $ allContactsView Nothing us DeleteUser uid -> do Users.delete uid us <- Users.all pure $ allContactsView Nothing us -- TODO: get the form to close when submitted allContactsView :: Maybe Filter -> [User] -> View Contacts () allContactsView fil us = col ~ gap 20 $ do row ~ gap 10 $ do el ~ pad 10 $ "Filter: " dropdown Reload fil $ do option Nothing "" option (Just Active) "Active!" option (Just Inactive) "Inactive" row ~ gap 10 $ do let filtered = filter (filterUsers fil) us forM_ filtered $ \u -> do el ~ border 1 . pad 10 $ do hyper (InlineContact u.id) $ contactView u row $ do space route (Route.Contacts $ Route.Contact u.id) "details" ~ Style.link row ~ gap 10 $ do button (Reload Nothing) ~ Style.btnLight $ "Reload" target (InlineContact 2) () $ button Edit ~ Style.btnLight $ "Edit Sara" hyper NewContact newContactButton where filterUsers Nothing _ = True filterUsers (Just Active) u = u.isActive filterUsers (Just Inactive) u = not u.isActive -- New Contact Form / Button ---------------------------------- -- Note that it is easier to nest hyperviews here because NewContact has sufficiently different state -- * It doesn't need to know the users -- * It DOES need to track it's open / close state -- * We use target to submit the form to the Contacts parent view data NewContact = NewContact deriving (Generic, ViewId) instance (Users :> es) => HyperView NewContact es where data Action NewContact = ShowForm | CloseForm deriving (Generic, ViewAction) type Require NewContact = '[Contacts] update action = case action of ShowForm -> pure newContactForm CloseForm -> pure newContactButton newContactButton :: View NewContact () newContactButton = do button ShowForm ~ btn $ "Add Contact" 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" -- Reuse Contact View ---------------------------------- -- We want to use the same view as Example.Contact, but customize the edit view to have a delete button -- Note that we re-implement the actions and the handler -- Just create functions to deduplicate code and use them here data InlineContact = InlineContact UserId deriving (Generic, ViewId) instance (Users :> es, Debug :> es) => HyperView InlineContact es where data Action InlineContact = Edit | ViewContact | Save deriving (Generic, ViewAction) type Require InlineContact = '[Contacts] update a = do InlineContact uid <- viewId u <- Users.find uid case a of ViewContact -> pure $ contactView u Edit -> pure $ contactEdit u Save -> do delay 1000 unew <- parseUser uid Users.save unew pure $ contactView unew -- See how we reuse the contactView' from Example.Contact contactView :: User -> View InlineContact () contactView = contactView' Edit -- See how we reuse the contactEdit' and contactLoading from Example.Contact contactEdit :: User -> View InlineContact () contactEdit u = do el ~ (display None . whenLoading flexCol) $ contactLoading col ~ (whenLoading (display None) . gap 10) $ do Contact.contactEdit ViewContact Save u target Contacts () $ button (DeleteUser u.id) ~ btn' Danger . pad (XY 10 0) $ text "Delete" ================================================ FILE: demo/Example/Counter.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Counter where import Data.Text (pack) import Effectful import Example.Style.Cyber as Style import Web.Atomic.CSS import Web.Hyperbole as Hyperbole page :: (Hyperbole :> es) => Page es '[Counter] page = do pure $ hyper Counter (viewCount 0) data Counter = Counter deriving (Generic, ViewId) instance HyperView Counter es where data Action Counter = Increment Int | Decrement Int deriving (Generic, ViewAction) update (Increment n) = do pure $ viewCount (n + 1) update (Decrement n) = do pure $ viewCount (n - 1) viewCount :: Int -> View Counter () viewCount n = row $ do col ~ gap 10 $ do el ~ dataFeature $ text $ pack $ show n row ~ gap 10 $ do button (Decrement n) "Decrement" ~ Style.btn button (Increment n) "Increment" ~ Style.btn ================================================ FILE: demo/Example/Data/ProgrammingLanguage.hs ================================================ {-# LANGUAGE DerivingVia #-} module Example.Data.ProgrammingLanguage where import Data.Text (Text, isInfixOf, toLower) import Web.Hyperbole data ProgrammingLanguage = ProgrammingLanguage { family :: LanguageFamily , name :: Text , features :: [TypeFeature] , description :: Text } deriving (Generic, ToParam, FromParam) instance Eq ProgrammingLanguage where p1 == p2 = p1.name == p2.name data LanguageFamily = Functional | ObjectOriented deriving (Eq, Show, ToJSON, FromJSON, Ord, Generic, ToParam, FromParam) data TypeFeature = Dynamic | Typed | Generics | TypeClasses | TypeFamilies deriving (Eq, Show, ToJSON, FromJSON, Generic, ToParam, FromParam) isMatchLanguage :: Text -> ProgrammingLanguage -> Bool isMatchLanguage term p = isInfixOf (toLower term) . toLower $ p.name allLanguages :: [ProgrammingLanguage] allLanguages = [ ProgrammingLanguage ObjectOriented "JavaScript" [Dynamic] "A versatile scripting language mainly used for web development." , ProgrammingLanguage ObjectOriented "Java" [Typed] "A robust, platform-independent language commonly used for enterprise applications." , ProgrammingLanguage ObjectOriented "TypeScript" [Typed, Generics] "A superset of JavaScript that adds static typing." , ProgrammingLanguage ObjectOriented "Python" [Dynamic] "A beginner-friendly language with a wide range of applications, from web to data science." , ProgrammingLanguage ObjectOriented "PHP" [Dynamic] "A server-side scripting language primarily used for web development." , ProgrammingLanguage ObjectOriented "Go" [Typed, Generics] "A statically typed, compiled language designed for simplicity and efficiency." , ProgrammingLanguage ObjectOriented "C++" [Typed] "A powerful language for system programming, game development, and high-performance applications." , ProgrammingLanguage ObjectOriented "C#" [Typed, Generics] "A language developed by Microsoft, widely used for developing Windows and web applications." , ProgrammingLanguage ObjectOriented "Objective-C" [Typed] "A language used primarily for macOS and iOS application development before Swift." , ProgrammingLanguage ObjectOriented "Rust" [Typed, Generics, TypeClasses, TypeFamilies] "A memory-safe language focused on performance and reliability." , ProgrammingLanguage ObjectOriented "Ruby" [Dynamic] "A dynamic language known for its simplicity and used in web frameworks like Ruby on Rails." , ProgrammingLanguage ObjectOriented "Swift" [Typed, Generics] "A modern language for iOS and macOS application development." , ProgrammingLanguage Functional "Haskell" [Typed, Generics, TypeClasses, TypeFamilies] "An elegant functional language for those with excellent taste." , ProgrammingLanguage Functional "Elm" [Typed, Generics] "A functional language for building reliable web front-end applications." , ProgrammingLanguage Functional "Scheme" [Dynamic] "A minimalist, functional dialect of Lisp." ] ================================================ FILE: demo/Example/DataLists/Autocomplete.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.DataLists.Autocomplete where import App.Docs import App.Route as Route import Control.Monad (forM_) import Data.Text (Text) import Data.Text qualified as T import Effectful import Example.Colors import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages, isMatchLanguage) import Example.DataLists.Filter as Filter (chosenView, clearButton, resultsTable) import Example.View.Layout import Safe (atMay) import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) page :: (Hyperbole :> es) => Page es '[LiveSearch] page = do pure $ layout (Data Autocomplete) $ do el "Create a serverside autocomplete with a combination of onInput and onKeyDown" example $(moduleSource) $ do hyper LiveSearch $ liveSearchView allLanguages 0 "" data LiveSearch = LiveSearch deriving (Generic, ViewId) instance (IOE :> es) => HyperView LiveSearch es where data Action LiveSearch = SearchTerm Int Text | Select (Maybe ProgrammingLanguage) deriving (Generic, ViewAction) -- favor the latest thing typed type Concurrency LiveSearch = Replace update (SearchTerm current term) = do pure $ liveSearchView allLanguages current term update (Select Nothing) = do pure $ liveSearchView allLanguages 0 "" update (Select (Just lang)) = do pure $ selectedView lang selectedView :: ProgrammingLanguage -> View LiveSearch () selectedView selected = do col ~ gap 10 $ do Filter.chosenView selected liveSearchView :: [ProgrammingLanguage] -> Int -> Text -> View LiveSearch () liveSearchView langs current term = do col ~ gap 10 $ do el ~ stack $ do search (SearchTerm current) 250 @ searchKeys . placeholder "search programming languages" . value term . autofocus ~ border 1 . pad 10 . grow Filter.clearButton (SearchTerm current) term col ~ popup (TRBL 50 0 0 0) . shownIfMatches $ do searchPopup matchedLanguages currentSearchLang Filter.resultsTable (Select . Just) langs where matchedLanguages = filter (isMatchLanguage term) langs currentSearchLang = matchedLanguages `atMay` current -- Only show the search popup if there is a search term and matchedLanguages shownIfMatches = if T.null term || null matchedLanguages then display None else flexCol searchKeys = onKeyDown Enter (Select currentSearchLang) . onKeyDown ArrowDown (SearchTerm (current + 1) term) . onKeyDown ArrowUp (SearchTerm (current - 1) term) searchPopup :: [ProgrammingLanguage] -> Maybe ProgrammingLanguage -> View LiveSearch () searchPopup shownLangs highlighted = do col ~ border 1 . bg White $ do forM_ shownLangs $ \lang -> do button (Select (Just lang)) ~ hover (bg Light) . selected lang . pad 5 $ do text lang.name where selected l = if Just l == highlighted then bg Light else id ================================================ FILE: demo/Example/DataLists/DataTable.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Example.DataLists.DataTable where import App.Docs import App.Route as Route import Data.List (sortOn) import Data.Text (pack) import Effectful import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages) import Example.View.Layout import Example.View.SortableTable (dataTable, sortBtn, sortColumn) import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) -- DataTable -> do -- el "Complex reusable View Functions allow us to " page :: (Hyperbole :> es) => Page es '[Languages] page = do pure $ layout (Data SortableTable) $ do el "We can write view Functions that work in any view, like a dataTable" example $(moduleSource) $ do hyper Languages $ languagesView Nothing allLanguages data Languages = Languages deriving (Generic, ViewId) data SortField = SortName | SortDescription | SortFamily deriving (Show, Read, Eq, Generic, ToJSON, FromJSON, ToParam, FromParam) instance HyperView Languages es where data Action Languages = SortOn SortField deriving (Generic, ViewAction) update (SortOn fld) = do let sorted = sortOnField fld allLanguages pure $ languagesView (Just fld) sorted sortOnField :: SortField -> [ProgrammingLanguage] -> [ProgrammingLanguage] sortOnField = \case SortName -> sortOn (.name) SortDescription -> sortOn (.description) SortFamily -> sortOn (.family) languagesView :: Maybe SortField -> [ProgrammingLanguage] -> View Languages () languagesView fld langs = table langs ~ dataTable $ do sortColumn (sortBtn "Language" (SortOn SortName) (fld == Just SortName)) (.name) sortColumn (sortBtn "Family" (SortOn SortFamily) (fld == Just SortFamily)) $ \d -> pack $ show d.family sortColumn (sortBtn "Description" (SortOn SortDescription) (fld == Just SortDescription)) (.description) ================================================ FILE: demo/Example/DataLists/Filter.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.DataLists.Filter where import App.Docs import App.Route as Route import Data.Text (Text, pack) import Effectful hiding (Dynamic) import Example.Colors import Example.Data.ProgrammingLanguage (LanguageFamily (..), ProgrammingLanguage (..), TypeFeature (..), allLanguages, isMatchLanguage) import Example.View.Icon as Icon import Example.View.Inputs (toggleCheckbox) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) page :: (Hyperbole :> es, IOE :> es) => Page es '[Languages] page = do filters <- query pure $ layout (Data Filter) $ do el "Incrementally search a list of data, storing parameters in the query string" example $(moduleSource) $ do hyper Languages $ languagesView filters data Languages = Languages deriving (Generic, ViewId) -- Filters available from the query -- See Example.Data.ProgrammingLanguage data Filters = Filters { features :: [TypeFeature] , family :: Maybe LanguageFamily , term :: Text } deriving (Generic, Show, FromQuery, ToQuery) instance (IOE :> es) => HyperView Languages es where data Action Languages = SearchTerm Text | Select ProgrammingLanguage | Feature TypeFeature Bool | SetFamily (Maybe LanguageFamily) deriving (Generic, ViewAction) -- favor the latest thing entered / typed type Concurrency Languages = Replace update = \case Select lang -> do pure $ chosenView lang SearchTerm term -> do filters <- modFilters $ \f -> f{term} pure $ languagesView filters Feature feature selected -> do filters <- modFilters $ \f -> setFeatures feature selected f pure $ languagesView filters SetFamily f -> do filters <- modFilters $ \Filters{features, term} -> Filters{family = f, features, term} pure $ languagesView filters where setFeatures feature selected Filters{term, family, features} = let features' = if selected then addFeature feature features else delFeature feature features in Filters{term, family, features = features'} addFeature f fs | f `elem` fs = fs | otherwise = f : fs delFeature feature = filter (/= feature) modFilters f = do filts <- query let filts' = f filts setQuery filts' pure filts' -- apply our filters, return any languages that match filterLanguages :: Filters -> [ProgrammingLanguage] filterLanguages filts = filter match allLanguages where match lang = isMatchLanguage filts.term lang && matchFamily filts.family lang && matchFeatures filts.features lang matchFamily Nothing _ = True matchFamily (Just fam) lang = lang.family == fam matchFeatures feats lang = all (\f -> f `elem` lang.features) feats languagesView :: Filters -> View Languages () languagesView filters = do let matched = filterLanguages filters col ~ gap 10 . grow $ do filtersView filters resultsTable Select matched filtersView :: Filters -> View Languages () filtersView filters = do el ~ stack . grow $ do search SearchTerm 250 @ placeholder "filter programming languages" . value filters.term . autofocus ~ border 1 . pad 10 clearButton SearchTerm filters.term row $ do col ~ gap 5 $ do el ~ bold $ "Language Family" familyDropdown filters space col ~ gap 5 $ do el ~ bold $ "Type System Features" feature Dynamic feature Typed feature Generics feature TypeClasses feature TypeFamilies where feature f = row ~ gap 10 $ do toggleCheckbox (Feature f) (f `elem` filters.features) el $ text (featureName f) featureName f = pack $ show f 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" clearButton :: (ViewAction (Action id)) => (Text -> Action id) -> Text -> View id () clearButton clear term = el ~ popup (R 0) . pad 10 . showClearBtn $ do button (clear "") ~ width 24 . hover (color PrimaryLight) $ Icon.xCircle where showClearBtn = case term of "" -> display None _ -> id chosenView :: ProgrammingLanguage -> View c () chosenView lang = do row ~ gap 10 $ do el "You chose:" el $ text lang.name el ~ (if lang.name == "Haskell" then id else display None) $ "You are as wise as you are attractive" resultsTable :: (ViewAction (Action id)) => (ProgrammingLanguage -> Action id) -> [ProgrammingLanguage] -> View id () resultsTable onSelect langs = do col ~ gap 15 $ do mapM_ languageRow langs where languageRow lang = do col ~ gap 5 $ do row ~ gap 5 $ do el ~ bold $ text lang.name space button (onSelect lang) ~ pad (XY 10 2) . border 1 . hover (bg GrayLight) . rows $ "Select" row $ viewFamily lang.family row ~ gap 5 $ do el $ text lang.description rows = textAlign AlignCenter . border 1 . borderColor GrayLight viewFamily :: LanguageFamily -> View c () viewFamily fam = do el ~ bg Light . pad (XY 10 2) . fontSize 16 . textAlign AlignCenter $ family fam where family Functional = "Functional" family ObjectOriented = "Object Oriented" ================================================ FILE: demo/Example/DataLists/LoadMore.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.DataLists.LoadMore where import App.Docs import App.Route as Route import Effectful import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages) import Example.DataLists.Filter (viewFamily) import Example.Style.Cyber (btn) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) page :: (Hyperbole :> es) => Page es '[Languages] page = do ls <- loadNextLanguages 0 pure $ layout (Data LoadMore) $ do el "Progressively load more data" example $(moduleSource) $ do hyper (Languages 0) $ languagesView ls type Offset = Int -- fake database load of next N language loadNextLanguages :: Offset -> Eff es [ProgrammingLanguage] loadNextLanguages offset = pure $ fmap snd $ filter isInPage $ zip [0 ..] allLanguages where isInPage (n, _) = n >= offset && n < offset + nextLanguagesPageSize nextLanguagesPageSize :: Int nextLanguagesPageSize = 4 data Languages = Languages Offset deriving (Generic, ViewId) instance HyperView Languages es where data Action Languages = Load deriving (Generic, ViewAction) update Load = do Languages offset <- viewId ls <- loadNextLanguages offset pure $ languagesView ls languagesView :: [ProgrammingLanguage] -> View Languages () languagesView ls = do col ~ gap 20 $ do mapM_ languageView ls col ~ pad (TRBL 20 0 0 0) $ do nextLanguages ls nextLanguages :: [ProgrammingLanguage] -> View Languages () nextLanguages ls | length ls < nextLanguagesPageSize = pure () | otherwise = do Languages off <- viewId hyper (Languages (off + nextLanguagesPageSize)) $ do button Load ~ btn $ "Load More" languageView :: ProgrammingLanguage -> View Languages () languageView lang = do col ~ gap 6 $ do row $ do el ~ bold $ text lang.name space row $ viewFamily lang.family el $ text lang.description ================================================ FILE: demo/Example/Docs/App.hs ================================================ module Example.Docs.App where import Data.Text (Text) import Effectful import Effectful.Concurrent import Effectful.Dispatch.Dynamic (send) import Effectful.Reader.Dynamic import Example.Docs.Page.Messages qualified as Messages import Example.Docs.Page.Users qualified as Users import Example.Docs.SideEffects as SideEffects import Example.Effects.Users (User, Users (..)) import Web.Hyperbole import Web.Hyperbole.Effect.Response (view) documentHead :: View DocumentHead () documentHead = do title "My Website" script' scriptEmbed style cssEmbed script "custom.js" 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" type UserId = Int data AppRoute = Main | Messages | User UserId deriving (Eq, Generic) instance Route AppRoute where baseRoute = Just Main 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 userView :: User -> View c () userView _ = none app :: Application app = liveApp (document documentHead) (routeRequest router) data AppConfig = AppConfig runApp :: (Hyperbole :> es, IOE :> es) => AppConfig -> Eff (Reader AppConfig : Concurrent : es) a -> Eff es a runApp config = runConcurrent . runReader config app' :: AppConfig -> Application app' config = liveApp (document documentHead) (runApp config $ routeRequest router') router' :: (Hyperbole :> es, Concurrent :> es) => AppRoute -> Eff es Response router' Messages = runReader @Text "Secret Message!" $ runPage SideEffects.page router' (User cid) = runPage $ Users.page cid router' Main = pure $ view "..." ================================================ FILE: demo/Example/Docs/BasicPage.hs ================================================ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Example.Docs.BasicPage where import Data.Text (Text) import Web.Hyperbole main :: IO () main = do run 3000 $ liveApp quickStartDocument (runPage hello) hello :: Page es '[] hello = do pure $ el "Hello World" messageView :: Text -> View context () messageView msg = el $ text msg helloWorld :: View context () helloWorld = el "Hello World" page :: Page es '[] page = do pure $ messageView "Hello World" ================================================ FILE: demo/Example/Docs/CSS.hs ================================================ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-unused-binds #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Example.Docs.CSS where import Web.Atomic.CSS import Web.Hyperbole example = do col $ do el ~ h3 $ "My Page" el ~ btn $ "Hover Me" where header = bold h1 = header . fontSize 32 h2 = header . fontSize 24 h3 = header . fontSize 18 btn = pad 10 . border 1 . pointer . hover (bold . border 2) ================================================ FILE: demo/Example/Docs/Client.hs ================================================ module Example.Docs.Client where import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[] page = do pageTitle "My Page Title" pure $ el "Hello World" ================================================ FILE: demo/Example/Docs/Component.hs ================================================ module Example.Docs.Component where import Data.Text (Text) import Example.Colors import Web.Atomic.CSS import Web.Hyperbole styledButton :: (ViewAction (Action id)) => Action id -> Text -> View id () styledButton clickAction lbl = do button clickAction ~ btn $ text lbl where btn = pad 10 . bg Primary . hover (bg PrimaryLight) . rounded 5 ================================================ FILE: demo/Example/Docs/Encoding.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Docs.Encoding where import Data.Text (Text) import Web.Hyperbole data Filters = Filters { active :: Bool , term :: Text } deriving (Generic, Eq, FromQuery, ToQuery) ================================================ FILE: demo/Example/Docs/Interactive.hs ================================================ module Example.Docs.Interactive where import Example.Simple import Web.Hyperbole page :: Page es '[Message] page = do pure $ do el "Unchanging Header" hyper Message1 $ messageView "Hello" hyper Message2 $ messageView "World" ================================================ FILE: demo/Example/Docs/MultiPage.hs ================================================ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Example.Docs.MultiPage where import Example.Docs.Interactive qualified as Message import Example.Docs.MultiView qualified as Counter import Web.Atomic.CSS import Web.Hyperbole data AppRoute = Message -- /message | Counter -- /counter deriving (Generic, Eq, Route) main = do run 3000 $ do liveApp quickStartDocument (routeRequest router) where router Message = runPage Message.page router Counter = runPage Counter.page menu :: View c () menu = do route Message "Link to /message" route Counter "Link to /counter" exampleLayout :: View c () -> View c () exampleLayout contents = do col ~ grow $ do el ~ border 1 $ "My Website Header" row $ do menu contents examplePage :: Page es '[] examplePage = do pure $ exampleLayout $ do el "page contents" ================================================ FILE: demo/Example/Docs/MultiView.hs ================================================ module Example.Docs.MultiView where import Example.Counter (Counter (..), viewCount) import Example.Simple (Message (..), messageView) import Web.Hyperbole page :: Page es [Message, Counter] page = do pure $ do hyper Message1 $ messageView "Hello" hyper Message2 $ messageView "World" hyper Counter $ viewCount 0 ================================================ FILE: demo/Example/Docs/Nested.hs ================================================ module Example.Docs.Nested where import Control.Monad (forM_) import Data.Text (Text) import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[AllTodos, TodoItem] page = do pure $ do hyper AllTodos $ todosView allTodos where allTodos = [todo "One", todo "Two", todo " Three"] todo t = Todo t False data Todo = Todo { task :: Text , completed :: Bool } deriving (Generic, ToParam, FromParam) data AllTodos = AllTodos deriving (Generic, ViewId) instance HyperView AllTodos es where type Require AllTodos = '[TodoItem] data Action AllTodos = AddTodo Text [Todo] deriving (Generic, ViewAction) update (AddTodo txt todos) = do let new = Todo txt False : todos pure $ todosView new todosView :: [Todo] -> View AllTodos () todosView todos = do forM_ todos $ \todo -> do hyper TodoItem $ todoView todo button (AddTodo "Shopping" todos) "Add Todo: Shopping" data TodoItem = TodoItem deriving (Generic, ViewId) instance HyperView TodoItem es where data Action TodoItem = Complete Todo deriving (Generic, ViewAction) update (Complete todo) = do let new = todo{completed = True} pure $ todoView new todoView :: Todo -> View TodoItem () todoView todo = do el (text todo.task) button (Complete todo) "Mark Completed" ================================================ FILE: demo/Example/Docs/Nesting.hs ================================================ module Example.Docs.Nesting where import Control.Monad (forM_) import Example.Colors import Example.Docs.UniqueViewId hiding (loadDummyItemIds) import Example.Style.Cyber (btnLight) import Web.Atomic.CSS import Web.Hyperbole page :: Page es '[ItemList, Item] page = do itemIds <- loadDummyItemIds pure $ hyper ItemList $ itemList itemIds data ItemList = ItemList deriving (Generic, ViewId) instance HyperView ItemList es where data Action ItemList = Reset deriving (Generic, ViewAction) type Require ItemList = '[Item] update Reset = do itemIds <- loadDummyItemIds pure $ itemList itemIds -- need to load different item ids, because both examples are on the same documentation page! loadDummyItemIds :: Eff es [Int] loadDummyItemIds = pure [5 .. 9] itemList :: [Int] -> View ItemList () itemList itemIds = do row ~ gap 4 . color White $ do forM_ itemIds $ \itemId -> do hyper (Item itemId) itemUnloaded button Reset ~ btnLight $ "Reset" ================================================ FILE: demo/Example/Docs/Page/Messages.hs ================================================ module Example.Docs.Page.Messages where import Web.Hyperbole page :: Page es '[] page = pure $ el "Messages page" ================================================ FILE: demo/Example/Docs/Page/Users.hs ================================================ module Example.Docs.Page.Users where import Web.Hyperbole page :: Int -> Page es '[] page _ = pure $ el "User page" ================================================ FILE: demo/Example/Docs/Params.hs ================================================ module Example.Docs.Params where import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole 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 data Todos = Todos deriving (Generic, ViewId) 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 -- Fake User effect data Todo loadTodos :: Filters -> Eff es [Todo] loadTodos _ = pure [] -- Fake Todo View todosView :: [Todo] -> View Todos () todosView _ = none page' :: (Hyperbole :> es) => Page es '[Message] page' = do msg <- param "message" pure $ do hyper Message $ messageView msg messageView :: Text -> View Message () messageView m = do el ~ bold $ text $ "Message: " <> m button (SetMessage "Goodbye") ~ border 1 $ "Say Goodbye" data Message = Message deriving (Generic, ViewId) instance HyperView Message es where data Action Message = SetMessage Text deriving (Generic, ViewAction) update (SetMessage msg) = do setParam "message" msg pure $ messageView msg ================================================ FILE: demo/Example/Docs/QueryMessage.hs ================================================ module Example.Docs.QueryMessage where import Data.Maybe (fromMaybe) import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[Message] page = do prm <- lookupParam "msg" let msg = fromMaybe "hello" prm pure $ do hyper Message $ messageView msg data Message = Message deriving (Generic, ViewId) instance HyperView Message es where data Action Message = Louder Text deriving (Generic, ViewAction) update (Louder msg) = do let new = msg <> "!" setParam "msg" new pure $ messageView new messageView :: Text -> View Message () messageView m = do button (Louder m) ~ border 1 $ "Louder" el ~ bold $ text $ "Message: " <> m ================================================ FILE: demo/Example/Docs/Sessions.hs ================================================ module Example.Docs.Sessions where import Web.Atomic.CSS import Web.Hyperbole data AppColor = White | Red | Green deriving (Show, Generic, ToParam, FromParam) instance Default AppColor where def = White instance ToColor AppColor where colorValue White = "#FFF" colorValue Red = "#F00" colorValue Green = "#0F0" data Preferences = Preferences { color :: AppColor } deriving (Generic, ToEncoded, FromEncoded, 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" data Content = Content deriving (Generic, ViewId) 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" ================================================ FILE: demo/Example/Docs/SideEffects.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Docs.SideEffects where import Data.Text (Text) import App.Docs import Effectful import Effectful.Concurrent import Effectful.Reader.Dynamic import Example.Colors import Example.Style.Cyber import Web.Atomic.CSS import Web.Hyperbole -- page :: (Hyperbole :> es, Concurrent :> es) => Page es '[] -- page = do -- threadDelay 1000 -- let msg = fromMaybe "hello" prm -- pure $ do -- hyper Message $ messageView msg -- page :: (Hyperbole :> es, IOE :> es) => Page es '[Message] -- page = do -- prm <- lookupParam "msg" -- let msg = fromMaybe "hello" prm -- pure $ do -- hyper Message $ messageView msg app :: Application app = do liveApp quickStartDocument $ do runConcurrent . runReader @Text "Secret!" $ runPage page page :: (Hyperbole :> es, Concurrent :> es, Reader Text :> es) => Page es '[SlowReader] page = do pure $ hyper SlowReader $ messageView "..." data SlowReader = SlowReader deriving (Generic, ViewId) instance (Concurrent :> es, Reader Text :> es) => HyperView SlowReader es where data Action SlowReader = GetMessage deriving (Generic, ViewAction) update GetMessage = do threadDelay 500000 msg <- ask pure $ messageView msg messageView :: Text -> View SlowReader () messageView m = do el ~ bold . whenLoading (color SecondaryLight) $ text $ "Message: " <> m button GetMessage ~ btn $ "Get Message from Reader" -- data Message = Message -- deriving (Generic, ViewId) -- -- instance (IOE :> es) => HyperView Message es where -- data Action Message -- = Louder Text -- deriving (Generic, ViewAction) -- -- update (Louder msg) = do -- let new = msg <> "!" -- setParam "msg" new -- pure $ messageView new -- -- messageView :: Text -> View Message () -- messageView m = do -- button (Louder m) ~ border 1 $ "Louder" -- el ~ bold $ text $ "Message: " <> m data Titler = Titler deriving (Generic, ViewId) instance HyperView Titler es where data Action Titler = SetTitle Text deriving (Generic, ViewAction) update (SetTitle msg) = do pageTitle msg pure "Check the title" titleView :: View Titler () titleView = do button (SetTitle "Hello") ~ btn $ "Set Title" source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Docs/State.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Docs.State where import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole messageView :: Text -> View Message () messageView m = do button (Louder m) ~ border 1 $ "Louder" el ~ bold $ text m page :: Page es '[Message] page = do pure $ do hyper Message $ messageView "Hello" data Message = Message deriving (Generic, ViewId) instance HyperView Message es where data Action Message = Louder Text deriving (Generic, ViewAction) update (Louder m) = do let new = m <> "!" pure $ messageView new ================================================ FILE: demo/Example/Docs/UniqueViewId.hs ================================================ module Example.Docs.UniqueViewId where import Control.Monad (forM_) import Data.Text (Text, pack) import Example.Colors import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole page :: Page es '[Item] page = do itemIds <- loadDummyItemIds pure $ do row ~ gap 4 $ do forM_ itemIds $ \uid -> do hyper (Item uid) itemUnloaded -- Item ---------------------------------------------------------------- type UniqueId = Int data Item = Item UniqueId deriving (Generic, ViewId) instance HyperView Item es where data Action Item = Load deriving (Generic, ViewAction) update Load = do Item uid <- viewId item <- loadDummyItem uid pure $ itemLoaded item itemUnloaded :: View Item () itemUnloaded = do Item uid <- viewId button Load ~ btn $ text $ "Load " <> pack (show uid) itemLoaded :: Text -> View Item () itemLoaded msg = do el ~ bg SecondaryLight . color White . pad 10 $ text msg -- Fake Database ------------------------------------------------------ loadDummyItem :: Int -> Eff es Text loadDummyItem n = pure $ items !! n where items = ["zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten"] loadDummyItemIds :: Eff es [Int] loadDummyItemIds = pure [0 .. 4] ================================================ FILE: demo/Example/Docs/ViewFunctions.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Docs.ViewFunctions where import Data.Text (Text) import App.Docs import Example.Style.Cyber (btn) import Example.View.Inputs (progressBar, toggleCheckbox) import Web.Atomic.CSS import Web.Hyperbole page :: Page es '[Message] page = do pure $ do hyper VFMessage $ messageView "Hello" data Message = VFMessage deriving (Generic, ViewId) instance HyperView Message es where data Action Message = SetMessage Text deriving (Generic, ViewAction) update (SetMessage t) = pure $ messageView t messageView :: Text -> View Message () messageView m = do header m messageButton "Salutations!" messageButton "Good Morning!" messageButton "Goodbye" messageButton :: Text -> View Message () messageButton msg = do button (SetMessage msg) ~ btn $ text $ "Say " <> msg header :: Text -> View ctx () header txt = do el ~ bold $ text txt source :: ModuleSource source = $(moduleSource) -- Toggle Examples ---------------------------- data Toggler = Toggler deriving (Generic, ViewId) instance HyperView Toggler es where data Action Toggler = Toggle Bool deriving (Generic, ViewAction) update (Toggle b) = -- do something with the data pure $ toggler b toggler :: Bool -> View Toggler () toggler b = row ~ gap 10 $ do toggleCheckbox Toggle b text "I am using view functions" -- Progress Example ------------------------ data Progress = Progress deriving (Generic, ViewId) instance HyperView Progress es where data Action Progress = MakeProgress Float deriving (Generic, ViewAction) update (MakeProgress pct) = pure $ workingHard (pct + 0.1) workingHard :: Float -> View Progress () workingHard prog = row ~ gap 10 $ do button (MakeProgress prog) ~ btn $ " + Progress" progressBar prog ~ grow $ do el ~ grow . fontSize 18 $ if prog >= 1 then "Done!" else "Working..." ================================================ FILE: demo/Example/Document.hs ================================================ module Example.Document where import Web.Hyperbole main :: IO () main = do run 3000 $ liveApp (document documentHead) (runPage hello) documentHead :: View DocumentHead () documentHead = do title "Best Website Ever" mobileFriendly style cssEmbed script' scriptEmbed stylesheet "/mysite.css" hello :: Page es '[] hello = do pure $ el "Hello World" ================================================ FILE: demo/Example/Effects/Debug.hs ================================================ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} module Example.Effects.Debug ( Milliseconds , Debug (..) , runDebugIO , dump , delay , systemTime , UTCTime ) where import Control.Concurrent (threadDelay) import Data.String.Interpolate (i) import Data.Time.Clock (UTCTime, getCurrentTime) import Effectful import Effectful.Dispatch.Dynamic type Milliseconds = Int data Debug :: Effect where Dump :: (Show a) => String -> a -> Debug m () Delay :: Milliseconds -> Debug m () Time :: Debug m UTCTime type instance DispatchOf Debug = 'Dynamic runDebugIO :: (IOE :> es) => Eff (Debug : es) a -> Eff es a runDebugIO = interpret $ \_ -> \case Dump msg a -> do liftIO $ putStrLn [i| [#{msg}] #{show a}|] Delay ms -> liftIO $ threadDelay (ms * 1000) Time -> liftIO getCurrentTime dump :: (Debug :> es, Show a) => String -> a -> Eff es () dump msg a = send $ Dump msg a delay :: (Debug :> es) => Milliseconds -> Eff es () delay n = send $ Delay n systemTime :: (Debug :> es) => Eff es UTCTime systemTime = send Time ================================================ FILE: demo/Example/Effects/Todos.hs ================================================ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} module Example.Effects.Todos where import Data.Map (Map) import Data.Map.Strict qualified as M import Data.Text (Text, pack) import Effectful import Effectful.Dispatch.Dynamic import System.Random (randomRIO) import Web.Hyperbole import Web.Hyperbole.Data.JSON type TodoId = Text newtype AllTodos = AllTodos (Map TodoId Todo) deriving (Generic) deriving newtype (ToJSON, FromJSON) deriving (ToEncoded, FromEncoded) via (JSON AllTodos) instance Session AllTodos where sessionKey = "todos" cookiePath = Just "/examples" -- share data between both pages instance Default AllTodos where def = AllTodos mempty data Todo = Todo { id :: TodoId , task :: Text , completed :: Bool } deriving (Generic, ToJSON, FromJSON, ToParam, FromParam) data Todos :: Effect where LoadAll :: Todos m [Todo] Save :: Todo -> Todos m () Remove :: TodoId -> Todos m () Create :: Text -> Todos m TodoId type instance DispatchOf Todos = 'Dynamic runTodosSession :: forall es a . (Hyperbole :> es, IOE :> es) => Eff (Todos : es) a -> Eff es a runTodosSession = interpret $ \_ -> \case LoadAll -> do AllTodos todos <- session pure $ M.elems todos Save todo -> do modifySession_ $ insert todo Remove todoId -> do modifySession_ $ delete todoId Create task -> do todoId <- randomId let todo = Todo todoId task False modifySession_ $ insert todo pure todoId where randomId :: (IOE :> es) => Eff es Text randomId = do n <- randomRIO @Int (0, 9999999) pure $ "todo-" <> pack (show n) insert :: Todo -> AllTodos -> AllTodos insert todo (AllTodos m) = AllTodos (M.insert todo.id todo m) delete :: TodoId -> AllTodos -> AllTodos delete todoId (AllTodos m) = AllTodos (M.delete todoId m) loadAll :: (Todos :> es) => Eff es [Todo] loadAll = send LoadAll create :: (Todos :> es) => Text -> Eff es TodoId create t = send $ Create t setTask :: (Todos :> es) => Text -> Todo -> Eff es Todo setTask task t = do let updated = t{task} send $ Save updated pure updated setCompleted :: (Todos :> es) => Bool -> Todo -> Eff es Todo setCompleted completed todo = do let updated = todo{completed} send $ Save updated pure updated toggleAll :: (Todos :> es) => [Todo] -> Eff es [Todo] toggleAll todos = do let shouldComplete = any (\t -> not t.completed) todos mapM (setCompleted shouldComplete) todos clearCompleted :: (Todos :> es) => Eff es [Todo] clearCompleted = do todos <- loadAll let completed = filter (.completed) todos mapM_ clear completed loadAll clear :: (Todos :> es) => Todo -> Eff es () clear todo = do send $ Remove todo.id filteredTodos :: (Todos :> es) => FilterTodo -> Eff es [Todo] filteredTodos filt = filter (isFilter filt) <$> loadAll where isFilter f todo = case f of FilterAll -> True Active -> not todo.completed Completed -> todo.completed data FilterTodo = FilterAll | Active | Completed deriving (Eq, Generic, ToJSON, FromJSON, ToParam, FromParam) ================================================ FILE: demo/Example/Effects/Users.hs ================================================ {-# LANGUAGE LambdaCase #-} module Example.Effects.Users where import App.Route (UserId) import Control.Concurrent.MVar import Data.Map.Strict (Map) import Data.Map.Strict qualified as M import Data.Text (Text) import Effectful import Effectful.Dispatch.Dynamic import Web.Hyperbole (Hyperbole, notFound) data User = User { id :: UserId , firstName :: Text , lastName :: Text , age :: Int , info :: Text , isActive :: Bool } deriving (Show) -- Load a user AND do next if missing? data Users :: Effect where LoadUser :: UserId -> Users m (Maybe User) LoadUsers :: Users m [User] SaveUser :: User -> Users m () ModifyUser :: UserId -> (User -> User) -> Users m () DeleteUser :: UserId -> Users m () NextId :: Users m UserId type instance DispatchOf Users = 'Dynamic type UserStore = MVar (Map UserId User) runUsersIO :: (IOE :> es) => UserStore -> Eff (Users : es) a -> Eff es a runUsersIO var = interpret $ \_ -> \case LoadUser uid -> do us <- liftIO $ readMVar var pure $ M.lookup uid us LoadUsers -> loadAll SaveUser u -> do modify $ \us -> pure $ M.insert u.id u us ModifyUser uid f -> do modify $ \us -> do pure $ M.adjust f uid us DeleteUser uid -> do modify $ \us -> pure $ M.delete uid us NextId -> do us <- loadAll let umax = maximum $ fmap (.id) us pure (umax + 1) where loadAll :: (MonadIO m) => m [User] loadAll = do us <- liftIO $ readMVar var pure $ M.elems us modify :: (MonadIO m) => (Map UserId User -> IO (Map UserId User)) -> m () modify f = liftIO $ modifyMVar_ var f initUsers :: (MonadIO m) => m UserStore initUsers = liftIO $ newMVar $ M.fromList $ map (\u -> (u.id, u)) users where users = [ User 1 "Joe" "Blow" 32 "" True , User 2 "Sara" "Dane" 24 "" False , User 3 "Billy" "Bob" 48 "" False , User 4 "Felicia" "Korvus" 84 "" True ] find :: (Hyperbole :> es, Users :> es) => Int -> Eff es User find uid = do mu <- send (LoadUser uid) maybe notFound pure mu all :: (Users :> es) => Eff es [User] all = send LoadUsers save :: (Users :> es) => User -> Eff es () save = send . SaveUser delete :: (Users :> es) => Int -> Eff es () delete = send . DeleteUser nextId :: (Users :> es) => Eff es Int nextId = send NextId ================================================ FILE: demo/Example/Errors.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.Errors where import App.Docs import Effectful.Exception import Example.Colors import Text.Read (readMaybe) import Example.Style.Cyber as Cyber (btn) import Control.Monad (forM_) import Data.List qualified as L import Data.Text (Text, pack, unpack) import Web.Atomic.CSS import Web.Hyperbole hiding (Response) -- Exceptiosn data Errors = Exceptions | Customs deriving (Generic, ViewId) instance HyperView Errors es where data Action Errors = CauseServerside | CauseUserFacing | CauseCustom deriving (Generic, ViewAction) update CauseServerside = do _ <- throwIO $ SomeServerError "Oh no!" pure $ el "unreachable" update CauseUserFacing = do _ <- respondError "This is a user-facing custom error" pure $ el "unreachable" update CauseCustom = do _ <- respondErrorView "Something" $ do el ~ border 1 . borderColor Danger . rounded 3 $ "Style errors however you want!" pure $ el "unreachable" viewExceptions :: View Errors () viewExceptions = do row ~ gap 10 $ do button CauseServerside ~ btn $ "Cause Exception" viewCustom :: View Errors () viewCustom = do row ~ gap 10 $ do button CauseUserFacing ~ btn $ "Custom Error Message" button CauseCustom ~ btn $ "Custom Error View" data SomeServerError = SomeServerError String deriving (Show, Eq, Exception) -- Users ------------------------------------------------ data User = User { id :: Int , username :: Text } type UserId = Int type UserName = Text fakeDatabase :: [User] fakeDatabase = [ User 1 "Bob" , User 2 "Sarah" , User 3 "Alice" ] findUser :: UserId -> Eff es (Maybe User) findUser uid = pure $ L.find (\(User i _) -> uid == i) fakeDatabase -- KnownUsers ------------------------------------------------ data Users = KnownUsers | SearchUsers deriving (Generic, ViewId) instance HyperView Users es where data Action Users = UserDetails Int | SearchUser Text deriving (Generic, ViewAction) update (UserDetails uid) = do mu <- findUser uid case mu of Nothing -> notFound Just u -> pure $ do viewWithDetails (viewUserDetails u) viewKnownUsers update (SearchUser term) = do mu <- searchUser term pure $ do viewWithDetails (viewSearchResults mu) viewSearchUsers viewKnownUsers :: View Users () viewKnownUsers = do col ~ gap 10 $ do el "We know all these users exist when the view was rendered, so one going missing is unlikely" row ~ gap 10 $ do forM_ fakeDatabase $ \u -> do button (UserDetails u.id) ~ btn $ text $ "User: " <> pack (show u.id) el "If a user were deleted between when they were rendered and loaded, the error would look like this:" button (UserDetails 4) ~ btn $ "Attempt to load non-existing User 4" viewWithDetails :: View c () -> View c () -> View c () viewWithDetails details cnt = do col ~ gap 10 $ do details cnt viewUserDetails :: User -> View c () viewUserDetails u = do col ~ gap 10 . pad 10 . border 1 $ do el $ do text "ID: " text $ pack $ show u.id el $ do text "Name: " text u.username -- SearchUsers ------------------------------------------------ searchUser :: Text -> Eff es (Maybe User) searchUser searchTerm = pure $ findId searchTerm where findId term = do uid <- readMaybe @Int (unpack term) L.find (\(User i _) -> uid == i) fakeDatabase viewSearchUsers :: View Users () viewSearchUsers = do el "Search for a user by id" search SearchUser 250 ~ border 1 . pad 10 @ placeholder "2" viewSearchResults :: Maybe User -> View c () viewSearchResults mu = do case mu of Nothing -> el ~ italic $ "User not found. No big deal. Doesn't need to be an application error" Just u -> viewUserDetails u source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/FormSimple.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.FormSimple where import App.Docs import Data.Text (Text, pack) import Example.Style qualified as Style import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole source :: ModuleSource source = $(moduleSource) data AddContact = AddContact deriving (Generic, ViewId) instance HyperView AddContact es where data Action AddContact = Submit deriving (Generic, ViewAction) update Submit = do cf <- formData pure $ contactView cf data Planet = Mercury | Venus | Earth | Mars deriving (Generic, FromParam, ToParam, Eq, Show) data Moon = Titan | Europa | Callisto | Mimas deriving (Generic, FromParam, ToParam, Eq, Show) -- Forms can be pretty simple. Just a type that can be parsed data ContactForm = ContactForm { name :: Text , age :: Int , isFavorite :: Bool , planet :: Planet , moon :: Moon } deriving (Generic, FromForm) nameForm :: View AddContact () nameForm = do form Submit $ do -- 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" -- and a view that displays an input for each field 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)) -- Alternatively, use Higher Kinded Types, and Hyperbole can guarantee the field names are the same -- -- ContactForm' Identity is exactly the same as ContactForm: -- ContactForm' { name :: Text, age :: Int } -- -- ContactForm' FieldName: -- ContactForm' { name :: FieldName Text, age :: FieldName Int } -- -- ContactForm' Maybe: -- ContactForm' { name :: Maybe Text, age :: Maybe Int } -- -- You still have to remember to include all the fields somewhere in the form data ContactForm' f = ContactForm' { name :: Field f Text , age :: Field f Int , isFavorite :: Field f Bool , planet :: Field f Planet , moon :: Field f Moon } deriving (Generic, FromFormF, GenFields FieldName) nameForm' :: View AddContact () nameForm' = do let f = fieldNames @ContactForm' form Submit $ do field f.name $ do label $ do text "Contact Name" input Username @ placeholder "contact name" formView' :: View AddContact () formView' = do -- generate a ContactForm' FieldName let f = fieldNames @ContactForm' form Submit ~ gap 15 . pad 10 $ do el ~ Style.h1 $ "Add Contact" -- f.name :: FieldName Text -- f.name = FieldName "name" field f.name $ do label $ do text "Contact Name" input Username @ placeholder "contact name" ~ Style.input -- f.age :: FieldName Int -- f.age = FieldName "age" field f.age $ do label $ do text "Age" input Number @ placeholder "age" . value "0" ~ Style.input field f.isFavorite $ do label $ do row ~ gap 10 $ do checkbox False ~ width 32 text "Favorite?" col ~ gap 5 $ do el $ text "Planet" field f.planet $ do radioGroup Earth $ do radioOption Mercury radioOption Venus radioOption Earth radioOption Mars field f.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 radioOption val = label ~ flexRow . gap 10 $ do radio val ~ width 32 text (pack (show val)) contactView :: ContactForm -> View AddContact () contactView u = do el ~ bold . Style.success $ "Accepted Signup" row ~ gap 5 $ do el "Username:" el $ text u.name row ~ gap 5 $ do el "Age:" el $ text $ pack (show u.age) row ~ gap 5 $ do el "Favorite:" el $ text $ pack (show u.isFavorite) row ~ gap 5 $ do el "Planet:" el $ text $ pack (show u.planet) row ~ gap 5 $ do el "Moon:" el $ text $ pack (show u.moon) ================================================ FILE: demo/Example/FormValidation.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.FormValidation where import Data.Text (Text, pack) import Data.Text qualified as T import App.Docs import Example.Style qualified as Style import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole source :: ModuleSource source = $(moduleSource) data Signup = Signup deriving (Generic, ViewId) instance HyperView Signup es where data Action Signup = Submit deriving (Generic, ViewAction) update Submit = do uf <- formData @(UserForm Identity) let vals = validateForm uf if anyInvalid vals then pure $ formView vals else pure $ userView uf -- Form Fields newtype User = User {username :: Text} deriving newtype (FromParam) 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) anyInvalid :: UserForm Validated -> Bool anyInvalid u = or [isInvalid u.user, isInvalid u.age, isInvalid u.pass1, isInvalid u.pass2] 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" validateUser :: User -> Validated User validateUser (User u) = mconcat [ validate (T.elem ' ' u) "Username must not contain spaces" , validate (T.length u < 4) "Username must be at least 4 chars" , if u == "admin" || u == "guest" then Invalid "Username is already in use" else Valid ] validatePass :: Text -> Text -> Validated Text validatePass p1 p2 = mconcat [ validate (p1 /= p2) "Passwords did not match" , validate (T.length p1 < 8) "Password must be at least 8 chars" ] formView :: UserForm Validated -> View Signup () formView val = do let f = fieldNames @UserForm form Submit ~ gap 15 . pad 10 $ do el ~ Style.h1 $ "Sign Up" field f.user ~ valStyle val.user $ do label $ do text "Username" input Username @ placeholder "username" ~ Style.input case val.user of Invalid t -> el (text t) Valid -> el "Username is available" _ -> none field f.age ~ valStyle val.age $ do label $ do text "Age" input Number @ placeholder "age" ~ Style.input el $ invalidText val.age field f.pass1 ~ valStyle val.pass1 $ do label $ do text "Password" input NewPassword @ placeholder "password" ~ Style.input el $ invalidText val.pass1 field f.pass2 $ do label $ do text "Repeat Password" input NewPassword @ placeholder "repeat password" ~ Style.input submit "Submit" ~ btn where valStyle (Invalid _) = Style.invalid valStyle Valid = Style.success valStyle _ = id userView :: UserForm Identity -> View Signup () userView u = do el ~ bold . Style.success $ "Accepted Signup" row ~ gap 5 $ do el "Username:" el $ text u.user.username row ~ gap 5 $ do el "Age:" el $ text $ pack (show u.age) row ~ gap 5 $ do el "Password:" el $ text u.pass1 ================================================ FILE: demo/Example/Interactivity/Events.hs ================================================ module Example.Interactivity.Events where import Data.Text (Text, pack) import Example.Colors import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole hiding (button, input) -- Try Events -------------------------------------- data TryEvents = TryEvents deriving (Generic, ViewId) instance HyperView TryEvents es where data Action TryEvents = SetMessage Text deriving (Generic, ViewAction) update (SetMessage t) = do pure $ viewEvents t viewEvents :: Text -> View TryEvents () viewEvents t = do el ~ bold $ text t input @ onInput SetMessage 250 ~ border 1 . pad 5 $ none button @ onDblClick (SetMessage "") ~ btn $ "Double Click to Clear" where input = tag "input" button = tag "button" -- Boxes ----------------------------------- data Boxes = Boxes deriving (Generic, ViewId) instance HyperView Boxes es where data Action Boxes = SelectBox Int | ClearBox deriving (Generic, ViewAction) -- favor the last action that happens type Concurrency Boxes = Replace update (SelectBox n) = do pure $ viewBoxes (Just n) update ClearBox = do pure $ viewBoxes Nothing viewBoxes :: Maybe Int -> View Boxes () viewBoxes mn = do boxes mn $ \n -> do el ~ box @ onMouseEnter (SelectBox n) . onMouseLeave ClearBox $ text $ pack $ show n boxes :: Maybe Int -> (Int -> View c ()) -> View c () boxes mn boxView = do let ns = [0 .. 50] :: [Int] el ~ grid . gap 10 . pad 10 $ do col ~ double . border 2 . bold . fontSize 48 $ do space el ~ textAlign AlignCenter $ text $ pack $ maybe "" show mn space mapM_ boxView ns box :: (Styleable h) => CSS h -> CSS h box = border 1 . pad 10 . pointer . hover (bg PrimaryLight) . textAlign AlignCenter grid :: (Styleable h) => CSS h -> CSS h grid = utility "grid" [ "display" :. "grid" , "grid-template-columns" :. "repeat(auto-fit, minmax(50px, 1fr))" ] double :: (Styleable h) => CSS h -> CSS h double = utility "double" [ "grid-column" :. "1 / span 2" , "grid-row" :. "1 / span 2" ] ================================================ FILE: demo/Example/Interactivity/Inputs.hs ================================================ module Example.Interactivity.Inputs where import Data.Text (pack) import Web.Atomic.CSS import Web.Hyperbole hiding (button, input) data Dropper = Dropper deriving (Generic, ViewId) data Planet = Mercury | Venus | Earth | Mars deriving (Generic, FromParam, ToParam, Eq, Show, Enum, Bounded) instance HyperView Dropper es where data Action Dropper = Select (Maybe Planet) deriving (Generic, ViewAction) update (Select mp) = do pure $ selectPlanet mp selectPlanet :: Maybe Planet -> View Dropper () selectPlanet mp = do dropdown Select mp ~ border 1 . pad 10 $ do option Nothing "Choose a Planet" option (Just Mercury) "Mercury" option (Just Venus) "Venus" option (Just Earth) "Earth" option (Just Mars) "Mars" case mp of Nothing -> none Just p -> el $ text $ "You chose: " <> pack (show p) ================================================ FILE: demo/Example/Javascript.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.Javascript where import Data.Text (Text, pack) import App.Docs import Example.Interactivity.Events (box, boxes) import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[JBoxes, Message] page = do pure $ do script "custom.js" hyper JBoxes $ viewJBoxes Nothing hyper Message viewMessage data JBoxes = JBoxes deriving (Generic, ViewId) instance HyperView JBoxes es where data Action JBoxes = Selected Int | Clear deriving (Generic, ViewAction) type Concurrency JBoxes = Replace update (Selected n) = do pure $ viewJBoxes (Just n) update Clear = do pure $ viewJBoxes Nothing viewJBoxes :: Maybe Int -> View JBoxes () viewJBoxes mn = do boxes mn $ \n -> do el ~ box . cls "box" $ text $ pack $ show n data Message = Message deriving (Generic, ViewId) 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" viewMessage :: View Message () viewMessage = do button AlertMe ~ btn $ "Alert Me" source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Push.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Push where import App.Docs import Control.Monad (forM_) import Effectful import Example.Colors import Example.Effects.Debug import Example.Style.Cyber (btn) import Example.View.Inputs (progressBar) import Web.Atomic.CSS import Web.Hyperbole data Tasks = Tasks deriving (Generic, ViewId) instance (Debug :> es) => HyperView Tasks es where data Action Tasks = RunLongTask | Interrupt deriving (Generic, ViewAction) type Concurrency Tasks = Replace update RunLongTask = do forM_ [1 :: Float .. 100] $ \n -> do pushUpdate $ taskView (n / 100) delay 50 pure $ taskView 1 update Interrupt = do pure $ col ~ gap 10 $ do el "Interrupted!" taskView 0 taskView :: Float -> View Tasks () taskView pct = col ~ gap 10 $ do taskBar if isRunning then button Interrupt ~ btn $ "Interrupt" else button RunLongTask ~ btn . whenLoading disabled $ "Run Task" where taskBar | pct == 0 = el ~ bg Light . pad 5 $ "Task" | pct >= 1 = row ~ bg Success . color White . pad 5 $ el $ text "Complete" | otherwise = progressBar pct "Task" isRunning = pct > 0 && pct < 1 source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Requests.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.Requests where import Data.String.Conversions (cs) import Data.Text (Text) import App.Docs import Example.Colors import Example.Style.Cyber as Cyber (btn, btn') import Web.Atomic.CSS import Web.Hyperbole hiding (Response) import Web.Hyperbole.Data.URI -- REQUEst ------------------------------------------------- data CheckRequest = CheckRequest deriving (Generic, ViewId) instance HyperView CheckRequest es where data Action CheckRequest = Refresh deriving (Generic, ViewAction) update Refresh = do r <- request pure $ viewRequest r viewRequest :: Request -> View CheckRequest () viewRequest r = do col ~ gap 10 $ do el $ do text "Host: " text $ cs $ show r.host el $ do text "Path: " text $ cs $ show r.path el $ do text "Query: " text $ cs $ show r.query el $ do text "Cookies: " text $ cs $ show r.cookies -- CLIENT ------------------------------------------------- data Message = Message { message :: Text } deriving (Generic, ToQuery) data ControlClient = ControlClient deriving (Generic, ViewId) instance HyperView ControlClient es where type Require ControlClient = '[CheckRequest] data Action ControlClient = SetQuery | ClearQuery deriving (Generic, ViewAction) update SetQuery = do setQuery $ Message "hello" trigger CheckRequest Refresh pure $ do el "Updated Query String" viewClient update ClearQuery = do clearQuery trigger CheckRequest Refresh pure viewClient viewClient :: View ControlClient () viewClient = do button SetQuery ~ btn $ "Set Query from another HyperView" button ClearQuery ~ btn $ "Clear Query" -- RESPONSE ------------------------------------------------- data ControlResponse = ControlResponse deriving (Generic, ViewId) instance HyperView ControlResponse es where data Action ControlResponse = RedirectAsAction | SetPageTitle | RespondNotFound | -- \| RespondEarlyView RespondWithError deriving (Generic, ViewAction) update RedirectAsAction = do redirect $ pathUri "/hello/redirected" update SetPageTitle = do pageTitle "Hello World!" pure $ col ~ gap 10 $ do el ~ bold $ "Set page title!" responseView update RespondNotFound = do _ <- notFound pure "This will not be rendered" -- update RespondEarlyView = do -- _ <- respondView ControlResponse "Responded early!" -- pure "This will not be rendered" update RespondWithError = do _ <- respondError "Some custom error" pure "This will not be rendered" responseView :: View ControlResponse () responseView = do row ~ gap 10 . flexWrap Wrap $ do button RedirectAsAction ~ btn $ "Redirect Me" button SetPageTitle ~ btn $ "Set Page Title" button RespondNotFound ~ btn' Danger $ "Respond Not Found" button RespondWithError ~ btn' Danger $ "Respond Error" source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/Scrollbars.hs ================================================ module Example.Scrollbars where import Control.Monad (forM_) import Data.String.Conversions (cs) import Data.Text (Text) import Effectful import Example.Colors import Example.Style.Cyber (btn, btnLight) import Web.Atomic.CSS import Web.Hyperbole test :: IO () test = do putStrLn "Starting..." run 3000 $ do liveApp quickStartDocument (runPage page) page' :: (Hyperbole :> es) => Page es '[Long] page' = do pure $ do style "body { height: 100vh; overflow: hidden; } " hyper Long (longView Nothing) ~ height (Pct 1) data Long = Long deriving (Generic, ViewId) instance HyperView Long es where data Action Long = Select Text deriving (Generic, ViewAction) update (Select t) = do pure $ longView (Just t) longView :: Maybe Text -> View Long () longView sel = do row ~ height (Pct 1) $ do col ~ gap 10 . pad 10 . bg cyan . width 200 . height (Pct 1) . overflow Auto $ do forM_ [0 .. 100 :: Int] $ \n -> do let val = cs $ "Item " <> show n button (Select val) ~ btnLight . slide val $ text val col ~ gap 10 . pad 20 . border 3 . grow $ do el ~ bold $ "SELECTED" case sel of Nothing -> "_" Just t -> el $ text t where slide v = if Just v == sel then color White . bold . btn else btnLight data Test = Test deriving (Generic, ViewId) instance HyperView Test es where data Action Test = Noop deriving (Generic, ViewAction) update Noop = do pure none page :: Page es '[Test] page = pure $ do el ~ vh100 . overflow Hidden $ do col ~ height (Pct 1) . pad 25 . gap 30 $ do hyper Test ~ height (Pct 1) $ do col ~ overflow Scroll . height 300 . width 300 . border 1 $ do forM_ [0 .. 100 :: Int] $ \_ -> do el "HELLO" where vh100 = utility "vh100" ["height" :. "100vh"] ================================================ FILE: demo/Example/Simple.hs ================================================ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Example.Simple where import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole main :: IO () main = do run 3000 $ do liveApp quickStartDocument (runPage page) page :: (Hyperbole :> es) => Page es '[Message] page = do pure $ do hyper Message1 $ messageView "Hello" hyper Message2 $ messageView "World!" 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 messageView :: Text -> View Message () messageView msg = do button (Louder msg) ~ border 1 $ text msg ================================================ FILE: demo/Example/State/Effects.hs ================================================ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.State.Effects where import App.Docs import Data.Text (pack) import Effectful import Effectful.Concurrent.STM import Effectful.Reader.Dynamic import Example.Style.Cyber as Cyber (btn, dataFeature) import Web.Atomic.CSS import Web.Hyperbole as Hyperbole import Web.Hyperbole.Data.Encoded page :: (Hyperbole :> es, Concurrent :> es, Reader (TVar Int) :> es) => Page es '[Counter] page = do n <- getCount pure $ do hyper Counter (viewCount n) data Counter = Counter deriving (Generic) instance ViewId Counter where -- to avoid conflicts with other "Counter" ViewIds on example pages toViewId _ = Encoded "counter-effects" [] parseViewId (Encoded "counter-effects" _) = pure Counter parseViewId _ = Left "expected constructor name" instance (Reader (TVar Int) :> es, Concurrent :> es) => HyperView Counter es where data Action Counter = Increment | Decrement deriving (Generic, ViewAction) update Increment = do n <- modifyCount (+ 1) pure $ viewCount n update Decrement = do n <- modifyCount (subtract 1) pure $ viewCount n viewCount :: Int -> View Counter () viewCount n = row $ do col ~ gap 10 $ do el ~ dataFeature $ text $ pack $ show n row ~ gap 10 $ do button Decrement "Decrement" ~ btn button Increment "Increment" ~ btn modifyCount :: (Concurrent :> es, Reader (TVar Int) :> es) => (Int -> Int) -> Eff es Int modifyCount f = do var <- ask atomically $ do modifyTVar var f readTVar var getCount :: (Concurrent :> es, Reader (TVar Int) :> es) => Eff es Int getCount = readTVarIO =<< ask initCounter :: (Concurrent :> es) => Eff es (TVar Int) initCounter = newTVarIO 0 app :: TVar Int -> Application app var = do liveApp quickStartDocument (runReader var . runConcurrent $ runPage page) source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/State/Query.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} module Example.State.Query where import Data.Text (Text) import Effectful import Example.Colors import Example.Style qualified as Style import Example.Style.Cyber (btn', btnLight) import Web.Atomic.CSS import Web.Hyperbole data Preferences = Preferences { message :: Text , color :: AppColor } deriving (Generic, Show, ToQuery, FromQuery) instance Default Preferences where def = Preferences mempty def page :: (Hyperbole :> es) => Page es '[QueryPrefs] page = do prefs <- query @Preferences pure $ do hyper QueryPrefs $ viewPreferences prefs data QueryPrefs = QueryPrefs deriving (Generic, ViewId) instance HyperView QueryPrefs es where data Action QueryPrefs = SaveColor AppColor | SaveMessage Text | Clear deriving (Generic, ViewAction) update (SaveColor clr) = do prefs <- saveColor clr pure $ viewPreferences prefs update (SaveMessage msg) = do prefs <- modifyQuery $ \p -> p{message = msg} pure $ viewPreferences prefs update Clear = do setQuery @Preferences def pure $ viewPreferences def saveColor :: (Hyperbole :> es) => AppColor -> Eff es Preferences saveColor clr = modifyQuery $ \p -> p{color = clr} viewPreferences :: Preferences -> View QueryPrefs () viewPreferences prefs = do col ~ gap 20 $ do viewColorPicker prefs.color viewMessage prefs.message button Clear ~ Style.btnLight $ "Clear" viewColorPicker :: AppColor -> View QueryPrefs () viewColorPicker clr = do col ~ gap 10 . pad 20 . bg clr . border 1 $ do el ~ fontSize 18 . bold $ "Query Background" row ~ gap 10 $ do button (SaveColor Success) ~ (btn' Success . brd) $ "Successs" button (SaveColor Warning) ~ (btn' Warning . brd) $ "Warning" button (SaveColor Danger) ~ (btn' Danger . brd) $ "Danger" where brd = border $ TRBL 1 0 0 1 viewMessage :: Text -> View QueryPrefs () viewMessage msg = do col ~ gap 10 . pad 20 . border 1 $ do el ~ fontSize 18 . bold $ "Query Message" el $ text msg row ~ gap 10 $ do button (SaveMessage "Hello") ~ btnLight $ "Msg: Hello" button (SaveMessage "Goodbye") ~ btnLight $ "Msg: Goodbye" ================================================ FILE: demo/Example/State/Sessions.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.State.Sessions where import App.Docs import App.Route as Route import Data.Text (Text) import Effectful import Example.Colors import Example.Style qualified as Style import Example.Style.Cyber (btn', btnLight) import Example.View.Layout (layout) import Web.Atomic.CSS import Web.Hyperbole data Preferences = Preferences { message :: Text , color :: AppColor } deriving (Generic, Show, ToEncoded, FromEncoded, Session) instance Default Preferences where def = Preferences "_" White page :: (Hyperbole :> es) => Page es '[Contents] page = do prefs <- session @Preferences pure $ layout State $ do example $(moduleSource) $ do el "We can also persist state in a browser cookie. This is most useful for user-specific preferences and state that should last until they clear their browser cookies" col ~ embed $ hyper Contents $ viewContent prefs data Contents = Contents deriving (Generic, ViewId) instance HyperView Contents es where data Action Contents = SaveColor AppColor | SaveMessage Text | ClearSession deriving (Generic, ViewAction) update (SaveColor clr) = do prefs <- modifySession $ \p -> p{color = clr} pure $ viewContent prefs update (SaveMessage msg) = do prefs <- modifySession $ \p -> p{message = msg} pure $ viewContent prefs update ClearSession = do deleteSession @Preferences pure $ viewContent def viewContent :: Preferences -> View Contents () viewContent prefs = do col ~ gap 20 $ do viewColorPicker prefs.color viewMessage prefs.message button ClearSession ~ Style.btnLight $ "Clear" viewColorPicker :: AppColor -> View Contents () viewColorPicker clr = do col ~ gap 10 . pad 20 . bg clr . border 1 $ do el ~ fontSize 18 . bold $ "Session Background" row ~ gap 10 $ do button (SaveColor Success) ~ (btn' Success . brd) $ "Successs" button (SaveColor Warning) ~ (btn' Warning . brd) $ "Warning" button (SaveColor Danger) ~ (btn' Danger . brd) $ "Danger" where brd = border $ TRBL 1 0 0 1 viewMessage :: Text -> View Contents () viewMessage msg = do col ~ gap 10 . pad 20 . border 1 $ do el ~ fontSize 18 . bold $ "Session Message" el $ text msg row ~ gap 10 $ do button (SaveMessage "Hello") ~ btnLight $ "Msg: Hello" button (SaveMessage "Goodbye") ~ btnLight $ "Msg: Goodbye" ================================================ FILE: demo/Example/State/Stateless.hs ================================================ module Example.State.Stateless where import Example.Style.Cyber (btn) import Web.Atomic.CSS import Web.Hyperbole data Swapper = Swapper deriving (Generic, ViewId) instance HyperView Swapper es where data Action Swapper = Hello | Goodbye deriving (Generic, ViewAction) update Hello = pure "Hello" update Goodbye = pure "Goodbye" viewSwap :: View Swapper () viewSwap = do button Hello ~ btn $ "Hello" button Goodbye ~ btn $ "Goodbye" page :: (Hyperbole :> es) => Page es '[Swapper] page = do pure $ do hyper Swapper $ do button Hello "Hello" button Goodbye "Goodbye" ================================================ FILE: demo/Example/State/ViewState.hs ================================================ module Example.State.ViewState where import Data.Text (pack) import Example.Style.Cyber (btn, dataFeature) import Web.Atomic.CSS import Web.Hyperbole import Web.Hyperbole.HyperView page :: (Hyperbole :> es) => Page es '[Counter] page = do pure $ do hyperState CounterState 1 viewCount data Counter = CounterState deriving (Generic) instance ViewId Counter where type ViewState Counter = Int instance HyperView Counter es where data Action Counter = Increment | Decrement deriving (Generic, ViewAction) update Increment = do modify @Int (+ 1) pure viewCount update Decrement = do modify @Int (subtract 1) pure viewCount viewCount :: View Counter () viewCount = row $ do n <- viewState col ~ gap 10 $ do el ~ dataFeature $ text $ pack $ show n row ~ gap 10 $ do button Decrement "Decrement" ~ btn button Increment "Increment" ~ btn ================================================ FILE: demo/Example/Style/Cyber.hs ================================================ module Example.Style.Cyber where import Data.Text (Text, pack) import Example.Colors import Web.Atomic.CSS import Web.Atomic.Types (style, (-.)) import Web.Hyperbole hiding (style) import Web.Hyperbole.Types.Response clip :: (Styleable h) => PxRem -> CSS h -> CSS h clip size = utility ("clip-br" -. size) ["clip-path" :. ("polygon(0 0, 100% 0, 100% calc(100% - " <> style size <> "), calc(100% - " <> style size <> ") 100%, 0 100%);")] textShadow :: (Styleable h) => CSS h -> CSS h textShadow = utility "text-shadow" ["text-shadow" :. "0 0 4px #0ff, 0 0 8px #0ff"] dataFeature :: (Styleable h) => CSS h -> CSS h dataFeature = bold . fontSize 48 . border 1 . pad (XY 20 0) . font . textAlign AlignCenter btn :: (Styleable h) => CSS h -> CSS h btn = btn' Primary btn' :: (Styleable h) => AppColor -> CSS h -> CSS h btn' clr = bgAnimated . bgGradient clr . hover bgzero . font . color (contrastColor clr) . pad 10 . clip 10 . shadow () btnLight :: (Styleable h) => CSS h -> CSS h btnLight = base . border 2 . borderColor Secondary . font . color Secondary . hover (borderColor SecondaryLight . color SecondaryLight) where base = pad (XY 15 8) bgAnimated :: (Styleable h) => CSS h -> CSS h bgAnimated = utility "bg-anim" [ "background-size" :. "200% 100%" , "background-position" :. "100% 0" , "transition" :. "background-position 0.1s linear" ] bgzero :: (Styleable h) => CSS h -> CSS h bgzero = utility "bg0" ["background-position" :. "0 0"] bgGradient :: (Styleable h) => AppColor -> CSS h -> CSS h bgGradient clr = utility ("bg-grad" -. pack (show clr)) ["background-image" :. ("linear-gradient(90deg, " <> style (colorValue (hoverColor clr)) <> " 0 50%, " <> style (colorValue clr) <> " 50% 100%)")] font :: (Styleable h) => CSS h -> CSS h font = utility "share-tech" ["font-family" :. "'Share Tech Mono'"] cyberError :: View () () -> Body cyberError inner = renderBody $ el ~ wipeIn . border (T 4) . borderColor lightRed $ do el ~ bg midRed . clip 10 . pad 10 . color White $ inner where -- requires @keyframes wipeIn wipeIn :: (Styleable h) => CSS h -> CSS h wipeIn = utility "wipe-in" ["animation" :. "wipeIn 0.5s steps(20, end) forwards"] glitch :: Text -> View c () glitch msg = el ~ cls "glitch" @ att "data-text" msg $ text msg highlight :: (Styleable h) => CSS h -> CSS h highlight = pad 15 . gap 10 . bg White . flexCol . clip 10 . font embed :: (Styleable h) => CSS h -> CSS h embed = border (TL 0 8) . borderColor (light PrimaryLight) . highlight quote :: (Styleable h) => CSS h -> CSS h quote = highlight . italic . textAlign AlignRight ================================================ FILE: demo/Example/Style.hs ================================================ module Example.Style where import Example.Colors import Web.Atomic.CSS -- btn :: (Styleable h) => CSS h -> CSS h -- btn = btn' Primary -- -- btn' :: (Styleable h) => AppColor -> CSS h -> CSS h -- btn' clr = -- bg clr -- . hover (bg (hovClr clr)) -- . color (txtClr clr) -- . pad 10 -- . shadow () -- . rounded 3 -- where -- hovClr Primary = PrimaryLight -- hovClr c = c -- txtClr _ = White btnLight :: (Styleable h) => CSS h -> CSS h btnLight = base . border 2 . borderColor Secondary . color Secondary . hover (borderColor SecondaryLight . color SecondaryLight) where base = pad (XY 15 8) h1 :: (Styleable h) => CSS h -> CSS h h1 = bold . fontSize 32 invalid :: (Styleable h) => CSS h -> CSS h invalid = color Danger success :: (Styleable h) => CSS h -> CSS h success = color Success link :: (Styleable h) => CSS h -> CSS h link = color Primary . underline input :: (Styleable h) => CSS h -> CSS h input = border 1 . pad 8 strikethrough :: (Styleable h) => CSS h -> CSS h strikethrough = utility "strike" ["text-decoration" :. "line-through"] uppercase :: (Styleable h) => CSS h -> CSS h uppercase = utility "upper" ["text-transform" :. "uppercase"] ================================================ FILE: demo/Example/Tags.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.Tags where import App.Docs import App.Route qualified as Route import Data.Text (Text) import Example.Style.Cyber (btn) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole page :: (Hyperbole :> es) => Page es '[Tags] page = do pure $ layout (Route.Examples Route.Tags) $ do example $(moduleSource) $ do hyper Tags $ tagsView [] newtype Tag = Tag Text deriving newtype (ToParam, FromParam, Eq) data TagForm = TagForm { tag :: Text } deriving (Generic, FromForm) data Tags = Tags deriving (Generic, ViewId) instance HyperView Tags es where data Action Tags = SubmitTag [Tag] | RemoveTag [Tag] Tag deriving (Generic, ViewAction) update (SubmitTag ts) = do TagForm t <- formData pure $ tagsView (Tag t : ts) update (RemoveTag ts t) = do pure $ tagsView $ filter (/= t) ts tagsView :: [Tag] -> View Tags () tagsView ts = do row ~ gap 5 $ do mapM_ (tagView ts) ts form (SubmitTag ts) ~ gap 10 . pad 10 . flexRow $ do field "tag" ~ grow $ do label $ do input TextInput @ placeholder "New Tag" ~ border 1 . pad 10 @ value "" submit "+ Add" ~ btn tagView :: [Tag] -> Tag -> View Tags () tagView ts (Tag t) = do row ~ border 1 . pad 5 . gap 5 $ do button (RemoveTag ts (Tag t)) ~ pad 2 . btn $ "X" text t ================================================ FILE: demo/Example/Test.hs ================================================ module Example.Test where import Control.Monad (forM_) import Data.String.Conversions (cs) import Data.Text (Text) import Effectful import Example.Colors import Example.Style.Cyber (btn, btnLight) import Web.Atomic.CSS import Web.Hyperbole test :: IO () test = do putStrLn "Starting..." run 3000 $ do liveApp quickStartDocument (runPage page) -- TEST: add a test for Page+trigger page :: (Hyperbole :> es, IOE :> es) => Page es '[Long] page = do pure $ do style "body { height: 100vh; overflow: hidden; } " hyper Long (longView Nothing) ~ height (Pct 1) data Long = Long deriving (Generic, ViewId) instance HyperView Long es where data Action Long = Select Text deriving (Generic, ViewAction) update (Select t) = do pure $ longView (Just t) longView :: Maybe Text -> View Long () longView sel = do row ~ height (Pct 1) $ do col ~ gap 10 . pad 10 . bg cyan . width 200 . height (Pct 1) . overflow Auto $ do forM_ [0 .. 100 :: Int] $ \n -> do let val = cs $ "Item " <> show n button (Select val) ~ btnLight . slide val $ text val col ~ gap 10 . pad 20 . border 3 . grow $ do el ~ bold $ "SELECTED" case sel of Nothing -> "_" Just t -> el $ text t where slide v = if Just v == sel then color White . bold . btn else btnLight ================================================ FILE: demo/Example/Todos/Todo.hs ================================================ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Example.Todos.Todo where import App.Docs import App.Route qualified as Route import Control.Monad (forM_) import Data.Text (Text, pack) import Effectful import Example.Colors import Example.Effects.Todos (FilterTodo (..), Todo (..), TodoId, Todos, runTodosSession) import Example.Effects.Todos qualified as Todos import Example.Style qualified as Style import Example.View.Icon qualified as Icon import Example.View.Inputs (toggleCheckbox) import Example.View.Layout import Web.Atomic.CSS import Web.Hyperbole as Hyperbole page :: (Todos :> es) => Page es '[AllTodos, TodoView] page = do todos <- Todos.loadAll pure $ layout (Route.Examples Route.Todos) $ do section' "Todos" $ do example $(moduleSource) $ do hyper AllTodos $ todosView FilterAll todos -- Keep this, it's used for documentation (+ usable via the REPL, see main below) simplePage :: (Todos :> es) => Page es '[AllTodos, TodoView] simplePage = do todos <- Todos.loadAll pure $ do hyper AllTodos $ todosView FilterAll todos --- AllTodos ---------------------------------------------------------------------------- data AllTodos = AllTodos deriving (Generic, ViewId) instance (Todos :> es) => HyperView AllTodos es where type Require AllTodos = '[TodoView] data Action AllTodos = ClearCompleted | Filter FilterTodo | SubmitTodo | ToggleAll FilterTodo | SetCompleted FilterTodo Todo Bool | Destroy FilterTodo Todo deriving (Generic, ViewAction) update action = do case action of ClearCompleted -> do todosView FilterAll <$> Todos.clearCompleted SubmitTodo -> do TodoForm task <- formData @(TodoForm Identity) _ <- Todos.create task ts <- Todos.loadAll pure $ todosView FilterAll ts Filter filt -> do todos <- Todos.filteredTodos filt pure $ todosView filt todos ToggleAll filt -> do todos <- Todos.filteredTodos filt >>= Todos.toggleAll pure $ todosView filt todos SetCompleted filt todo completed -> do _ <- Todos.setCompleted completed todo todos <- Todos.filteredTodos filt pure $ todosView filt todos Destroy filt todo -> do Todos.clear todo todos <- Todos.filteredTodos filt pure $ todosView filt todos todosView :: FilterTodo -> [Todo] -> View AllTodos () todosView filt todos = do todoForm filt col $ do forM_ todos $ \todo -> do hyper (TodoView todo.id) $ todoView filt todo statusBar filt todos statusBar :: FilterTodo -> [Todo] -> View AllTodos () statusBar filt todos = do row ~ pad 10 . color SecondaryLight $ do let numLeft = length $ filter (\t -> not t.completed) todos el $ text $ mconcat [ pack $ show numLeft , " " , pluralize numLeft "item" "items" , " " , "left!" ] space row ~ gap 10 $ do filterButton FilterAll "All" filterButton Active "Active" filterButton Completed "Completed" space button ClearCompleted ~ hover (color Primary) $ "Clear completed" where filterButton f = button (Filter f) ~ selectedFilter f . pad (XY 4 0) . rounded 2 selectedFilter f = if f == filt then border 1 else id -- TodoForm ---------------------------------------------------------------------------- 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 "" --- TodoView ---------------------------------------------------------------------------- data TodoView = TodoView TodoId deriving (Generic, ViewId) instance (Todos :> es) => HyperView TodoView es where type Require TodoView = '[AllTodos] data Action TodoView = Edit FilterTodo Todo | SubmitEdit FilterTodo Todo deriving (Generic, ToJSON, FromJSON, ViewAction) update (Edit filt todo) = do pure $ todoEditView filt todo update (SubmitEdit filt todo) = do TodoForm task <- formData @(TodoForm Identity) t <- Todos.setTask task todo pure $ todoView filt t todoView :: FilterTodo -> Todo -> View TodoView () todoView filt todo = do row ~ border (TRBL 0 0 1 0) . pad 10 . showDestroyOnHover $ do target AllTodos () $ do toggleCheckbox (SetCompleted filt todo) todo.completed el (text todo.task) @ onDblClick (Edit filt todo) ~ completed . pad (XY 18 4) . grow target AllTodos () $ do button (Destroy filt todo) "✕" ~ cls "destroy-btn" . opacity 0 . hover (color Primary) . pad 4 where completed = if todo.completed then Style.strikethrough else id showDestroyOnHover = css "todo-row" ".todo-row:hover > .destroy-btn" (declarations (opacity 100)) todoEditView :: FilterTodo -> Todo -> View TodoView () todoEditView filt todo = do let f = fieldNames @TodoForm row ~ border (TRBL 0 0 1 0) . pad 10 $ do form (SubmitEdit filt todo) ~ pad (TRBL 0 0 0 46) $ do field f.task $ do input TextInput @ value todo.task . autofocus ~ pad 4 pluralize :: Int -> Text -> Text -> Text pluralize n singular plural = if n == 1 then singular else plural {- You may try this in the REPL for simple tests: bash> cabal repl exe:examples lib:hyperbole ghci> Todo.main -} main :: IO () main = do run 3000 $ do liveApp quickStartDocument (runTodosSession $ runPage simplePage) ================================================ FILE: demo/Example/Todos/TodoCSS.hs ================================================ {-# LANGUAGE UndecidableInstances #-} module Example.Todos.TodoCSS (page) where import App.Route hiding (Filter) import Control.Monad (forM_) import Data.Bool (bool) import Data.Text qualified as T import Example.Effects.Todos (FilterTodo (..), Todo, TodoId, Todos) import Example.Effects.Todos qualified as Todos import Example.Todos.Todo (Action (..), AllTodos (..), TodoForm (..), TodoView (..), pluralize) import Web.Hyperbole as Hyperbole {- To make the CSS version work and overcome the default CSS reset, we tweaked the output slightly via a few style tags here and there: only need to add one manual rule to the footer, to override the CSS reset - main title - override its absolute positioning - read-only item: - restore border-bottom (a visual separator) - first footer - add bottom padding - second footer - restore default user-agent p tags margin -} page :: (Todos :> es) => Page es '[CSSTodos, CSSTodo] page = do todos <- Todos.loadAll pure $ do div' $ do -- Alternative stylesheet at: https://todomvc.com/examples/javascript-es6/dist/app.css -- Reference implementation at: https://todomvc.com/examples/javascript-es6/dist/ stylesheet "https://cdn.jsdelivr.net/npm/todomvc-app-css@2.4.3/index.min.css" -- Tweaks required to the stylesheet, mostly to undo the global reset we used for the -- rest of the examples, but also to accomodate a slightly different DOM stylesheet "/todomvc.css" section @ class_ "todoapp" $ do hyper CSSTodos $ todosView FilterAll todos footer @ class_ "info" $ do p "Double-click to edit a todo" p $ do span' "Go back to the " route (Examples OtherExamples) "examples" --- TodosView ---------------------------------------------------------------------------- data CSSTodos = CSSTodos deriving (Generic, ViewId) instance (Todos :> es) => HyperView CSSTodos es where type Require CSSTodos = '[CSSTodo] -- reuse as the actions from the main TodoMVC example. This isn't a good -- example of how to factor well, it's optimized to make the main example -- readable. Focus on the views newtype Action CSSTodos = MkTodosAction (Action AllTodos) deriving newtype (ViewAction) -- Repeated logic from the main Todos example. Do not follow this as an example -- of how to reuse views update (MkTodosAction action) = do case action of ClearCompleted -> do todosView FilterAll <$> Todos.clearCompleted SubmitTodo -> do TodoForm task <- formData @(TodoForm Identity) _ <- Todos.create task todos <- Todos.filteredTodos FilterAll pure $ todosView FilterAll todos Filter filt -> do todos <- Todos.filteredTodos filt pure $ todosView filt todos ToggleAll filt -> do todos <- Todos.filteredTodos filt >>= Todos.toggleAll pure $ todosView filt todos SetCompleted filt todo completed -> do _ <- Todos.setCompleted completed todo todos <- Todos.filteredTodos filt pure $ todosView filt todos Destroy filt todo -> do Todos.clear todo todos <- Todos.filteredTodos filt pure $ todosView filt todos todosView :: FilterTodo -> [Todo] -> View CSSTodos () todosView filt todos = do header @ class_ "header" $ do h1 $ text "todos" todoForm main' @ class_ "main" $ do div' @ class_ "toggle-all-container" $ do input' @ class_ "toggle-all" . att "id" "toggle-all" . att "type" "checkbox" label' @ class_ "toggle-all-label" . att "for" "toggle-all" . onClick (MkTodosAction $ ToggleAll filt) $ text "Mark all as complete" ul' @ class_ "todo-list" $ do forM_ todos $ \todo -> do hyper (CSSTodo todo.id) $ todoView filt todo statusBar filt todos todoForm :: View CSSTodos () todoForm = do let f :: TodoForm FieldName = fieldNames form (MkTodosAction SubmitTodo) $ do field f.task $ do input TextInput -- we use a custom input field, because the Hyperbole one overrides autocomplete @ class_ "new-todo" {- -- . autofocus FIXME: turning off autofocus, that "steals" the focus on item click. FIXME: to solve this, we could either store the "initially focused" state and track that boolean, or use buttons FIXME: but since this example is meant to match as close as possible to the original CSS version FIXME: and not diverge too much from the other todo example, I'm leaving as-is. -} . placeholder "What needs to be done?" statusBar :: FilterTodo -> [Todo] -> View CSSTodos () statusBar filt todos = do footer @ class_ "footer" $ do let numLeft = length $ filter (\t -> not t.completed) todos span' @ class_ "todo-count" $ do text $ mconcat [ T.pack $ show numLeft , " " , pluralize numLeft "item" "items" , " " , "left!" ] space ul' @ class_ "filters" $ do filterLi FilterAll "All" filterLi Active "Active" filterLi Completed "Completed" space button (MkTodosAction ClearCompleted) @ class_ "clear-completed" $ "Clear completed" where filterLi f str = li' @ class_ "filter" . selectedFilter f $ do a @ onClick (MkTodosAction $ Filter f) . att "href" "" -- harmless empty href is for the CSS $ text str selectedFilter f = if f == filt then class_ "selected" else id --- TodoView ---------------------------------------------------------------------------- data CSSTodo = CSSTodo TodoId deriving (Generic, ViewId) instance (Todos :> es) => HyperView CSSTodo es where type Require CSSTodo = '[CSSTodos] newtype Action CSSTodo = MkTodoAction (Action TodoView) deriving newtype (ViewAction) update (MkTodoAction action) = case action of Edit filt todo -> do pure $ todoEditView filt todo SubmitEdit filt todo -> do TodoForm task <- formData @(TodoForm Identity) t <- Todos.setTask task todo pure $ todoView filt t todoView :: FilterTodo -> Todo -> View CSSTodo () todoView filt todo = do li' @ bool id (class_ "completed") todo.completed $ do div' @ class_ "view" $ do target CSSTodos () $ do input' @ class_ "toggle" . att "type" "checkbox" . onClick (MkTodosAction $ SetCompleted filt todo $ not todo.completed) . checked todo.completed label' @ class_ "label" . onDblClick (MkTodoAction $ Edit filt todo) $ do text todo.task target CSSTodos () $ do button (MkTodosAction $ Destroy filt todo) @ class_ "destroy" $ "" todoEditView :: FilterTodo -> Todo -> View CSSTodo () todoEditView filt todo = do li' @ class_ "editing" $ do form (MkTodoAction $ SubmitEdit filt todo) $ do field "task" $ do input TextInput @ class_ "edit" . value todo.task . autofocus --- Semantic HTML Helpers ---------------------------------------------------------------------------- -- -- you can use semantic HTML with atomic-css too! But it is required here for the stylesheet to work div' :: View c () -> View c () div' = tag "div" span' :: View c () -> View c () span' = tag "span" section :: View c () -> View c () section = tag "section" header :: View c () -> View c () header = tag "header" main' :: View c () -> View c () main' = tag "main" h1 :: View c () -> View c () h1 = tag "h1" p :: View c () -> View c () p = tag "p" label' :: View c () -> View c () label' = tag "label" input' :: View c () input' = tag "input" none a :: View c () -> View c () a = tag "a" ul' :: View c () -> View c () ul' = tag "ul" li' :: View c () -> View c () li' = tag "li" footer :: View c () -> View c () footer = tag "footer" ================================================ FILE: demo/Example/Trigger.hs ================================================ {-# LANGUAGE TemplateHaskell #-} module Example.Trigger where import Data.Text (Text) import App.Docs import Example.Style.Cyber as Cyber (btn, font) import Web.Atomic.CSS import Web.Hyperbole data Targeted = Targeted deriving (Generic, ViewId) instance HyperView Targeted es where data Action Targeted = SetMessage Text deriving (Generic, ViewAction) update (SetMessage msg) = do pure $ targetedView msg targetedView :: Text -> View Targeted () targetedView msg = do el ~ pad 10 . border 1 . Cyber.font $ do text msg data Controls = Controls deriving (Generic, ViewId) 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 controlView :: View Controls () controlView = do button TriggerMessage ~ btn $ "Trigger Message" targetView :: View Controls () targetView = do target Targeted () $ do button (SetMessage "Targeted!") ~ btn $ "Target SetMessage" source :: ModuleSource source = $(moduleSource) ================================================ FILE: demo/Example/View/Icon.hs ================================================ {-# LANGUAGE QuasiQuotes #-} module Example.View.Icon where import Data.String.Interpolate (i) import Data.Text (Text) import Web.Atomic.CSS import Web.Hyperbole.View hamburger :: View c () hamburger = raw [i| |] xCircle :: View c () xCircle = raw $ do [i| |] checkCircle :: View c () checkCircle = raw $ do [i| |] check :: View c () check = raw $ do [i| |] chevronDown :: View c () chevronDown = raw $ do [i| |] -- Haskell logo -- https://commons.wikimedia.org/wiki/File:Haskell-Logo.svg haskell :: View c () haskell = raw $ do [i| |] -- GitHub logo github :: View c () github = raw $ do [i| |] -- see icons.svg icon :: Text -> View c () icon iconId = tag "svg" ~ icn $ do tag "use" @ att "href" ("/icons.svg#" <> iconId) $ none where icn = utility "icn" [ "width" :. "1.2em" , "height" :. "1.2em" , "display" :. "inline-block" , "fill" :. "none" , "stroke" :. "current-color" , "transform" :. "translateY(0.175em)" ] bookOpen :: View c () bookOpen = icon "book" linkOut :: View c () linkOut = icon "link-out" iconInline :: (Styleable h) => CSS h -> CSS h iconInline = flexRow . gap 2 . utility "items-baseline" ["align-items" :. "baseline"] ================================================ FILE: demo/Example/View/Inputs.hs ================================================ module Example.View.Inputs where import Example.Colors import Web.Atomic.CSS import Web.Hyperbole toggleCheckbox :: (ViewAction (Action id)) => (Bool -> Action id) -> Bool -> View id () toggleCheckbox setChecked isSelected = do tag "input" @ att "type" "checkbox" . onClick (setChecked (not isSelected)) . checked isSelected ~ big $ none where big = width 32 . height 32 progressBar :: Float -> View context () -> View context () progressBar pct contents = do let setWidth = if pct > 0 then width (Pct pct) else id row ~ bg Light $ do row ~ bg PrimaryLight . setWidth . pad 5 $ contents ================================================ FILE: demo/Example/View/Layout.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} module Example.View.Layout where import App.Docs (PageAnchor (..)) import App.Route import Data.String.Conversions (cs) import Data.Version (showVersion) import Example.Colors (AppColor (..)) import Example.Style qualified as Style import Example.Style.Cyber qualified as Cyber import Example.View.Icon as Icon (github, hamburger, haskell) import Example.View.Menu (menu) import Paths_demo (version) import Web.Atomic.CSS import Web.Hyperbole layout :: AppRoute -> View c () -> View c () layout rt = layout' (menu @() rt) layoutSubnav :: forall sections c. (PageAnchor sections) => AppRoute -> View c () -> View c () layoutSubnav rt = layout' (menu @sections rt) layout' :: View c () -> View c () -> View c () layout' chosenMenu contents = el ~ grow $ do navigation chosenMenu ~ position Fixed . zIndex 1 . onDesktop leftMenu . onMobile topMenu col ~ pad (TRBL 25 25 100 25) . gap 30 . onDesktop horizontal . onMobile vertical $ do contents where leftMenu = width menuWidth . left 0 . top 0 . bottom 0 horizontal = margin (L menuWidth) vertical = margin (T menuHeight) topMenu = top 0 . right 0 . left 0 menuWidth = 230 menuHeight = 70 -- Navigation -------------------------------------- navigation :: View c () -> View c () navigation chosenMenu = do nav ~ bg Dark . color White . flexCol . showMenuHover $ do row $ do link hackageUrl "HYPERBOLE" ~ bold . pad 20 . logo . width 220 space menuButton col ~ cls "menu" . onMobile (display None) . Cyber.font . Style.uppercase $ do chosenMenu space row ~ pad (TL 20 10) . gap 10 . utility "items-center" ["align-items" :. "center"] $ do el ~ fontSize 12 $ do text "v" text $ cs $ showVersion version row $ do link hackageUrl (el ~ width 20 . height 20 . flexRow . utility "items-center" ["align-items" :. "center"] $ Icon.haskell) ~ pad 8 . hover (bg DarkHighlight) link githubUrl (el ~ width 20 . height 20 . flexRow . utility "items-center" ["align-items" :. "center"] $ Icon.github) ~ pad 8 . hover (bg DarkHighlight) where hackageUrl = [uri|https://hackage.haskell.org/package/hyperbole|] githubUrl = [uri|https://github.com/seanhess/hyperbole|] menuButton = el ~ onDesktop (display None) . onMobile flexCol $ do el ~ pad 6 $ do el Icon.hamburger ~ color White . width 50 . height 50 showMenuHover = css "show-menu" ".show-menu:hover > .menu" [ "display" :. "flex" ] -- https://www.fontspace.com/super-brigade-font-f96444 logo = utility "logo" [ "background" :. "no-repeat center/90% url(/logo-robot.png)" , "color" :. "transparent" ] onMobile :: (Styleable c) => (CSS c -> CSS c) -> CSS c -> CSS c onMobile = media (MaxWidth 650) onDesktop :: (Styleable c) => (CSS c -> CSS c) -> CSS c -> CSS c onDesktop = media (MinWidth 650) ================================================ FILE: demo/Example/View/Loader.hs ================================================ {-# LANGUAGE QuasiQuotes #-} module Example.View.Loader where import Data.ByteString (ByteString) import Data.String.Interpolate (i) import Web.Atomic.CSS import Web.Hyperbole css :: ByteString css = [i| .loader { width: 24px; aspect-ratio: 1; --c: no-repeat linear-gradient(\#E44072 0 0); background: var(--c) 0% 50%, var(--c) 50% 50%, var(--c) 100% 50%; background-size: 20% 100%; animation: l1 1s infinite linear; } @keyframes l1 { 0% {background-size: 20% 100%,20% 100%,20% 100%} 33% {background-size: 20% 10% ,20% 100%,20% 100%} 50% {background-size: 20% 100%,20% 10% ,20% 100%} 66% {background-size: 20% 100%,20% 100%,20% 10% } 100%{background-size: 20% 100%,20% 100%,20% 100%} } |] loadingBars :: View c () loadingBars = el ~ cls "loader" $ none loading :: View c () loading = do row ~ gap 10 . whenLoading flexRow . display None $ do loadingBars el "Loading..." ================================================ FILE: demo/Example/View/Menu.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} module Example.View.Menu where import App.Docs import App.Route import Control.Monad (when) import Example.Colors (AppColor (..), cyan) import Web.Atomic.CSS import Web.Hyperbole menu :: forall sections c. (PageAnchor sections) => AppRoute -> View c () menu current = do col ~ color White $ do docLink Intro docLink Basics docLink Hyperviews docLink Concurrency docLink ViewFunctions docLink SideEffects docLink State docLink CSS docLink HyperboleEffect docLink Application docLink (Forms FormSimple) docLink Interactivity docLink' isExamples (Examples OtherExamples) where -- case current of -- Examples _ -> -- completeExamples -- (Contacts _) -> -- completeExamples -- _ -> none -- completeExamples = do -- subLink (Examples Tags) -- subLink (Contacts ContactsAll) -- subLink (Examples OAuth2) -- subLink (Examples Todos) -- subLink (Examples TodosCSS) isExamples = case current of Examples _ -> True Data _ -> True Contacts _ -> True _ -> False sub = pad (TRBL 5 10 5 40) . fontSize 14 menuItem :: (Styleable h) => CSS h -> CSS h menuItem = pad (XY 20 10) . hover (bg DarkHighlight) docLink rt = docLink' (rt == current) rt docLink' isSelected rt = do let highlight = if isSelected then bg DarkHighlight . border (L 4) . pad (L 16) . color cyan else id route rt ~ highlight . menuItem $ text $ routeTitle rt when (rt == current) $ do mapM_ anchorLink (subnav @sections) -- subLink rt = do -- let isSelected = rt == current -- let highlight = if isSelected then bg DarkHighlight . color cyan else id -- border (L 4) . pad (L 16) . color cyan else id -- route rt ~ highlight . sub . menuItem $ -- text $ -- routeTitle rt anchorLink :: (PageAnchor a) => a -> View c () anchorLink a = do tag "a" ~ sub . menuItem @ att "href" ("#" <> pageAnchor a) $ do text $ navEntry a ================================================ FILE: demo/Example/View/SortableTable.hs ================================================ module Example.View.SortableTable where import Data.Text (Text) import Example.Colors import Example.Style qualified as Style import Example.View.Icon qualified as Icon import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) dataRow :: (Styleable a) => CSS a -> CSS a dataRow = gap 10 . pad (All $ PxRem dataRowPadding) dataRowPadding :: PxRem dataRowPadding = 5 bord :: (Styleable a) => CSS a -> CSS a bord = border 1 . borderColor Light hd :: View id () -> TableHead id () hd = th ~ pad 4 . bord . bg Light cell :: (Styleable a) => CSS a -> CSS a cell = pad 4 . bord dataTable :: (Styleable a) => CSS a -> CSS a dataTable = css "data-table" ".data-table tr:nth-child(even)" (declarations (bg Light)) sortBtn :: (ViewAction (Action id)) => Text -> Action id -> Bool -> View id () sortBtn lbl click isSelected = do button click ~ Style.link . flexRow . gap 0 $ do el ~ selectedColumn $ text lbl el ~ width 20 $ Icon.chevronDown where selectedColumn = if isSelected then underline else id sortColumn :: (ViewAction (Action id)) => View id () -> (dt -> Text) -> TableColumns id dt () sortColumn header cellText = do tcol (hd header) $ \item -> td ~ cell $ text $ cellText item ================================================ FILE: demo/Main.hs ================================================ module Main where import App main :: IO () main = App.run ================================================ FILE: demo/README.md ================================================ Hyperbole Examples =================== Visit https://docs.hyperbole.live to view these examples with source code ================================================ FILE: demo/demo.cabal ================================================ cabal-version: 2.2 -- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: demo version: 0.6.0 synopsis: Interactive HTML apps using type-safe serverside Haskell description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView category: Web, Network homepage: https://github.com/seanhess/hyperbole bug-reports: https://github.com/seanhess/hyperbole/issues author: Sean Hess maintainer: seanhess@gmail.com license: BSD-3-Clause build-type: Simple source-repository head type: git location: https://github.com/seanhess/hyperbole executable demo main-is: Main.hs other-modules: App App.Cache App.Config App.Docs App.Docs.Markdown App.Docs.Page App.Docs.Snippet App.Page.Application App.Page.Concurrency App.Page.CSS App.Page.Examples App.Page.Forms App.Page.HyperboleEffect App.Page.Hyperviews App.Page.Interactivity App.Page.Intro.Basics App.Page.Intro.Intro App.Page.OAuth2 App.Page.SideEffects App.Page.State App.Page.ViewFunctions App.Route App.Style Example.Chat Example.Colors Example.Concurrency.LazyLoading Example.Concurrency.Overlap Example.Concurrency.Polling Example.Concurrency.Progress Example.Concurrency.Tasks Example.Contact Example.Contacts Example.Counter Example.CSS.External Example.CSS.Loading Example.CSS.Tooltips Example.CSS.Transitions Example.Data.ProgrammingLanguage Example.DataLists.Autocomplete Example.DataLists.DataTable Example.DataLists.Filter Example.DataLists.LoadMore Example.Docs.App Example.Docs.BasicPage Example.Docs.Client Example.Docs.Component Example.Docs.CSS Example.Docs.Encoding Example.Docs.Interactive Example.Docs.MultiPage Example.Docs.MultiView Example.Docs.Nested Example.Docs.Nesting Example.Docs.Page.Messages Example.Docs.Page.Users Example.Docs.Params Example.Docs.QueryMessage Example.Docs.Sessions Example.Docs.SideEffects Example.Docs.State Example.Docs.UniqueViewId Example.Docs.ViewFunctions Example.Document Example.Effects.Debug Example.Effects.Todos Example.Effects.Users Example.Errors Example.FormSimple Example.FormValidation Example.Interactivity.Events Example.Interactivity.Inputs Example.Javascript Example.Push Example.Requests Example.Scrollbars Example.Simple Example.State.Effects Example.State.Query Example.State.Sessions Example.State.Stateless Example.State.ViewState Example.Style Example.Style.Cyber Example.Tags Example.Test Example.Todos.Todo Example.Todos.TodoCSS Example.Trigger Example.View.Icon Example.View.Inputs Example.View.Layout Example.View.Loader Example.View.Menu Example.View.SortableTable Paths_demo autogen-modules: Paths_demo hs-source-dirs: ./ default-extensions: OverloadedStrings OverloadedRecordDot DuplicateRecordFields NoFieldSelectors TypeFamilies DataKinds DerivingStrategies DeriveAnyClass ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , atomic-css , base , bytestring , casing , cmark , containers , cookie , data-default , directory , effectful , file-embed , filepath , foreign-store , http-api-data , http-client , http-client-tls , http-types , hyperbole , network , network-uri , random , safe , string-conversions , string-interpolate , template-haskell , text , time , wai , wai-middleware-static , wai-websockets , warp , websockets default-language: GHC2021 ================================================ FILE: demo/fourmolu.yaml ================================================ # # Number of spaces per indentation step indentation: 2 # # # Max line length for automatic line breaking # column-limit: none # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) function-arrows: leading # # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) # comma-style: leading # Styling of import/export lists (choices: leading, trailing, or diff-friendly) import-export-style: leading # # Whether to full-indent or half-indent 'where' bindings past the preceding body # indent-wheres: false # # # Whether to leave a space before an opening record brace # record-brace-space: false # # Number of spaces between top-level declarations newlines-between-decls: 1 # # # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) # haddock-style: multi-line # # # How to print module docstring # haddock-style-module: null # # Styling of let blocks (choices: auto, inline, newline, or mixed) # let-style: auto # # # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) # in-style: right-align # # # Whether to put parentheses around a single constraint (choices: auto, always, or never) # single-constraint-parens: always # # # Output Unicode syntax (choices: detect, always, or never) # unicode: never # # Give the programmer more choice on where to insert blank lines respectful: true # # Fixity information for operators # fixities: [] # # # Module reexports Fourmolu should know about # reexports: [] ================================================ FILE: demo/hie.yaml ================================================ cradle: cabal: ================================================ FILE: demo/package.yaml ================================================ name: demo version: 0.6.0 synopsis: Interactive HTML apps using type-safe serverside Haskell homepage: https://github.com/seanhess/hyperbole github: seanhess/hyperbole license: BSD-3-Clause author: Sean Hess maintainer: seanhess@gmail.com category: Web, Network description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView language: GHC2021 ghc-options: - -Wall - -fdefer-typed-holes default-extensions: - OverloadedStrings - OverloadedRecordDot - DuplicateRecordFields - NoFieldSelectors - TypeFamilies - DataKinds - DerivingStrategies - DeriveAnyClass dependencies: - base - aeson - bytestring - containers - casing - data-default - effectful - text - time - string-interpolate - file-embed - http-api-data - http-types - random - wai - warp - atomic-css - string-conversions - wai-websockets - network - websockets - cookie - hyperbole - network-uri - http-client - http-client-tls - template-haskell - cmark - directory - filepath executables: demo: main: Main.hs ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N source-dirs: - ./ dependencies: - wai-middleware-static - safe - foreign-store ================================================ FILE: demo/static/custom.js ================================================ console.log("Custom JS!") window.onload = function() { let boxes = Hyperbole.hyperView("JBoxes") console.log("Found HyperView 'Boxes'") boxes.addEventListener("mouseover", function(e) { if (e.target.classList.contains("box")) { let action = Hyperbole.action("Selected", parseInt(e.target.innerHTML)) boxes.runAction(action) } }) boxes.addEventListener("mouseout", function(e) { if (e.target.classList.contains("box")) { boxes.runAction("Clear") } }) listenServerEvents() } 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) }) } ================================================ FILE: demo/static/cyber.css ================================================ @font-face { font-family: 'Share Tech Mono'; src: url('/ShareTechMono-Regular.ttf') format('truetype'); font-weight: normal; font-style: normal; } @keyframes errorFlicker { 0%, 50% { opacity: 0; } 25%, 75%, 100% { opacity: 1; } } @keyframes wipeIn { from { clip-path: inset(0 100% 0 0); } /* fully hidden (100% right cut) */ to { clip-path: inset(0 0 0 0); } /* fully visible */ } .glitch, .live-reload { color: #fff; position: relative; margin: 0 auto; font-family: 'Share Tech Mono'; } /* keyframes expanded from the SCSS @for + random() */ @keyframes noise-anim { 00% { clip: rect(40px, 9999px, 60px, 0); } 05% { clip: rect(76px, 9999px, 10px, 0); } 10% { clip: rect(18px, 9999px, 74px, 0); } 15% { clip: rect(96px, 9999px, 32px, 0); } 20% { clip: rect(90px, 9999px, 8px, 0); } 25% { clip: rect(14px, 9999px, 72px, 0); } 30% { clip: rect(54px, 9999px, 36px, 0); } 35% { clip: rect(48px, 9999px, 92px, 0); } 40% { clip: rect(6px, 9999px, 40px, 0); } 45% { clip: rect(70px, 9999px, 16px, 0); } 50% { clip: rect(22px, 9999px, 84px, 0); } 55% { clip: rect(88px, 9999px, 28px, 0); } 60% { clip: rect(4px, 9999px, 44px, 0); } 65% { clip: rect(12px, 9999px, 98px, 0); } 70% { clip: rect(66px, 9999px, 22px, 0); } 75% { clip: rect(30px, 9999px, 80px, 0); } 80% { clip: rect(28px, 9999px, 58px, 0); } 85% { clip: rect(60px, 9999px, 20px, 0); } 90% { clip: rect(8px, 9999px, 96px, 0); } 95% { clip: rect(34px, 9999px, 12px, 0); } 100% { clip: rect(0px, 9999px, 100px, 0); } } @keyframes noise-anim-2 { 0% { clip: rect(10px, 9999px, 76px, 0); } 5% { clip: rect(72px, 9999px, 40px, 0); } 10% { clip: rect(24px, 9999px, 58px, 0); } 15% { clip: rect(60px, 9999px, 18px, 0); } 20% { clip: rect(36px, 9999px, 96px, 0); } 25% { clip: rect(52px, 9999px, 28px, 0); } 30% { clip: rect(6px, 9999px, 60px, 0); } 35% { clip: rect(80px, 9999px, 8px, 0); } 40% { clip: rect(14px, 9999px, 34px, 0); } 45% { clip: rect(100px, 9999px, 0px, 0); } 50% { clip: rect(64px, 9999px, 12px, 0); } 55% { clip: rect(8px, 9999px, 88px, 0); } 60% { clip: rect(44px, 9999px, 66px, 0); } 65% { clip: rect(2px, 9999px, 30px, 0); } 70% { clip: rect(78px, 9999px, 24px, 0); } 75% { clip: rect(20px, 9999px, 92px, 0); } 80% { clip: rect(86px, 9999px, 14px, 0); } 85% { clip: rect(32px, 9999px, 70px, 0); } 90% { clip: rect(58px, 9999px, 6px, 0); } 95% { clip: rect(16px, 9999px, 48px, 0); } 100% { clip: rect(94px, 9999px, 22px, 0); } } /* red/blue channel splits */ .glitch::after { content: attr(data-text); position: absolute; left: 2px; top: 0; color: #fff; text-shadow: -1px 0 #f00; background: transparent; overflow: hidden; clip: rect(0, 900px, 0, 0); animation: noise-anim 1s linear alternate-reverse; } .glitch::before { content: attr(data-text); position: absolute; left: -2px; top: 0; color: #fff; text-shadow: 1px 0 #00f; background: transparent; overflow: hidden; clip: rect(0, 900px, 0, 0); animation: noise-anim-2 1s linear alternate-reverse; } pre[class*="language-"], code[class*="language-"] { font-size: inherit; } .nav-active { color: #0FF; } ================================================ FILE: demo/static/docs.js ================================================ console.log("CUSTOM DOCS JS 2") const sections = document.querySelectorAll("section[id]") const navLinks = document.querySelectorAll('nav a[href^="#"]') let isNavigating = false const obs = new IntersectionObserver((entries) => { // Pick the most visible intersecting section const visible = entries .filter(e => e.isIntersecting) .sort((a, b) => b.intersectionRatio - a.intersectionRatio); if (!visible[0] || !visible[0].target.id) return const activeId = visible[0].target.id console.log("VISIBLE", activeId) if (!isNavigating) { highlightNav(activeId) } // Optional: keep URL in sync without jump history.replaceState(null, "", `#${activeId}`); }, { threshold: 0, rootMargin: "-10% 0px -80% 0px", }); sections.forEach(s => obs.observe(s)); function highlightNav(activeId) { console.log("highlightNav", activeId) const activeLink = document.querySelector('nav a[href^="#' + activeId + '"]') navLinks.forEach(a => a.classList.remove('nav-active')) activeLink.classList.add('nav-active') } window.addEventListener('popstate', function(event) { console.log("popstate", event, window.location.hash) isNavigating = true if (window.location.hash) { highlightNav(window.location.hash.substring(1)) } }); // window.addEventListener('scroll', (_event) => { // console.log('scroll'); // isScrolling = true // }) window.addEventListener('scrollend', (_event) => { console.log('scrollend'); isNavigating = false }); ================================================ FILE: demo/static/external.css ================================================ .item { border: 1px dashed; padding: 5px; padding-left: 10px; padding-right: 10px; } .item:hover { border-color: blue; color: blue; } .parent { display: flex; flex-direction: row; gap: 10px; padding: 10px; background-color: white; } .selected { font-weight: bold; border-width: 2px; padding: 4px; padding-left: 9px; padding-right: 9px; } ================================================ FILE: demo/static/prism.css ================================================ /* PrismJS 1.30.0 https://prismjs.com/download#themes=prism-okaidia&languages=markup+css+clike+javascript+haskell */ code[class*=language-],pre[class*=language-]{color:#f8f8f2;background:0 0;text-shadow:0 1px rgba(0,0,0,.3);font-family:Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace;font-size:0.875rem;text-align:left;white-space:pre;word-spacing:normal;word-break:normal;word-wrap:normal;line-height:1.5;-moz-tab-size:4;-o-tab-size:4;tab-size:4;-webkit-hyphens:none;-moz-hyphens:none;-ms-hyphens:none;hyphens:none}pre[class*=language-]{padding:1em;margin:.5em 0;overflow:auto;border-radius:.3em}:not(pre)>code[class*=language-],pre[class*=language-]{background:#272822}:not(pre)>code[class*=language-]{padding:.1em;border-radius:.3em;white-space:normal}.token.cdata,.token.comment,.token.doctype,.token.prolog{color:#8292a2}.token.punctuation{color:#f8f8f2}.token.namespace{opacity:.7}.token.constant,.token.deleted,.token.property,.token.symbol,.token.tag{color:#f92672}.token.boolean,.token.number{color:#ae81ff}.token.attr-name,.token.builtin,.token.char,.token.inserted,.token.selector,.token.string{color:#a6e22e}.language-css .token.string,.style .token.string,.token.entity,.token.operator,.token.url,.token.variable{color:#f8f8f2}.token.atrule,.token.attr-value,.token.class-name,.token.function{color:#e6db74}.token.keyword{color:#66d9ef}.token.important,.token.regex{color:#fd971f}.token.bold,.token.important{font-weight:700}.token.italic{font-style:italic}.token.entity{cursor:help} ================================================ FILE: demo/static/prism.js ================================================ /* PrismJS 1.30.0 https://prismjs.com/download#themes=prism&languages=markup+css+clike+javascript+haskell */ var _self="undefined"!=typeof window?window:"undefined"!=typeof WorkerGlobalScope&&self instanceof WorkerGlobalScope?self:{},Prism=function(e){var n=/(?:^|\s)lang(?:uage)?-([\w-]+)(?=\s|$)/i,t=0,r={},a={manual:e.Prism&&e.Prism.manual,disableWorkerMessageHandler:e.Prism&&e.Prism.disableWorkerMessageHandler,util:{encode:function e(n){return n instanceof i?new i(n.type,e(n.content),n.alias):Array.isArray(n)?n.map(e):n.replace(/&/g,"&").replace(/=g.reach);A+=w.value.length,w=w.next){var P=w.value;if(n.length>e.length)return;if(!(P instanceof i)){var E,S=1;if(y){if(!(E=l(b,A,e,m))||E.index>=e.length)break;var L=E.index,O=E.index+E[0].length,C=A;for(C+=w.value.length;L>=C;)C+=(w=w.next).value.length;if(A=C-=w.value.length,w.value instanceof i)continue;for(var j=w;j!==n.tail&&(Cg.reach&&(g.reach=W);var I=w.prev;if(_&&(I=u(n,I,_),A+=_.length),c(n,I,S),w=u(n,I,new i(f,p?a.tokenize(N,p):N,k,N)),M&&u(n,w,M),S>1){var T={cause:f+","+d,reach:W};o(e,n,t,w.prev,A,T),g&&T.reach>g.reach&&(g.reach=T.reach)}}}}}}function s(){var e={value:null,prev:null,next:null},n={value:null,prev:e,next:null};e.next=n,this.head=e,this.tail=n,this.length=0}function u(e,n,t){var r=n.next,a={value:t,prev:n,next:r};return n.next=a,r.prev=a,e.length++,a}function c(e,n,t){for(var r=n.next,a=0;a"+i.content+""},!e.document)return e.addEventListener?(a.disableWorkerMessageHandler||e.addEventListener("message",(function(n){var t=JSON.parse(n.data),r=t.language,i=t.code,l=t.immediateClose;e.postMessage(a.highlight(i,a.languages[r],r)),l&&e.close()}),!1),a):a;var g=a.util.currentScript();function f(){a.manual||a.highlightAll()}if(g&&(a.filename=g.src,g.hasAttribute("data-manual")&&(a.manual=!0)),!a.manual){var h=document.readyState;"loading"===h||"interactive"===h&&g&&g.defer?document.addEventListener("DOMContentLoaded",f):window.requestAnimationFrame?window.requestAnimationFrame(f):window.setTimeout(f,16)}return a}(_self);"undefined"!=typeof module&&module.exports&&(module.exports=Prism),"undefined"!=typeof global&&(global.Prism=Prism); Prism.languages.markup={comment:{pattern://,greedy:!0},prolog:{pattern:/<\?[\s\S]+?\?>/,greedy:!0},doctype:{pattern:/"'[\]]|"[^"]*"|'[^']*')+(?:\[(?:[^<"'\]]|"[^"]*"|'[^']*'|<(?!!--)|)*\]\s*)?>/i,greedy:!0,inside:{"internal-subset":{pattern:/(^[^\[]*\[)[\s\S]+(?=\]>$)/,lookbehind:!0,greedy:!0,inside:null},string:{pattern:/"[^"]*"|'[^']*'/,greedy:!0},punctuation:/^$|[[\]]/,"doctype-tag":/^DOCTYPE/i,name:/[^\s<>'"]+/}},cdata:{pattern://i,greedy:!0},tag:{pattern:/<\/?(?!\d)[^\s>\/=$<%]+(?:\s(?:\s*[^\s>\/=]+(?:\s*=\s*(?:"[^"]*"|'[^']*'|[^\s'">=]+(?=[\s>]))|(?=[\s/>])))+)?\s*\/?>/,greedy:!0,inside:{tag:{pattern:/^<\/?[^\s>\/]+/,inside:{punctuation:/^<\/?/,namespace:/^[^\s>\/:]+:/}},"special-attr":[],"attr-value":{pattern:/=\s*(?:"[^"]*"|'[^']*'|[^\s'">=]+)/,inside:{punctuation:[{pattern:/^=/,alias:"attr-equals"},{pattern:/^(\s*)["']|["']$/,lookbehind:!0}]}},punctuation:/\/?>/,"attr-name":{pattern:/[^\s>\/]+/,inside:{namespace:/^[^\s>\/:]+:/}}}},entity:[{pattern:/&[\da-z]{1,8};/i,alias:"named-entity"},/&#x?[\da-f]{1,8};/i]},Prism.languages.markup.tag.inside["attr-value"].inside.entity=Prism.languages.markup.entity,Prism.languages.markup.doctype.inside["internal-subset"].inside=Prism.languages.markup,Prism.hooks.add("wrap",(function(a){"entity"===a.type&&(a.attributes.title=a.content.replace(/&/,"&"))})),Object.defineProperty(Prism.languages.markup.tag,"addInlined",{value:function(a,e){var s={};s["language-"+e]={pattern:/(^$)/i,lookbehind:!0,inside:Prism.languages[e]},s.cdata=/^$/i;var t={"included-cdata":{pattern://i,inside:s}};t["language-"+e]={pattern:/[\s\S]+/,inside:Prism.languages[e]};var n={};n[a]={pattern:RegExp("(<__[^>]*>)(?:))*\\]\\]>|(?!)".replace(/__/g,(function(){return a})),"i"),lookbehind:!0,greedy:!0,inside:t},Prism.languages.insertBefore("markup","cdata",n)}}),Object.defineProperty(Prism.languages.markup.tag,"addAttribute",{value:function(a,e){Prism.languages.markup.tag.inside["special-attr"].push({pattern:RegExp("(^|[\"'\\s])(?:"+a+")\\s*=\\s*(?:\"[^\"]*\"|'[^']*'|[^\\s'\">=]+(?=[\\s>]))","i"),lookbehind:!0,inside:{"attr-name":/^[^\s=]+/,"attr-value":{pattern:/=[\s\S]+/,inside:{value:{pattern:/(^=\s*(["']|(?!["'])))\S[\s\S]*(?=\2$)/,lookbehind:!0,alias:[e,"language-"+e],inside:Prism.languages[e]},punctuation:[{pattern:/^=/,alias:"attr-equals"},/"|'/]}}}})}}),Prism.languages.html=Prism.languages.markup,Prism.languages.mathml=Prism.languages.markup,Prism.languages.svg=Prism.languages.markup,Prism.languages.xml=Prism.languages.extend("markup",{}),Prism.languages.ssml=Prism.languages.xml,Prism.languages.atom=Prism.languages.xml,Prism.languages.rss=Prism.languages.xml; !function(s){var e=/(?:"(?:\\(?:\r\n|[\s\S])|[^"\\\r\n])*"|'(?:\\(?:\r\n|[\s\S])|[^'\\\r\n])*')/;s.languages.css={comment:/\/\*[\s\S]*?\*\//,atrule:{pattern:RegExp("@[\\w-](?:[^;{\\s\"']|\\s+(?!\\s)|"+e.source+")*?(?:;|(?=\\s*\\{))"),inside:{rule:/^@[\w-]+/,"selector-function-argument":{pattern:/(\bselector\s*\(\s*(?![\s)]))(?:[^()\s]|\s+(?![\s)])|\((?:[^()]|\([^()]*\))*\))+(?=\s*\))/,lookbehind:!0,alias:"selector"},keyword:{pattern:/(^|[^\w-])(?:and|not|only|or)(?![\w-])/,lookbehind:!0}}},url:{pattern:RegExp("\\burl\\((?:"+e.source+"|(?:[^\\\\\r\n()\"']|\\\\[^])*)\\)","i"),greedy:!0,inside:{function:/^url/i,punctuation:/^\(|\)$/,string:{pattern:RegExp("^"+e.source+"$"),alias:"url"}}},selector:{pattern:RegExp("(^|[{}\\s])[^{}\\s](?:[^{};\"'\\s]|\\s+(?![\\s{])|"+e.source+")*(?=\\s*\\{)"),lookbehind:!0},string:{pattern:e,greedy:!0},property:{pattern:/(^|[^-\w\xA0-\uFFFF])(?!\s)[-_a-z\xA0-\uFFFF](?:(?!\s)[-\w\xA0-\uFFFF])*(?=\s*:)/i,lookbehind:!0},important:/!important\b/i,function:{pattern:/(^|[^-a-z0-9])[-a-z0-9]+(?=\()/i,lookbehind:!0},punctuation:/[(){};:,]/},s.languages.css.atrule.inside.rest=s.languages.css;var t=s.languages.markup;t&&(t.tag.addInlined("style","css"),t.tag.addAttribute("style","css"))}(Prism); Prism.languages.clike={comment:[{pattern:/(^|[^\\])\/\*[\s\S]*?(?:\*\/|$)/,lookbehind:!0,greedy:!0},{pattern:/(^|[^\\:])\/\/.*/,lookbehind:!0,greedy:!0}],string:{pattern:/(["'])(?:\\(?:\r\n|[\s\S])|(?!\1)[^\\\r\n])*\1/,greedy:!0},"class-name":{pattern:/(\b(?:class|extends|implements|instanceof|interface|new|trait)\s+|\bcatch\s+\()[\w.\\]+/i,lookbehind:!0,inside:{punctuation:/[.\\]/}},keyword:/\b(?:break|catch|continue|do|else|finally|for|function|if|in|instanceof|new|null|return|throw|try|while)\b/,boolean:/\b(?:false|true)\b/,function:/\b\w+(?=\()/,number:/\b0x[\da-f]+\b|(?:\b\d+(?:\.\d*)?|\B\.\d+)(?:e[+-]?\d+)?/i,operator:/[<>]=?|[!=]=?=?|--?|\+\+?|&&?|\|\|?|[?*/~^%]/,punctuation:/[{}[\];(),.:]/}; Prism.languages.javascript=Prism.languages.extend("clike",{"class-name":[Prism.languages.clike["class-name"],{pattern:/(^|[^$\w\xA0-\uFFFF])(?!\s)[_$A-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*(?=\.(?:constructor|prototype))/,lookbehind:!0}],keyword:[{pattern:/((?:^|\})\s*)catch\b/,lookbehind:!0},{pattern:/(^|[^.]|\.\.\.\s*)\b(?:as|assert(?=\s*\{)|async(?=\s*(?:function\b|\(|[$\w\xA0-\uFFFF]|$))|await|break|case|class|const|continue|debugger|default|delete|do|else|enum|export|extends|finally(?=\s*(?:\{|$))|for|from(?=\s*(?:['"]|$))|function|(?:get|set)(?=\s*(?:[#\[$\w\xA0-\uFFFF]|$))|if|implements|import|in|instanceof|interface|let|new|null|of|package|private|protected|public|return|static|super|switch|this|throw|try|typeof|undefined|var|void|while|with|yield)\b/,lookbehind:!0}],function:/#?(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*(?=\s*(?:\.\s*(?:apply|bind|call)\s*)?\()/,number:{pattern:RegExp("(^|[^\\w$])(?:NaN|Infinity|0[bB][01]+(?:_[01]+)*n?|0[oO][0-7]+(?:_[0-7]+)*n?|0[xX][\\dA-Fa-f]+(?:_[\\dA-Fa-f]+)*n?|\\d+(?:_\\d+)*n|(?:\\d+(?:_\\d+)*(?:\\.(?:\\d+(?:_\\d+)*)?)?|\\.\\d+(?:_\\d+)*)(?:[Ee][+-]?\\d+(?:_\\d+)*)?)(?![\\w$])"),lookbehind:!0},operator:/--|\+\+|\*\*=?|=>|&&=?|\|\|=?|[!=]==|<<=?|>>>?=?|[-+*/%&|^!=<>]=?|\.{3}|\?\?=?|\?\.?|[~:]/}),Prism.languages.javascript["class-name"][0].pattern=/(\b(?:class|extends|implements|instanceof|interface|new)\s+)[\w.\\]+/,Prism.languages.insertBefore("javascript","keyword",{regex:{pattern:RegExp("((?:^|[^$\\w\\xA0-\\uFFFF.\"'\\])\\s]|\\b(?:return|yield))\\s*)/(?:(?:\\[(?:[^\\]\\\\\r\n]|\\\\.)*\\]|\\\\.|[^/\\\\\\[\r\n])+/[dgimyus]{0,7}|(?:\\[(?:[^[\\]\\\\\r\n]|\\\\.|\\[(?:[^[\\]\\\\\r\n]|\\\\.|\\[(?:[^[\\]\\\\\r\n]|\\\\.)*\\])*\\])*\\]|\\\\.|[^/\\\\\\[\r\n])+/[dgimyus]{0,7}v[dgimyus]{0,7})(?=(?:\\s|/\\*(?:[^*]|\\*(?!/))*\\*/)*(?:$|[\r\n,.;:})\\]]|//))"),lookbehind:!0,greedy:!0,inside:{"regex-source":{pattern:/^(\/)[\s\S]+(?=\/[a-z]*$)/,lookbehind:!0,alias:"language-regex",inside:Prism.languages.regex},"regex-delimiter":/^\/|\/$/,"regex-flags":/^[a-z]+$/}},"function-variable":{pattern:/#?(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*(?=\s*[=:]\s*(?:async\s*)?(?:\bfunction\b|(?:\((?:[^()]|\([^()]*\))*\)|(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*)\s*=>))/,alias:"function"},parameter:[{pattern:/(function(?:\s+(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*)?\s*\(\s*)(?!\s)(?:[^()\s]|\s+(?![\s)])|\([^()]*\))+(?=\s*\))/,lookbehind:!0,inside:Prism.languages.javascript},{pattern:/(^|[^$\w\xA0-\uFFFF])(?!\s)[_$a-z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*(?=\s*=>)/i,lookbehind:!0,inside:Prism.languages.javascript},{pattern:/(\(\s*)(?!\s)(?:[^()\s]|\s+(?![\s)])|\([^()]*\))+(?=\s*\)\s*=>)/,lookbehind:!0,inside:Prism.languages.javascript},{pattern:/((?:\b|\s|^)(?!(?:as|async|await|break|case|catch|class|const|continue|debugger|default|delete|do|else|enum|export|extends|finally|for|from|function|get|if|implements|import|in|instanceof|interface|let|new|null|of|package|private|protected|public|return|set|static|super|switch|this|throw|try|typeof|undefined|var|void|while|with|yield)(?![$\w\xA0-\uFFFF]))(?:(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*\s*)\(\s*|\]\s*\(\s*)(?!\s)(?:[^()\s]|\s+(?![\s)])|\([^()]*\))+(?=\s*\)\s*\{)/,lookbehind:!0,inside:Prism.languages.javascript}],constant:/\b[A-Z](?:[A-Z_]|\dx?)*\b/}),Prism.languages.insertBefore("javascript","string",{hashbang:{pattern:/^#!.*/,greedy:!0,alias:"comment"},"template-string":{pattern:/`(?:\\[\s\S]|\$\{(?:[^{}]|\{(?:[^{}]|\{[^}]*\})*\})+\}|(?!\$\{)[^\\`])*`/,greedy:!0,inside:{"template-punctuation":{pattern:/^`|`$/,alias:"string"},interpolation:{pattern:/((?:^|[^\\])(?:\\{2})*)\$\{(?:[^{}]|\{(?:[^{}]|\{[^}]*\})*\})+\}/,lookbehind:!0,inside:{"interpolation-punctuation":{pattern:/^\$\{|\}$/,alias:"punctuation"},rest:Prism.languages.javascript}},string:/[\s\S]+/}},"string-property":{pattern:/((?:^|[,{])[ \t]*)(["'])(?:\\(?:\r\n|[\s\S])|(?!\2)[^\\\r\n])*\2(?=\s*:)/m,lookbehind:!0,greedy:!0,alias:"property"}}),Prism.languages.insertBefore("javascript","operator",{"literal-property":{pattern:/((?:^|[,{])[ \t]*)(?!\s)[_$a-zA-Z\xA0-\uFFFF](?:(?!\s)[$\w\xA0-\uFFFF])*(?=\s*:)/m,lookbehind:!0,alias:"property"}}),Prism.languages.markup&&(Prism.languages.markup.tag.addInlined("script","javascript"),Prism.languages.markup.tag.addAttribute("on(?:abort|blur|change|click|composition(?:end|start|update)|dblclick|error|focus(?:in|out)?|key(?:down|up)|load|mouse(?:down|enter|leave|move|out|over|up)|reset|resize|scroll|select|slotchange|submit|unload|wheel)","javascript")),Prism.languages.js=Prism.languages.javascript; Prism.languages.haskell={comment:{pattern:/(^|[^-!#$%*+=?&@|~.:<>^\\\/])(?:--(?:(?=.)[^-!#$%*+=?&@|~.:<>^\\\/].*|$)|\{-[\s\S]*?-\})/m,lookbehind:!0},char:{pattern:/'(?:[^\\']|\\(?:[abfnrtv\\"'&]|\^[A-Z@[\]^_]|ACK|BEL|BS|CAN|CR|DC1|DC2|DC3|DC4|DEL|DLE|EM|ENQ|EOT|ESC|ETB|ETX|FF|FS|GS|HT|LF|NAK|NUL|RS|SI|SO|SOH|SP|STX|SUB|SYN|US|VT|\d+|o[0-7]+|x[0-9a-fA-F]+))'/,alias:"string"},string:{pattern:/"(?:[^\\"]|\\(?:\S|\s+\\))*"/,greedy:!0},keyword:/\b(?:case|class|data|deriving|do|else|if|in|infixl|infixr|instance|let|module|newtype|of|primitive|then|type|where)\b/,"import-statement":{pattern:/(^[\t ]*)import\s+(?:qualified\s+)?(?:[A-Z][\w']*)(?:\.[A-Z][\w']*)*(?:\s+as\s+(?:[A-Z][\w']*)(?:\.[A-Z][\w']*)*)?(?:\s+hiding\b)?/m,lookbehind:!0,inside:{keyword:/\b(?:as|hiding|import|qualified)\b/,punctuation:/\./}},builtin:/\b(?:abs|acos|acosh|all|and|any|appendFile|approxRational|asTypeOf|asin|asinh|atan|atan2|atanh|basicIORun|break|catch|ceiling|chr|compare|concat|concatMap|const|cos|cosh|curry|cycle|decodeFloat|denominator|digitToInt|div|divMod|drop|dropWhile|either|elem|encodeFloat|enumFrom|enumFromThen|enumFromThenTo|enumFromTo|error|even|exp|exponent|fail|filter|flip|floatDigits|floatRadix|floatRange|floor|fmap|foldl|foldl1|foldr|foldr1|fromDouble|fromEnum|fromInt|fromInteger|fromIntegral|fromRational|fst|gcd|getChar|getContents|getLine|group|head|id|inRange|index|init|intToDigit|interact|ioError|isAlpha|isAlphaNum|isAscii|isControl|isDenormalized|isDigit|isHexDigit|isIEEE|isInfinite|isLower|isNaN|isNegativeZero|isOctDigit|isPrint|isSpace|isUpper|iterate|last|lcm|length|lex|lexDigits|lexLitChar|lines|log|logBase|lookup|map|mapM|mapM_|max|maxBound|maximum|maybe|min|minBound|minimum|mod|negate|not|notElem|null|numerator|odd|or|ord|otherwise|pack|pi|pred|primExitWith|print|product|properFraction|putChar|putStr|putStrLn|quot|quotRem|range|rangeSize|read|readDec|readFile|readFloat|readHex|readIO|readInt|readList|readLitChar|readLn|readOct|readParen|readSigned|reads|readsPrec|realToFrac|recip|rem|repeat|replicate|return|reverse|round|scaleFloat|scanl|scanl1|scanr|scanr1|seq|sequence|sequence_|show|showChar|showInt|showList|showLitChar|showParen|showSigned|showString|shows|showsPrec|significand|signum|sin|sinh|snd|sort|span|splitAt|sqrt|subtract|succ|sum|tail|take|takeWhile|tan|tanh|threadToIOResult|toEnum|toInt|toInteger|toLower|toRational|toUpper|truncate|uncurry|undefined|unlines|until|unwords|unzip|unzip3|userError|words|writeFile|zip|zip3|zipWith|zipWith3)\b/,number:/\b(?:\d+(?:\.\d+)?(?:e[+-]?\d+)?|0o[0-7]+|0x[0-9a-f]+)\b/i,operator:[{pattern:/`(?:[A-Z][\w']*\.)*[_a-z][\w']*`/,greedy:!0},{pattern:/(\s)\.(?=\s)/,lookbehind:!0},/[-!#$%*+=?&@|~:<>^\\\/][-!#$%*+=?&@|~.:<>^\\\/]*|\.[-!#$%*+=?&@|~.:<>^\\\/]+/],hvariable:{pattern:/\b(?:[A-Z][\w']*\.)*[_a-z][\w']*/,inside:{punctuation:/\./}},constant:{pattern:/\b(?:[A-Z][\w']*\.)*[A-Z][\w']*/,inside:{punctuation:/\./}},punctuation:/[{}[\];(),.:]/},Prism.languages.hs=Prism.languages.haskell; ================================================ FILE: demo/static/test.js ================================================ console.log('test.js') window.addEventListener('load', function() { let other = Hyperbole.hyperView("Other") document.addEventListener("hello", function(e) { console.log("got event", e.type, e.detail, e) other.runAction("Sneaky") }) }) ================================================ FILE: demo/static/todomvc.css ================================================ /* Undo the CSS reset for the TODOMVC example. This is only needed for the examples, because * we need to apply the reset for everything *except TodoMVC CSS-only. In a real app, if you * do not want to use atomic-css, simply omit the reset from your document function. * * In practice, you usually want a css reset anyway, even if you aren't using Atomic CSS * */ p { margin: 1em auto; } footer { padding-bottom: 30px !important; } a { color: #b83f45 !important; } h1 { top: -80px !important; } /* Changes to accomodate slightly different DOM generated by Hyperbole */ .todo-list li { border-bottom: 1px solid #ededed !important; } .todo-list div:last-child li { border-bottom: none !important; } ================================================ FILE: docs/Main.hs ================================================ {-# LANGUAGE QuasiQuotes #-} module Main where import Control.Exception (SomeException, try) 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 Distribution.Simple.Utils (copyDirectoryRecursive) import Distribution.Verbosity (verbose) import System.Directory import System.FilePath import Web.Hyperbole.Data.URI -- import Control.Applicative ((<|>)) -- import Web.Hyperbole.Route (matchRoute) main :: IO () main = do let tmpDir = "/tmp/hyperbole" copyExtraFilesTo tmpDir expandSourcesTo tmpDir putStrLn $ "COPY RECURSIVE: " <> (tmpDir <> "docs") copyDirectoryRecursive verbose "./docs" (tmpDir "docs") copyDirectoryRecursive verbose "./demo" (tmpDir "demo") 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 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") expandAndCopyFileTo :: FilePath -> FilePath -> IO () expandAndCopyFileTo tmpDir pth = do putStrLn $ "EXPANDING " <> pth src <- readSource pth expanded <- expandFile src writeSource tmpDir pth expanded readSource :: FilePath -> IO SourceCode readSource pth = do inp <- T.readFile pth pure $ SourceCode $ T.lines inp writeSource :: FilePath -> FilePath -> SourceCode -> IO () writeSource tmpDir relPath src = do let pth = tmpDir cleanRelativeDir relPath -- putStrLn $ "WRITE " <> pth <> " " <> show (length src.lines) createDirectoryIfMissing True $ takeDirectory pth T.writeFile pth $ T.unlines src.lines 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 } -- | Example Path deriving (Eq) newtype SourceCode = SourceCode {lines :: [Text]} instance Show Macro where -- show (Example p) = "Example " <> show p show (Embed mn def) = "Embed " <> show mn <> " " <> show def newtype ModuleName = ModuleName Text deriving newtype (Eq, Show) newtype TopLevelDefinition = TopLevelDefinition Text 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 case parseMacro line of Nothing -> do pure [line] Just (pre, Embed src def) -> do expandEmbed src pre def 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 (mn, definition) <- splitSrcDef $ T.dropWhile (== ' ') info pure (prefix, Embed mn definition) _ -> Nothing splitSrcDef inp = let (mn, def) = T.breakOn " " inp in pure (ModuleName mn, TopLevelDefinition $ T.drop 1 def) -- look it up as a URI... -- * #EXAMPLE /simple -- 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" 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) pure $ fmap markupLine expanded where requireTopLevel :: TopLevelDefinition -> SourceCode -> IO [Text] requireTopLevel tld sc = case findTopLevel tld sc of [] -> fail $ "Could not find: " <> show (Embed mn def) <> " " <> show def lns -> pure lns -- addPrefix line = embed.prefix <> line markupLine :: Text -> Text markupLine line = case pfx of "" -> markupLineAt line _ -> markupLinePrefix line markupLineAt = T.replace "\"" "\\\"" . highlightTermsLine markupLinePrefix line = pfx <> line highlightTermsLine :: Text -> Text highlightTermsLine ln = mconcat $ fmap highlightWord $ T.groupBy isSameTerm ln where isSameTerm :: Char -> Char -> Bool isSameTerm c1 c2 = (isAlpha c1 && isAlpha c2) || (isSpace c1 && isSpace c2) highlightWord :: Text -> Text highlightWord w = if w `elem` terms then "'" <> w <> "'" else w terms :: [Text] terms = [ "HyperView" , "View" , "Action" , "update" , "hyper" , "Page" , "liveApp" , "quickStartDocument" , "runPage" , "run" , "ViewId" , "viewId" , "ViewAction" , "Eff" , "button" , "el" , "el_" , "Hyperbole" , "Route" , "routeRequest" , "route" , "layout" , "Response" , "ToParam" , "FromParam" , "Session" , "FromQuery" , "ToQuery" , "lookupParam" , "setParam" , "DefaultParam" , "Client" ] -- returns lines of a top-level definition findTopLevel :: TopLevelDefinition -> SourceCode -> [Text] findTopLevel (TopLevelDefinition definition) source = let rest = dropWhile (not . isTopLevel) source.lines in dropWhileEnd isEmpty $ takeWhile isCurrentDefinition rest where isTopLevel = T.isPrefixOf definition isEmpty = T.null -- isBlankLine line = T.null $ T.strip line isCurrentDefinition line = isTopLevel line || not (isFullyOutdented line) dropWhileEnd p as = reverse $ dropWhile p $ reverse as isFullyOutdented :: Text -> Bool isFullyOutdented line = case cs (T.take 1 line) of "" -> False [c] -> not $ isSpace c _ -> False ================================================ FILE: docs/app-document.md ================================================ The first argument is a `document` function. This turns an initial page fragment into a full document, complete with `' script' :: ByteString -> View c () script' dat = tag' True "script" $ raw $ T.replace " View c () style cnt = tag "style" (raw $ cs cnt) @ type_ "text/css" stylesheet :: Text -> View c () stylesheet href = tag "link" @ att "rel" "stylesheet" . att "href" href $ none -- * Navigation nav :: View c () -> View c () nav = tag "nav" -- * Tables {- | Create a type safe data table by specifying columns > data User = User {name :: Text, email :: Text} > > usersTable :: [User] -> View c () > usersTable us = do > table us $ do > tcol (th "Name" ~ hd) $ \u -> td ~ cell $ text u.name > tcol (th "Email" ~ hd) $ \u -> td ~ cell $ text u.email > where > hd = cell . bold > cell :: (Styleable h) => CSS h -> CSS h > cell = pad 4 . border 1 -} table :: [dt] -> TableColumns c dt () -> View c () table dts (TableColumns wcs) = do let cols = runPureEff . execStateLocal [] $ wcs tag "table" $ do tag "thead" $ do tag "tr" $ do forM_ cols $ \tc -> do let TableHead hd = tc.headCell hd tag "tbody" $ do forM_ dts $ \dt -> do tag "tr" $ do forM_ cols $ \tc -> do tc.dataCell dt usersTable :: View c () usersTable = do table items $ do tcol (th "Index" ~ bold) $ \u -> td ~ cell $ text $ pack $ show $ fst u tcol (th "Item" ~ bold) $ \u -> td ~ cell $ text $ snd u where items :: [(Int, Text)] items = zip [0 ..] ["one", "two", "three"] cell :: (Styleable h) => CSS h -> CSS h cell = pad 4 . border 1 newtype Table c a = Table (View c a) deriving newtype (Functor, Applicative, Monad, Styleable) tcol :: forall dt c. TableHead c () -> (dt -> View c ()) -> TableColumns c dt () tcol hd cell = TableColumns $ do modify @[TableColumn c dt] $ \cols -> cols <> [TableColumn hd cell] th :: View c () -> TableHead c () th cnt = do TableHead $ tag "th" cnt td :: View c () -> View c () td = tag "td" instance {-# OVERLAPS #-} Styleable (TableColumns c dt () -> View c ()) where modCSS frr parent eff = modCSS frr (parent eff) newtype TableHead id a = TableHead (View id a) deriving newtype (Functor, Applicative, Monad, Styleable) newtype TableColumns c dt a = TableColumns (Eff '[State [TableColumn c dt]] a) deriving newtype (Functor, Applicative, Monad) data TableColumn c dt = TableColumn { headCell :: TableHead c () , dataCell :: dt -> View c () } -- * Lists {- | List elements do not include any inherent styling but are useful for accessibility. See 'Web.Atomic.CSS.list'. > ol id $ do > let nums = list Decimal > li nums "one" > li nums "two" > li nums "three" -} ol :: ListItem c () -> View c () ol (ListItem cnt) = do tag "ol" cnt ul :: ListItem c () -> View c () ul (ListItem cnt) = do tag "ul" cnt li :: View c () -> ListItem c () li cnt = ListItem $ do tag "li" cnt newtype ListItem c a = ListItem (View c a) deriving newtype (Functor, Applicative, Monad, Styleable) ================================================ FILE: src/Web/Hyperbole/View/Types.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} module Web.Hyperbole.View.Types where import Data.String (IsString (..)) import Data.Text (Text, pack) import Effectful import Effectful.Reader.Dynamic import Effectful.State.Dynamic import GHC.Generics import Web.Atomic.Html (Html (..)) import Web.Atomic.Html qualified as Atomic import Web.Atomic.Types import Web.Hyperbole.Data.Encoded (decodeEither, encodedToText) import Web.Hyperbole.Data.Param (FromParam, ToParam (..)) import Web.Hyperbole.View.ViewId -- View ------------------------------------------------------------ {- | 'View's are HTML fragments with a 'context' @ #EMBED Example.Docs.BasicPage helloWorld @ -} newtype View c a = View {html :: Eff '[Reader (c, ViewState c)] (Html a)} instance IsString (View c ()) where fromString s = View $ pure $ Atomic.text (pack s) execView :: forall c a. c -> ViewState c -> View c a -> Html a execView c st (View eff) = do runPureEff $ runReader (c, st) eff instance Functor (View c) where fmap f (View eff) = View $ do html <- eff pure $ fmap f html instance Applicative (View ctx) where pure a = View $ pure $ pure a liftA2 :: (a -> b -> c) -> View ctx a -> View ctx b -> View ctx c liftA2 abc (View va) (View vb) = View $ do ha <- va hb <- vb pure $ liftA2 abc ha hb View va *> View vb = View $ do ha <- va hb <- vb pure $ ha *> hb instance Monad (View ctx) where (>>) = (*>) (>>=) :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b -- TEST: appending Empty View ea >>= famb = View $ do ha <- ea let View eb = famb ha.value (ha >>) <$> eb -- Context ----------------------------------------- -- type family ViewContext (v :: Type) where -- ViewContext (View c x) = c -- ViewContext (View c x -> View c x) = c newtype ChildView a = ChildView a deriving (Generic) instance (ViewId a, FromParam a, ToParam a) => ViewId (ChildView a) where type ViewState (ChildView a) = ViewState a -- TEST: appending Empty context :: forall c. View c (c, ViewState c) context = View $ do c <- ask @(c, ViewState c) pure $ pure c viewState :: View c (ViewState c) viewState = snd <$> context runViewContext :: ctx -> ViewState ctx -> View ctx () -> View c () runViewContext c st (View eff) = View $ do pure $ runPureEff $ runReader (c, st) eff runChildView :: (ViewState ctx ~ ViewState c) => (c -> ctx) -> View ctx () -> View c () runChildView f v = do st <- viewState c <- viewId runViewContext (f c) st v -- modifyContext -- :: forall ctx0 ctx1. (ctx0 -> ctx1) -> View ctx1 () -> View ctx0 () -- modifyContext f (View eff) = View $ do -- ctx0 <- ask @ctx0 -- pure $ runPureEff $ runReader (f ctx0) eff -- Attributes ----------------------------------------- instance Attributable (View c a) where modAttributes f (View eff) = View $ do h <- eff pure $ modAttributes f h instance Styleable (View c a) where modCSS f (View eff) = View $ do h <- eff pure $ modCSS f h {- | 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 @ -} class HasViewId m view where viewId :: m view instance HasViewId (View ctx) ctx where viewId = fst <$> context instance (ViewState view ~ st) => HasViewId (Eff (Reader view : State st : es)) view where viewId = ask encodeViewId :: (ViewId id) => id -> Text encodeViewId = encodedToText . toViewId decodeViewId :: (ViewId id) => Text -> Maybe id decodeViewId t = do case parseViewId =<< decodeEither t of Left _ -> Nothing Right a -> pure a ================================================ FILE: src/Web/Hyperbole/View/ViewAction.hs ================================================ {-# LANGUAGE DefaultSignatures #-} module Web.Hyperbole.View.ViewAction where import Data.Text (Text) import GHC.Generics import Web.Hyperbole.Data.Encoded as Encoded {- | Define every action possible for a given 'HyperView' @ #EMBED Example.Simple instance HyperView Message @ -} class ViewAction a where toAction :: a -> Encoded default toAction :: (Generic a, GToEncoded (Rep a)) => a -> Encoded toAction = genericToEncoded parseAction :: Encoded -> Either String a default parseAction :: (Generic a, GFromEncoded (Rep a)) => Encoded -> Either String a parseAction = genericParseEncoded instance ViewAction () where toAction _ = mempty parseAction _ = pure () encodeAction :: (ViewAction act) => act -> Text encodeAction = encodedToText . toAction decodeAction :: (ViewAction act) => Text -> Maybe act decodeAction t = do case parseAction =<< encodedParseText t of Left _ -> Nothing Right a -> pure a ================================================ FILE: src/Web/Hyperbole/View/ViewId.hs ================================================ {-# LANGUAGE DefaultSignatures #-} module Web.Hyperbole.View.ViewId where import Data.Kind (Type) import GHC.Generics import Web.Hyperbole.Data.Encoded as Encoded {- | A unique identifier for a 'HyperView' @ #EMBED Example.Simple data Message @ -} class ViewId a where type ViewState a :: Type type ViewState a = () toViewId :: a -> Encoded default toViewId :: (Generic a, GToEncoded (Rep a)) => a -> Encoded toViewId = genericToEncoded parseViewId :: Encoded -> Either String a default parseViewId :: (Generic a, GFromEncoded (Rep a)) => Encoded -> Either String a parseViewId = genericParseEncoded instance ViewId () where toViewId _ = mempty parseViewId _ = pure () ================================================ FILE: src/Web/Hyperbole/View.hs ================================================ module Web.Hyperbole.View ( module Web.Hyperbole.View.Types , module Web.Hyperbole.View.ViewId , module Web.Hyperbole.View.ViewAction , module Web.Hyperbole.View.Embed , module Web.Hyperbole.View.Render , module Web.Hyperbole.View.Tag , module Web.Hyperbole.View.CSS , module Web.Atomic.Attributes ) where import Web.Atomic.Attributes import Web.Hyperbole.View.CSS import Web.Hyperbole.View.Embed import Web.Hyperbole.View.Render import Web.Hyperbole.View.Tag hiding (form, input, label) import Web.Hyperbole.View.Types import Web.Hyperbole.View.ViewAction import Web.Hyperbole.View.ViewId ================================================ FILE: src/Web/Hyperbole.hs ================================================ {- | Module: Web.Hyperbole Copyright: (c) 2024 Sean Hess License: BSD3 Maintainer: Sean Hess Stability: experimental Portability: portable Create fully interactive HTML applications with type-safe serverside Haskell. Inspired by [HTMX](https://htmx.org/), [Elm](https://elm-lang.org/), and [Phoenix LiveView](https://www.phoenixframework.org/) * [hyperbole.live](https://hyperbole.live) - documentation and examples * [github](https://github.com/seanhess/hyperbole) - issues and source code -} module Web.Hyperbole ( -- * Application #application# liveApp , Warp.run -- ** Page , Page , runPage -- ** Document , document , quickStartDocument , DocumentHead , quickStart , mobileFriendly -- ** Type-Safe Routes #routes# , Route (..) , routeRequest -- maybe belongs in an application section , routeUri , route -- * Hyperbole Effect #hyperbole-effect# , Hyperbole -- ** Request #request# , request , Request (..) -- ** Response #response# , respondError , respondErrorView , notFound , redirect -- ** Query #query# -- $query , ToQuery (..) , FromQuery (..) , query , setQuery , modifyQuery , clearQuery , param , lookupParam , setParam , deleteParam , queryParams -- ** Sessions #sessions# -- $sessions , Session (..) , session , saveSession , lookupSession , modifySession , modifySession_ , deleteSession -- ** Control Client #client# , pageTitle , trigger , pushEvent , pushUpdate -- * HyperView #hyperview# , HyperView (..) , hyper , hyperState , HasViewId (..) -- * Interactive Elements #interactive# , button , search , dropdown , option , Option -- * Events , onClick , onDblClick , onMouseEnter , onMouseLeave , onInput , onLoad , DelayMs , onKeyDown , onKeyUp , Key (..) -- * Type-Safe Forms #forms# -- $forms , FromForm (..) , FromFormF (..) , formData , GenFields (..) , fieldNames , FieldName (..) , FormFields -- , FormField (..) , Field , Identity -- ** Form View , form , field , label , input , checkbox , radioGroup , radio , select , checked , textarea , submit , View.placeholder , InputType (..) -- ** Validation , Validated (..) , isInvalid , validate , invalidText -- * Query Param Encoding #query-param# , QueryData , ToParam (..) , FromParam (..) , ToEncoded , FromEncoded -- * Advanced #advanced# , target , Response , Root , ConcurrencyMode (..) -- * Exports #exports# -- ** View , View (..) , module View -- ** Embeds -- | Embedded CSS and Javascript to include in your document function. See 'quickStartDocument' , module Web.Hyperbole.View.Embed -- ** Effectful -- $effects , module Effectful -- ** Other , URI (..) , uri , Application , module GHC.Generics , Default (..) , ToJSON , FromJSON ) where import Data.Aeson (FromJSON, ToJSON) import Data.Default import Effectful (Eff, (:>)) import GHC.Generics (Generic, Rep) import Network.Wai (Application) import Network.Wai.Handler.Warp as Warp (run) import Web.Atomic.CSS () import Web.Atomic.Types () import Web.Hyperbole.Application import Web.Hyperbole.Data.Encoded (FromEncoded, ToEncoded) import Web.Hyperbole.Data.Param import Web.Hyperbole.Data.QueryData import Web.Hyperbole.Document import Web.Hyperbole.Effect.Client import Web.Hyperbole.Effect.Hyperbole import Web.Hyperbole.Effect.Query import Web.Hyperbole.Effect.Request import Web.Hyperbole.Effect.Response import Web.Hyperbole.Effect.Session import Web.Hyperbole.HyperView import Web.Hyperbole.HyperView.Forms import Web.Hyperbole.Page (Page, runPage) import Web.Hyperbole.Route import Web.Hyperbole.Types.Request import Web.Hyperbole.Types.Response import Web.Hyperbole.View hiding (placeholder) import Web.Hyperbole.View qualified as View hiding (Attributable, Attributes, View) import Web.Hyperbole.View.Embed {- $documentation Please visit https://hyperbole.live for documentation and examples -} -- TODO: NSO link ================================================ FILE: test/Spec.hs ================================================ import Skeletest.Main ================================================ FILE: test/Test/EncodedSpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} module Test.EncodedSpec where import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) import Data.Text (Text) import GHC.Generics (Generic) import Skeletest import Web.Hyperbole.Data.Encoded import Web.Hyperbole.Data.Param -- TEST: QueryData underscores vs spaces data One = One -- toJSON automatically delegates to the child's ToJSON instance -- when it ought to be enought to delegate to the Generic instance! deriving (Generic, Eq, ToEncoded, FromEncoded, ToParam, FromParam) data Tag = A | B | C | D deriving (Generic, Eq, ToEncoded, ToParam, FromParam) data Two = Two | Two2 Int deriving (Generic, Eq, ToJSON, FromJSON, ToEncoded, FromEncoded) -- Custom Param Encoding instance ToParam Two where toParam Two = "Two" toParam other = genericToParam other instance FromParam Two where parseParam "Two" = pure Two parseParam other = genericParseParam other data Sum = Sumthing | Num Int | Str Text | COne One | CTwo Two | List [Text] deriving (Generic, Eq, ToEncoded, FromEncoded) data Nested = Gogo One | RecordN Record | RecordEx Record Int | Tag Tag deriving (Generic, ToEncoded, FromEncoded, Eq) data Product = Product Text Int Bool deriving (Generic, Eq, ToEncoded, FromEncoded) data Record = Record { one :: Int , two :: Text } deriving (Generic, Show, ToJSON, FromJSON, Eq, ToEncoded, FromEncoded, ToParam, FromParam) data Product4 = Product4 Text Text Text Text deriving (Generic, Show, Eq, Read, FromEncoded, ToEncoded) spec :: Spec spec = withMarkers ["encoded"] $ do describe "genericToEncoded" $ do it "should encode single tags" $ do genericToEncoded One `shouldBe` Encoded "One" [] it "should encode multi tags" $ do genericToEncoded Two `shouldBe` Encoded "Two" [] genericToEncoded (Two2 3) `shouldBe` Encoded "Two2" [jsonParam $ Number 3] genericToEncoded (Gogo One) `shouldBe` Encoded "Gogo" [toParam One] it "should encode sum tags" $ do genericToEncoded (CTwo Two) `shouldBe` Encoded "CTwo" [toParam Two] it "basic" $ do genericToEncoded (Gogo One) `shouldBe` Encoded "Gogo" [toParam One] it "product" $ do genericToEncoded (Product "one" 2 True) `shouldBe` Encoded "Product" [toParam @Text "one", toParam @Int 2, toParam True] it "product4" $ do let prod = Product4 "one" "two" "three" "four" genericToEncoded prod `shouldBe` Encoded "Product4" (fmap toParam ["one" :: Text, "two", "three", "four"]) describe "genericParseEncoded" $ do it "product4" $ do genericParseEncoded (Encoded "Product4" (fmap toParam ["one" :: Text, "two", "three", "four"])) `shouldBe` Right (Product4 "one" "two" "three" "four") it "sum" $ do genericParseEncoded @Sum (Encoded "Sumthing" []) `shouldBe` Right Sumthing genericParseEncoded @Sum (Encoded "Num" [toParam @Int 2]) `shouldBe` Right (Num 2) genericParseEncoded @Sum (Encoded "Str" [toParam @Text "OK"]) `shouldBe` Right (Str "OK") genericParseEncoded @Sum (Encoded "COne" [toParam One]) `shouldBe` Right (COne One) genericParseEncoded @Sum (Encoded "CTwo" [toParam Two]) `shouldBe` Right (CTwo Two) describe "toEncoded" $ do it "encodes numbers as text" $ do -- no, this is right, but when we go to decode, we pick up the json instance... toEncoded (Num 1) `shouldBe` Encoded "Num" [jsonParam $ Number 1] describe "toText" $ do it "should encode single tags" $ do encodedToText (Encoded "One" []) `shouldBe` "One" describe "parseText" $ do it "should decode single tags" $ do encodedParseText "One" `shouldBe` Right (Encoded "One" []) it "parses numbers" $ do encodedParseText "Num 1" `shouldBe` Right (Encoded "Num" [jsonParam $ Number 1]) describe "encode" $ do it "should encode single tags" $ do encode One `shouldBe` "One" it "encodes strings" $ do encode (Str "hello world") `shouldBe` "Str hello_world" -- but then how is it going to know the difference between the two? encode (Str " ") `shouldBe` "Str _" encode (Str "") `shouldBe` "Str |" encode (Str "_") `shouldBe` "Str \\_" encode (Str "\n") `shouldBe` "Str \\n" encode (Str "hello_world") `shouldBe` "Str hello\\_world" encode (Str "hello+world") `shouldBe` "Str hello+world" encode (Str "hello\nworld") `shouldBe` "Str hello\\nworld" it "should encode records`" $ do -- no field names for ourselves encode (Record 1 "two") `shouldBe` "Record 1 two" -- but if it is nested it uses the JSON instance, obviously let r2 = Record 1 "two" encode (RecordN r2) `shouldBe` "RecordN " <> encodeParam (jsonParam r2) it "no special case for nested constructors`" $ do encode A `shouldBe` "A" encode (Tag A) `shouldBe` "Tag A" it "should encode sum" $ do encode (Num 1) `shouldBe` "Num 1" encode (Str "hello world") `shouldBe` "Str hello_world" it "should encode prodcuts" $ do encode (Product "hello world" 2 True) `shouldBe` "Product hello_world 2 true" it "encodes more constructors" $ do encode (CTwo (Two2 3)) `shouldBe` "CTwo [\"Two2\",3]" encode (CTwo Two) `shouldBe` "CTwo Two" -- uses the custom toparam instance encode (COne One) `shouldBe` "COne []" describe "decode" $ do it "should encode single tags" $ do decode "One" `shouldBe` Just One it "should decode nested sum" $ do decodeEither "Num 1" `shouldBe` Right (Num 1) decodeEither "Str str" `shouldBe` Right (Str "str") decodeEither "Str hello_world" `shouldBe` Right (Str "hello world") it "no special case for nested constructors`" $ do decode "Tag A" `shouldBe` Just (Tag A) it "decodes strings" $ do decode "Str |" `shouldBe` pure (Str "") describe "params" $ do it "sanitizeText" $ do encodeParam "hello world" `shouldBe` "hello_world" encodeParam "hello_world" `shouldBe` "hello\\_world" encodeParam "hello\nworld" `shouldBe` "hello\\nworld" it "desanitizeText" $ do decodeParam "hello_world" `shouldBe` "hello world" decodeParam "hello\\_world" `shouldBe` "hello_world" decodeParam "hello\\nworld" `shouldBe` "hello\nworld" -- TODO: Add more edge cases to check if "\n" is escaped properly. it "edge cases" $ do encodeParam "" `shouldBe` "|" encodeParam " " `shouldBe` "_" encodeParam " " `shouldBe` "__" encodeParam "_" `shouldBe` "\\_" encodeParam "__" `shouldBe` "\\_\\_" decodeParam "|" `shouldBe` "" decodeParam "_" `shouldBe` " " decodeParam "\\_" `shouldBe` "_" decodeParam "\\_\\_" `shouldBe` "__" describe "round trip" $ do it "records" $ do let enc = genericToEncoded (Record 1 "two") genericParseEncoded enc `shouldBe` Right (Record 1 "two") it "product" $ do decode (encode (Product "hello world" 2 False)) `shouldBe` Just (Product "hello world" 2 False) decode (encode (Product "bob" (-2) True)) `shouldBe` Just (Product "bob" (-2) True) it "nested product with records" $ do let r = RecordEx (Record 2 "three") 33 let t = encode r decode t `shouldBe` Just r it "special case constructors" $ do decode (encode (CTwo Two)) `shouldBe` Just (CTwo Two) decode (encode (Tag B)) `shouldBe` Just (Tag B) it "big product" $ do let p = Product4 "hello world" "two_times" "three" "four" decode (encode p) `shouldBe` Just p it "empty strings" $ do decode (encode $ Str "") `shouldBe` Just (Str "") it "special characters" $ do let str = "hello+world \"bob_lives\"" decode (encode $ Str str) `shouldBe` Just (Str str) it "encodes lists`" $ do let l = List ["hello, world", "", "+,|<[]"] print $ encode l decode @Sum (encode l) `shouldBe` Just l -- Regression tests for https://github.com/seanhess/hyperbole/issues/187 -- A ViewId (or state) containing a list with newline characters must -- encode/decode correctly. Previously, desanitizeParamText blindly -- replaced the JSON escape sequence "\\n" with a real newline, corrupting -- the JSON and causing "No Handler for Event viewId". it "list with newline character round-trips correctly (issue #187)" $ do decode @Sum (encode (List ["\n"])) `shouldBe` Just (List ["\n"]) it "list with newline in multiple elements" $ do decode @Sum (encode (List ["\n", "hello\nworld", "plain"])) `shouldBe` Just (List ["\n", "hello\nworld", "plain"]) it "strings" $ do decode @Sum (encode (Str "")) `shouldBe` pure (Str "") decode @Sum (encode (Str " ")) `shouldBe` pure (Str " ") decode @Sum (encode (Str "_")) `shouldBe` pure (Str "_") decode @Sum (encode (Str "~")) `shouldBe` pure (Str "~") decode @Sum (encode (Str "+")) `shouldBe` pure (Str "+") decode @Sum (encode (Str "hello world")) `shouldBe` pure (Str "hello world") decode @Sum (encode (Str "hello_world")) `shouldBe` pure (Str "hello_world") ================================================ FILE: test/Test/FormSpec.hs ================================================ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedLists #-} module Test.FormSpec where import Data.Text (Text) import Skeletest import Web.Hyperbole.HyperView.Forms data Example f = Example { message :: Field f Text , age :: Field f Int , whatever :: Field f (Maybe Float) , maybeMessage :: Field f (Maybe Text) } deriving (Generic, FromFormF, GenFields Maybe) instance Show (Example Identity) where show (Example m a w mm) = "Example " <> show m <> " " <> show a <> " " <> show w <> " " <> show mm instance Eq (Example Identity) where Example m a w mm == Example m2 a2 w2 mm2 = m == m2 && a == a2 && w == w2 && mm == mm2 data Flags = Flags { a :: Bool , b :: Bool } deriving (Generic, FromForm, Show, Eq) data Todo = Todo {msg :: Text} deriving (Generic, FromForm, Show, Eq) spec :: Spec spec = withMarkers ["param"] $ do describe "forms" $ do it "should parse a form" $ do case fromForm @(Example Identity) [("message", "hello"), ("age", "23"), ("whatever", "")] of Left e -> fail $ show e Right a -> do a.message `shouldBe` "hello" a.age `shouldBe` 23 a.whatever `shouldBe` Nothing it "should parse a form with a number for the text" $ do let res = fromForm @(Example Identity) [("message", "30"), ("age", "0"), ("whatever", "2"), ("maybeMessage", "hello")] res `shouldBe` Right (Example "30" 0 (Just 2) (Just "hello")) it "parses missing Maybes" $ do let res = fromForm @(Example Identity) [("message", "30"), ("age", "0")] res `shouldBe` Right (Example "30" 0 Nothing Nothing) it "parses Maybe Text empty string" $ do let res = fromForm @(Example Identity) [("message", "30"), ("age", "0"), ("maybeMessage", "")] res `shouldBe` Right (Example "30" 0 Nothing (Just "")) it "parses weird" $ do fromForm @Flags [("a", "true"), ("b", "off")] `shouldBe` Right (Flags True False) fromForm @Flags [("a", "on"), ("b", "false")] `shouldBe` Right (Flags True False) fromForm @Flags [("a", "on")] `shouldBe` Right (Flags True False) it "parses missing bools as false" $ do fromForm @Flags [("a", "true")] `shouldBe` Right (Flags True False) it "parses underscores" $ do fromForm @Todo [("msg", "test")] `shouldBe` Right (Todo "test") fromForm @Todo [("msg", "hello world")] `shouldBe` Right (Todo "hello world") fromForm @Todo [("msg", "hello+world")] `shouldBe` Right (Todo "hello+world") fromForm @Todo [("msg", "hello_world")] `shouldBe` Right (Todo "hello_world") ================================================ FILE: test/Test/ParamSpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} module Test.ParamSpec where import Data.Aeson import Data.String.Conversions (cs) import Data.Text (Text) import GHC.Generics import Skeletest import Web.Hyperbole.Data.Param spec :: Spec spec = withMarkers ["param"] $ do describe "param" paramSpec data Record = Record { age :: Int , msg :: Text } deriving (Generic, ToJSON, FromJSON, ToParam, FromParam, Eq) data Tag = A | B deriving (Generic, ToParam, FromParam, Eq, Show) data Tag2 = C | Tag Text deriving (Generic, ToParam, FromParam, Eq, Show) instance ToJSON Tag2 where toJSON = genericToJSON jsonOptions paramSpec :: Spec paramSpec = do describe "ToParam" $ do it "should encode basics" $ do toParam @Text "hello" `shouldBe` "hello" toParam @Int 23 `shouldBe` ParamValue "23" it "should encode Maybe" $ do toParam @(Maybe Int) Nothing `shouldBe` ParamValue "~" toParam @(Maybe Int) (Just 23) `shouldBe` ParamValue "23" it "encodes simple constructors" $ do toParam A `shouldBe` ParamValue "A" toParam B `shouldBe` ParamValue "B" it "encodes complex constructors as json" $ do toParam C `shouldBe` jsonParam C toParam (Tag "hello world") `shouldBe` jsonParam (Tag "hello world") -- it "should encode lists with spaces = plusses" $ do -- toParam @[Int] [1, 2, 3] `shouldBe` ParamValue ("1+2+3") -- toParam @[Text] ["one", "two"] `shouldBe` ParamValue ("one+two") -- toParam @[Text] ["hello world", "friend"] `shouldBe` ParamValue ("hello%20world+friend") it "should not escape text" $ do toParam @Text "hello world" `shouldBe` ParamValue "hello world" toParam @Text "hello_world" `shouldBe` ParamValue "hello_world" toParam @Text "hello+world" `shouldBe` ParamValue "hello+world" it "encodes json" $ do let r = Record 10 "hello world" toParam r `shouldBe` jsonParam (toJSON r) let r2 = Record 10 "hello_world" toParam r2 `shouldBe` jsonParam (toJSON r2) toParam r2 `shouldBe` ParamValue (cs (encode r2)) describe "FromParam" $ do it "should parse basics" $ do parseParam @Text "hello" `shouldBe` Right "hello" parseParam @Int "3" `shouldBe` Right 3 it "decodes json" $ do let r2 = Record 10 "hello_world" parseParam (jsonParam r2) `shouldBe` Right r2 parseParam (ParamValue $ cs $ encode r2) `shouldBe` Right r2 it "can decode numbers as text" $ do parseParam @Text "3" `shouldBe` Right "3" it "should not escape text" $ do parseParam @Text "hello world" `shouldBe` Right "hello world" parseParam @Text "hello_world" `shouldBe` Right "hello_world" parseParam @Text "hello+world" `shouldBe` Right "hello+world" describe "RoundTrip" $ do it "round trips constructors" $ do parseParam (toParam A) `shouldBe` Right A parseParam (toParam B) `shouldBe` Right B parseParam (toParam C) `shouldBe` Right C let t = Tag "woo hoo" parseParam (toParam t) `shouldBe` Right t ================================================ FILE: test/Test/QuerySpec.hs ================================================ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} module Test.QuerySpec where import Data.Function ((&)) import Data.Text (Text) import Skeletest import Skeletest.Predicate qualified as P import Web.Hyperbole hiding (Number) import Web.Hyperbole.Data.QueryData as QueryData spec :: Spec spec = withMarkers ["param"] $ do describe "render" renderSpec describe "class" classSpec describe "multi" multiSpec data Woot = Woot Text deriving (Generic, Show) data Record = Record { age :: Int , msg :: Text } deriving (Generic, ToJSON, FromJSON, ToParam, FromParam, Eq, FromQuery, ToQuery) classSpec :: Spec classSpec = do describe "FromQuery" $ do it "decodes record" $ do let qd = QueryData.parse "age=20&msg=hello_world" parseQuery @Record qd `shouldSatisfy` P.right P.anything it "decodes numbers as text if needed" $ do let qd = QueryData.parse "age=20&msg=30" parseQuery @Record qd `shouldBe` Right (Record 20 "30") describe "ToQuery" $ do it "encodes record" $ do let r = Record 20 "hello world" QueryData.render (toQuery r) `shouldBe` "age=20&msg=hello_world" describe "roundtrip" $ do it "round trips" $ do let r = Record 20 "hello world" parseQuery (toQuery r) `shouldBe` Right r renderSpec :: Spec renderSpec = do it "should parse multiple items" $ do let qd = parse "msg=hello&age=1" require @Text "msg" qd `shouldBe` Right "hello" require @Int "age" qd `shouldBe` Right 1 it "should render as a querystring" $ do let q = mempty & QueryData.insert @Text "msg" "value" & QueryData.insert @Int "age" 1 QueryData.render q `shouldBe` "age=1&msg=value" it "should escape special characters in strings" $ do let q = mempty & QueryData.insert @Text "msg" "bob&henry=fast" QueryData.render q `shouldBe` "msg=bob%26henry%3Dfast" -- it "handles underscores" $ do -- QueryData.render [(Param "msg", ParamValue "hello_world" $ String "hello_world")] `shouldBe` "msg=hello%5C_world" -- QueryData.render [(Param "msg", ParamValue "hello world" $ String "hello world")] `shouldBe` "msg=hello_world" it "should roundtrip special characters" $ do let msg = "bob&henry=fast" let q = mempty & QueryData.insert @Text "msg" msg let out = QueryData.render q let q' = QueryData.parse out QueryData.lookup "msg" q' `shouldBe` Just msg -- it "should preserve plusses" $ do -- let QueryData q = QueryData $ M.fromList [("items", "one+two")] -- print $ HTTP.toQuery $ M.toList q -- QueryData.render (QueryData q) `shouldBe` "items=one+two" data Filters = Filters { term :: Text , isActive :: Bool , another :: Maybe Text } deriving (Eq, Show) instance ToQuery Filters where toQuery f = mempty & QueryData.insert "term" f.term & QueryData.insert "isActive" f.isActive & QueryData.insert "another" f.another instance FromQuery Filters where parseQuery q = do term <- QueryData.require "term" q isActive <- QueryData.require "isActive" q another <- QueryData.require "another" q pure Filters{..} data Filters' = Filters' { term :: Text , isActive :: Bool } deriving (Generic, Eq, ToJSON, FromJSON, FromParam, ToParam) instance Default Filters' where def = Filters' "" False data Nested = Nested { filters :: Filters' } deriving (Generic, ToQuery, FromQuery) -- instance ToQuery Nested where -- toQuery n = -- mempty & QueryData.insert "filters" (JSON n.filters) -- -- -- instance FromQuery Nested where -- parseQuery q = -- mempty & QueryData.insert "filters" (JSON n.filters) multiSpec :: Spec multiSpec = do describe "Roundtrip" $ do it "should parse from querydata" $ do let f = Filters "hello world" False Nothing let out = QueryData.render (toQuery f) let q = QueryData.parse out parseQuery q `shouldBe` Right f it "should work with Just" $ do let f = Filters "hello_world" False (Just "hello") let out = QueryData.render (toQuery f) let q = QueryData.parse out parseQuery q `shouldBe` Right f ================================================ FILE: test/Test/RouteSpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} module Test.RouteSpec where import Data.Text (Text) import GHC.Generics import Skeletest import Web.Hyperbole.Route data Routes = MainPage | Hello Hello | Goodbye deriving (Show, Generic, Eq) instance Route Routes where baseRoute = Just MainPage data Hello = MainHello | World | Message String deriving (Show, Generic, Eq) instance Route Hello where baseRoute = Just MainHello data NoMain = NoMain Nested deriving (Show, Generic, Eq, Route) data Nested = Something | Nested Text deriving (Show, Generic, Eq, Route) spec :: Spec spec = do describe "Route" $ do describe "routePath" $ do it "basic" $ routePath Goodbye `shouldBe` ["goodbye"] it "default" $ routePath MainPage `shouldBe` [] it "dynamic" $ routePath (Hello (Message "woot")) `shouldBe` ["hello", "message", "woot"] it "compound" $ routePath (Hello World) `shouldBe` ["hello", "world"] it "compound default" $ routePath (Hello MainHello) `shouldBe` ["hello"] it "constructors with parameters should use full url" $ routePath (NoMain (Nested "woot")) `shouldBe` ["nomain", "nested", "woot"] it "no main should use full url" $ routePath (NoMain Something) `shouldBe` ["nomain", "something"] describe "matchRoute" $ do it "basic" $ matchRoute ["goodbye"] `shouldBe` Just Goodbye -- it "default empty string" $ matchRoute [""] `shouldBe` Just MainPage it "default empty" $ matchRoute [] `shouldBe` Just MainPage it "compound" $ matchRoute ["hello", "world"] `shouldBe` Just (Hello World) it "compound default" $ matchRoute ["hello"] `shouldBe` Just (Hello MainHello) it "compound dynamic" $ matchRoute ["hello", "message", "whatever"] `shouldBe` Just (Hello (Message "whatever")) it "no base compound" $ matchRoute ["nomain", "nested", "hello"] `shouldBe` Just (NoMain (Nested "hello")) describe "baseRoute" $ do it "default" $ baseRoute `shouldBe` Just MainPage it "compound" $ (baseRoute @Hello) `shouldBe` Just MainHello it "none" $ (baseRoute @Nested) `shouldBe` Nothing ================================================ FILE: test/Test/SessionSpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} module Test.SessionSpec where import Data.String.Conversions (cs) import Data.Text (Text) import Network.HTTP.Types (urlEncode) import Skeletest import Web.Hyperbole import Web.Hyperbole.Data.Cookie as Cookie import Web.Hyperbole.Data.Encoded qualified as Encoded import Web.Hyperbole.Data.URI import Web.Hyperbole.Effect.Session (sessionCookie) -- import Skeletest.Predicate qualified as P data Woot = Woot Text deriving (Generic, Show, ToEncoded, FromEncoded) instance Session Woot where cookiePath = Just $ Path ["somepage"] data InsecureSession = InsecureSession Text deriving (Generic, Show, ToEncoded, FromEncoded) instance Session InsecureSession where cookieSecure = False spec :: Spec spec = do describe "Session" $ do it "should encode cookie" $ do let woot = Woot "hello" toCookie woot `shouldBe` CookieValue (cs $ Encoded.encode woot) describe "sessionCookie" $ do it "should create cookie" $ do let woot = Woot "hello" sessionCookie woot `shouldBe` Cookie (sessionKey @Woot) (cookiePath @Woot) (Just (toCookie woot)) (cookieSecure @Woot) describe "render" $ do it "should parse cookies" $ do Cookie.parse [("Woot", "Woot")] `shouldBe` Right (Cookie.fromList [Cookie "Woot" Nothing (Just (CookieValue "Woot")) True]) it "should render cookie with root path" $ do let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot")) True Cookie.render [] cookie `shouldBe` "Woot=Woot; SameSite=None; secure; path=/" it "should render non-secure cookie" $ do let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot")) False Cookie.render [] cookie `shouldBe` "Woot=Woot; SameSite=Lax; path=/" it "should render complex cookie with included path" $ do let woot = Woot "hello world" let cookie = sessionCookie woot Cookie.render [] cookie `shouldBe` "Woot=" <> urlEncode True (cs $ Encoded.encode woot) <> "; SameSite=None; secure; path=/somepage" describe "Session class" $ do it "should encode class" $ do let prefs = Preferences "hello" Warning let cooks = Cookie.insert (sessionCookie prefs) mempty Cookie.lookup (sessionKey @Preferences) cooks `shouldBe` Just (CookieValue $ cs $ Encoded.encode prefs) it "should decode class" $ do let prefs = Preferences "hello" Warning let cooks = Cookie.insert (sessionCookie prefs) mempty Just val <- pure $ Cookie.lookup (sessionKey @Preferences) cooks parseCookie val `shouldBe` Right prefs it "should create non-secure cookie when cookieSecure is False" $ do let insecure = InsecureSession "test" let cookie = sessionCookie insecure cookie.secure `shouldBe` False data Preferences = Preferences { message :: Text , color :: AppColor } deriving (Generic, Eq, Show, ToEncoded, FromEncoded, Session) instance Default Preferences where def = Preferences "_" White data AppColor = White | Light | GrayLight | GrayDark | Dark | DarkHighlight | Success | Danger | Warning | Primary | PrimaryLight | Secondary | SecondaryLight deriving (Show, Eq, Generic, ToParam, FromParam) ================================================ FILE: test/Test/URISpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} module Test.URISpec where import Skeletest import Web.Hyperbole import Web.Hyperbole.Data.URI spec :: Spec spec = do describe "URI" $ do it "should preserve slashes" $ do let u = [uri|http://example.com|] ./. "hello" u.uriPath `shouldBe` "/hello" it "should render with path slashes" $ do let u = [uri|http://example.com/test|] uriToText (u ./. ["wahoo"]) `shouldBe` "http://example.com/test/wahoo" uriToText (u ./. ["/wahoo"]) `shouldBe` "http://example.com/test/wahoo" uriToText (u ./. []) `shouldBe` "http://example.com/test" uriToText (u ./. "/") `shouldBe` "http://example.com/test" describe "Path" $ do it "handles edge cases" $ do path "" `shouldBe` [] path "/" `shouldBe` [] it "normal paths" $ do path "woot" `shouldBe` ["woot"] path "woot/hello" `shouldBe` ["woot", "hello"] path "/woot/hello" `shouldBe` ["woot", "hello"] path "/woot/hello/" `shouldBe` ["woot", "hello"] ================================================ FILE: test/Test/ViewActionSpec.hs ================================================ module Test.ViewActionSpec where import Data.Text (Text) import GHC.Generics import Skeletest import Skeletest.Predicate qualified as P import Web.Hyperbole (FromJSON, ToJSON) import Web.Hyperbole.Data.Encoded import Web.Hyperbole.Data.Param import Web.Hyperbole.View import Web.Hyperbole.HyperView.Event (toActionInput) data Simple = Simple deriving (Generic, Eq, Show, Read, ViewAction, ToJSON, FromJSON, ToParam, FromParam) data Product = Product String Int deriving (Generic, Show, Eq, ViewAction, Read, ToJSON, FromJSON, ToEncoded, FromEncoded, ToParam, FromParam) data Product' = Product' HasText Int deriving (Generic, Show, Eq, ViewAction, Read, ToJSON, FromJSON, ToEncoded, FromEncoded) data Sum = SumA | SumB Int | SubC Text | SubD (Maybe Text) | SubE Term | SubF Simple deriving (Generic, Show, Read, Eq, ViewAction) data Compound = Compound Product deriving (Generic, Show, Eq, Read, ToJSON, FromEncoded, ToEncoded, FromJSON, ViewAction) data HasText = HasText Text deriving (Generic, Show, Eq, Read, ViewAction, ToJSON, FromJSON, FromEncoded, ToEncoded, ToParam, FromParam) newtype Term = Term Text deriving newtype (Eq, Show, ToJSON, FromJSON, Read, ToParam, FromParam) spec :: Spec spec = withMarkers ["encoded"] $ do describe "ViewAction" $ do describe "toAction" $ do it "simple" $ toAction Simple `shouldBe` Encoded "Simple" [] it "has text" $ toAction (HasText "hello world") `shouldBe` Encoded "HasText" ["hello world"] it "product" $ toAction (Product "hello world" 123) `shouldBe` Encoded "Product" ["hello world", toParam @Int 123] it "sum" $ toAction (SumB 123) `shouldBe` Encoded "SumB" [toParam @Int 123] it "compound" $ do let p = Product "hello world" 123 toAction (Compound p) `shouldBe` Encoded "Compound" [toParam p] describe "toActionInput" $ do it "Constructor Text" $ do toActionInput SubC `shouldBe` Encoded "SubC" [] it "Constructor (Maybe Text)" $ do toActionInput (SubD . Just) `shouldBe` Encoded "SubD" [] it "Constructor newtype Term" $ do toActionInput (SubE . Term) `shouldBe` Encoded "SubE" [] it "renders data constructors" $ do toActionInput SubF `shouldBe` Encoded "SubF" [] describe "parseAction" $ do it "simple" $ parseAction (Encoded "Simple" []) `shouldBe` pure Simple it "parse product" $ do parseAction @Product (Encoded "Product" ["woot", toParam @Int 1234]) `shouldSatisfy` P.right P.anything it "parse product with spaces" $ do parseAction @Product (Encoded "Product" ["hello world", toParam @Int 1234]) `shouldSatisfy` P.right P.anything describe "roundTrip" $ do it "simple" $ do parseAction (toAction Simple) `shouldBe` pure Simple it "has text multiple words" $ do let a = HasText "hello world" parseAction (toAction a) `shouldBe` pure a it "product" $ do let a = Product "hello world" 123 parseAction @Product (toAction a) `shouldBe` pure a it "product'" $ do let a = Product' (HasText "hello world") 123 parseAction (toAction a) `shouldBe` pure a it "compound" $ do let a = Compound (Product "hello world" 123) parseAction (toAction a) `shouldBe` pure a it "sum" $ do let a = SumB 123 parseAction (toAction a) `shouldBe` pure a ================================================ FILE: test/Test/ViewIdSpec.hs ================================================ {-# LANGUAGE OverloadedLists #-} module Test.ViewIdSpec where import Data.Text (Text) import Data.Text qualified as T import GHC.Generics import Skeletest import Web.Hyperbole import Web.Hyperbole.Data.Encoded data Thing = Thing deriving (Generic, Show, Eq, ToJSON, FromJSON, ToEncoded, FromEncoded, ViewId, ToParam, FromParam) data Custom = Custom deriving (Show, Eq) data HasString = HasString String deriving (Generic, Show, Eq, Read, ViewId) data Compound = One | Two Thing | WithId (Id Thing) | Compound Text Compound deriving (Generic, Show, Eq, ToJSON, FromJSON, ToEncoded, FromEncoded, ViewId, ToParam, FromParam) data Product4 = Product4 Text Text Text Text deriving (Generic, Show, Eq, Read, ViewId) -- Regression test for https://github.com/seanhess/hyperbole/issues/187 data MessageView = MessageView [Text] deriving (Generic, Show, Eq, ViewId) newtype Id a = Id {fromId :: Text} deriving newtype (Eq, ToJSON, FromJSON, Ord, Show, ToParam, FromParam) deriving (Generic) instance ViewId Custom where toViewId Custom = Encoded "something" [] parseViewId (Encoded "something" []) = pure Custom parseViewId _ = Left "NOPE" spec :: Spec spec = withMarkers ["encoded"] $ do describe "ViewId Encoded" $ do describe "toViewId" $ do it "basic" $ encodeViewId Thing `shouldBe` "Thing" it "custom" $ encodeViewId Custom `shouldBe` "something" describe "parseViewId" $ do it "basic lowercase" $ decodeViewId @Thing "thing" `shouldBe` Nothing it "basic" $ decodeViewId @Thing "Thing" `shouldBe` pure Thing it "custom" $ decodeViewId @Custom "something" `shouldBe` pure Custom it "custom other" $ decodeViewId @Thing "custom" `shouldBe` Nothing describe "has-string" $ do it "should not contain single quotes" $ do encodeViewId (HasString "woot") `shouldBe` "HasString woot" containsSingleQuotes (encodeViewId (HasString "woot")) `shouldBe` False it "should roundtrip" $ do let inp = HasString "woot" decodeViewId (encodeViewId inp) `shouldBe` pure inp describe "compound" $ do it "double roundtrip" $ decodeViewId (encodeViewId (Two Thing)) `shouldBe` pure (Two Thing) describe "nested" $ do let nest = Compound "one" $ Compound "two" (Two Thing) it "should roundtrip" $ decodeViewId (encodeViewId nest) `shouldBe` pure nest describe "big product" $ do let p = Product4 "one" "two" "three" "four" it "should roundtrip" $ do let vid = encodeViewId p decodeViewId vid `shouldBe` pure p -- Regression tests for https://github.com/seanhess/hyperbole/issues/187 -- When a ViewId contains a list of Text with newline characters, the -- encoded/decoded form must round-trip correctly. describe "list with newline (issue #187)" $ do it "roundtrips MessageView with single newline" $ do let v = MessageView ["\n"] decodeViewId (encodeViewId v) `shouldBe` pure v it "roundtrips MessageView with newlines in multiple elements" $ do let v = MessageView ["\n", "hello\nworld", "plain"] decodeViewId (encodeViewId v) `shouldBe` pure v -- describe "Param Attributes" $ do -- it "should serialize basic id" $ do -- let atts = mempty :: Attributes id -- (setId "woot" atts).other `shouldBe` [("id", "woot")] -- -- it "should serialize compound id" $ do -- let atts = mempty :: Attributes id -- (setId (toViewId $ Two Thing) atts).other `shouldBe` [("id", toViewId $ Two Thing)] -- -- it "should serialize stringy id" $ do -- let atts = mempty :: Attributes id -- (setId (toViewId $ HasString "woot") atts).other `shouldBe` [("id", pack $ show $ HasString "woot")] -- -- it "should serialize with Id" $ do -- let atts = mempty :: Attributes id -- (setId (toViewId $ WithId (Id "woot")) atts).other `shouldBe` [("id", "WithId \"woot\"")] containsSingleQuotes :: Text -> Bool containsSingleQuotes = T.elem '\'' -- setId :: Text -> Mod id -- setId = att "id" ================================================ FILE: test/Test/ViewSpec.hs ================================================ module Test.ViewSpec where import Skeletest import Web.Hyperbole spec :: Spec spec = do describe "View" $ do describe "monad" $ do it "renders all nodes with do" $ do let v = do el "one" el "two" renderText v `shouldBe` "
one
\n
two
" it "renders all nodes with >>" $ do let v = el "one" >> el "two" renderText v `shouldBe` "
one
\n
two
" it "renders all nodes with >>=" $ do let v = el "one" >>= \_ -> el "two" renderText v `shouldBe` "
one
\n
two
"