From d98db8f077ed0394cb7a70a2c32a276f5cb9f2a0 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 12 Nov 2024 12:05:16 +0000 Subject: [PATCH] Initial commit Initial commit of ghc-wasm-reflex-examples forked from ghc-wasm-miso-examples. Co-authored-by: Cheng Shao --- .github/workflows/build.yml | 108 +++++++++ .gitignore | 1 + LICENSE | 21 ++ README.md | 62 ++++++ app/App.hs | 11 + app/Main.hs | 10 + cabal.project | 33 +++ flake.lock | 81 +++++++ flake.nix | 15 ++ frontend/.gitignore | 3 + frontend/build.sh | 45 ++++ frontend/index.js | 22 ++ frontend/reflex-todomvc.html | 12 + ghc-wasm-reflex-examples.cabal | 19 ++ reflex-todomvc/reflex-todomvc.cabal | 25 +++ reflex-todomvc/src/Reflex/TodoMVC.hs | 322 +++++++++++++++++++++++++++ 16 files changed, 790 insertions(+) create mode 100644 .github/workflows/build.yml create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 app/App.hs create mode 100644 app/Main.hs create mode 100644 cabal.project create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 frontend/.gitignore create mode 100755 frontend/build.sh create mode 100644 frontend/index.js create mode 100644 frontend/reflex-todomvc.html create mode 100644 ghc-wasm-reflex-examples.cabal create mode 100644 reflex-todomvc/reflex-todomvc.cabal create mode 100644 reflex-todomvc/src/Reflex/TodoMVC.hs diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 0000000..e12bf3d --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,108 @@ +name: build + +on: + merge_group: + pull_request: + push: + branches: + - main + workflow_dispatch: + +jobs: + nix-build: + name: nix-build + runs-on: ubuntu-latest + steps: + + - name: checkout + uses: actions/checkout@v4 + + - name: install-nix + uses: DeterminateSystems/nix-installer-action@v15 + + - name: build-frontend + run: | + nix develop --command bash -c "cd frontend && wasm32-wasi-cabal update && exec ./build.sh --debuginfo --low-memory-unused --converge --gufa --flatten --rereloop -Oz" + + ghcup-build: + name: ghcup-build + runs-on: ubuntu-latest + steps: + + - name: install-happy + run: | + cabal path --installdir >> "$GITHUB_PATH" + cabal update -z + cabal install -z happy + + - name: checkout + uses: actions/checkout@v4 + + - name: ghc-wasm-meta + run: | + pushd "$(mktemp -d)" + curl -f -L --retry 5 https://gitlab.haskell.org/ghc/ghc-wasm-meta/-/archive/master/ghc-wasm-meta-master.tar.gz | tar xz --strip-components=1 + SKIP_GHC=1 ./setup.sh + ~/.ghc-wasm/add_to_github_path.sh + popd + + - name: cabal + run: | + ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-prereleases-0.0.8.yaml + ghcup install cabal --set 3.15.0.0.2024.10.3 + + - name: wasm32-wasi-ghc + run: | + ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-cross-0.0.8.yaml + ghcup install ghc --set wasm32-wasi-9.10.1.20241021 -- $CONFIGURE_ARGS + + - name: build-frontend + run: | + cd frontend + cabal \ + --with-compiler=wasm32-wasi-ghc \ + --with-hc-pkg=wasm32-wasi-ghc-pkg \ + --with-hsc2hs=wasm32-wasi-hsc2hs \ + update + ./build.sh --debuginfo --low-memory-unused --converge --gufa --flatten --rereloop -Oz + + non-nix-build: + name: non-nix-build + runs-on: ubuntu-latest + permissions: + pages: write + id-token: write + steps: + + - name: install-happy + run: | + cabal path --installdir >> "$GITHUB_PATH" + cabal update -z + cabal install -z happy + + - name: checkout + uses: actions/checkout@v4 + + - name: ghc-wasm-meta + run: | + pushd "$(mktemp -d)" + curl -f -L --retry 5 https://gitlab.haskell.org/ghc/ghc-wasm-meta/-/archive/master/ghc-wasm-meta-master.tar.gz | tar xz --strip-components=1 + ./setup.sh + ~/.ghc-wasm/add_to_github_path.sh + popd + env: + FLAVOUR: '9.10' + + - name: build-frontend + run: | + cd frontend + ./build.sh --debuginfo --low-memory-unused --converge --gufa --flatten --rereloop -Oz + + - name: upload-pages-artifact + uses: actions/upload-pages-artifact@v3 + with: + path: frontend/dist + retention-days: 90 + + - name: deploy-pages + uses: actions/deploy-pages@v4 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..a3d114c --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) Tweag I/O Limited. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..7ab7472 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ +# `ghc-wasm-reflex-examples` + +[![Chat on Matrix](https://matrix.to/img/matrix-badge.svg)](https://matrix.to/#/#haskell-wasm:matrix.terrorjack.com) + +The GHC wasm backend supports the +[JSFFI](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/wasm.html#javascript-ffi-in-the-wasm-backend) +feature, allowing Haskell wasm apps to interop with JavaScript +seamlessly in the browser. This repo contains an example to +demonstrate this ability based on the +[`reflex`](https://reflex-frp.org/) frontend framework as well as an +experimental [`jsaddle-wasm`](https://github.com/amesgen/jsaddle-wasm) +library under the hood. + +See also: +[`ghc-wasm-miso-examples`](https://github.com/tweag/ghc-wasm-miso-examples) + +## Live demo + +- [reflex-todomvc](https://tweag.github.io/ghc-wasm-reflex-examples/reflex-todomvc.html) + +## Building + +### With nix + +Within the `nix develop` shell: + +```sh +cd frontend +wasm32-wasi-cabal update +./build.sh +``` + +If you pass additional arguments to `build.sh`, they will be +redirected to `wasm-opt`, otherwise a dev build without `wasm-opt` +will be performed. + +The artifacts will be available in `frontend/dist`. + +### Without nix + +You can set up the toolchain by either: + +- Using + [`ghc-wasm-meta`](https://gitlab.haskell.org/ghc/ghc-wasm-meta#getting-started-without-nix) + directly to set up ghc 9.10 +- Using [`ghcup`](https://www.haskell.org/ghcup/guide/#cross-support) + to set up ghc 9.10 (9.10.1.20241021 or later, with TemplateHaskell + support) and cabal >=3.14. + +Then: + +```sh +source ~/.ghc-wasm/env +cd frontend +./build.sh +``` + +## Acknowledgements + +The examples are vendored and modified from the following projects: + +- reflex-todomvc: based on https://github.com/reflex-frp/reflex-todomvc diff --git a/app/App.hs b/app/App.hs new file mode 100644 index 0000000..d07f92e --- /dev/null +++ b/app/App.hs @@ -0,0 +1,11 @@ +module App (start) where + +import GHC.Wasm.Prim +import Language.Javascript.JSaddle (JSM) +import Reflex.TodoMVC qualified + +start :: JSString -> JSM () +start e = + case fromJSString e of + "reflex-todomvc" -> Reflex.TodoMVC.main + _ -> fail "unknown example" diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..3f1a49c --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,10 @@ +module MyMain (main) where + +import App (start) +import GHC.Wasm.Prim +import Language.Javascript.JSaddle.Wasm qualified as JSaddle.Wasm + +foreign export javascript "hs_start" main :: JSString -> IO () + +main :: JSString -> IO () +main e = JSaddle.Wasm.run $ start e diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..fc31946 --- /dev/null +++ b/cabal.project @@ -0,0 +1,33 @@ +packages: . reflex-todomvc + +index-state: 2024-11-11T12:54:21Z + +if arch(wasm32) + -- Required for TemplateHaskell. When using wasm32-wasi-cabal from + -- ghc-wasm-meta, this is superseded by the global cabal.config. + shared: True + + -- https://github.com/haskellari/time-compat/issues/37 + -- Older versions of time don't build on WASM. + constraints: time installed + allow-newer: time + + -- https://github.com/haskellari/splitmix/pull/73 + source-repository-package + type: git + location: https://github.com/amesgen/splitmix + tag: 5f5b766d97dc735ac228215d240a3bb90bc2ff75 + +package aeson + flags: -ordered-keymap + +-- for reflex-frp + +-- GHC 9.10 compat +source-repository-package + type: git + location: https://github.com/amesgen/reflex-dom + tag: e43e0525d643f656a0a5b0f10e13e2a04712cd4e + subdir: reflex-dom-core + +allow-newer: dependent-sum-template:template-haskell diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..b585a4b --- /dev/null +++ b/flake.lock @@ -0,0 +1,81 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1726560853, + "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-wasm-meta": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + }, + "locked": { + "host": "gitlab.haskell.org", + "lastModified": 1731323753, + "narHash": "sha256-K6uBL4TVGHl9bknKdEAevBUXmkaimNXc8H4yaB2CBBk=", + "owner": "ghc", + "repo": "ghc-wasm-meta", + "rev": "94337065008e8892f0188be0e636cc4b5aa4652d", + "type": "gitlab" + }, + "original": { + "host": "gitlab.haskell.org", + "owner": "ghc", + "repo": "ghc-wasm-meta", + "type": "gitlab" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1731139594, + "narHash": "sha256-IigrKK3vYRpUu+HEjPL/phrfh7Ox881er1UEsZvw9Q4=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "76612b17c0ce71689921ca12d9ffdc9c23ce40b2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "ghc-wasm-meta": "ghc-wasm-meta" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..658e856 --- /dev/null +++ b/flake.nix @@ -0,0 +1,15 @@ +{ + inputs = { + ghc-wasm-meta.url = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org"; + }; + outputs = inputs: inputs.ghc-wasm-meta.inputs.flake-utils.lib.eachDefaultSystem (system: + let pkgs = inputs.ghc-wasm-meta.inputs.nixpkgs.legacyPackages.${system}; + in + { + devShells.default = pkgs.mkShell { + packages = [ + inputs.ghc-wasm-meta.packages.${system}.all_9_10 + ]; + }; + }); +} diff --git a/frontend/.gitignore b/frontend/.gitignore new file mode 100644 index 0000000..2d89aca --- /dev/null +++ b/frontend/.gitignore @@ -0,0 +1,3 @@ +node_modules/ +dist/ +ghc_wasm_jsffi.js diff --git a/frontend/build.sh b/frontend/build.sh new file mode 100755 index 0000000..19d47cb --- /dev/null +++ b/frontend/build.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash + +set -e + +if [[ $PWD != */frontend ]]; then + echo "This script is meant to be run in the frontend directory" + exit 1 +fi + +if [ $# -eq 0 ]; then + echo "Building for dev" + dev_mode=true +else + echo "Building for prod" + dev_mode=false +fi + +rm -rf dist +mkdir dist +cp ./*.html dist/ + +if command -v wasm32-wasi-cabal &>/dev/null; then + wasm32-wasi-cabal build ghc-wasm-reflex-examples +else + cabal \ + --with-compiler=wasm32-wasi-ghc \ + --with-hc-pkg=wasm32-wasi-ghc-pkg \ + --with-hsc2hs=wasm32-wasi-hsc2hs \ + build ghc-wasm-reflex-examples +fi + +hs_wasm_path=$(find .. -name "*.wasm") + +"$(wasm32-wasi-ghc --print-libdir)"/post-link.mjs \ + --input "$hs_wasm_path" --output ghc_wasm_jsffi.js + +if $dev_mode; then + cp "$hs_wasm_path" dist/bin.wasm +else + wizer --allow-wasi --wasm-bulk-memory true --init-func _initialize -o dist/bin.wasm "$hs_wasm_path" + wasm-opt ${1+"$@"} dist/bin.wasm -o dist/bin.wasm + wasm-tools strip -o dist/bin.wasm dist/bin.wasm +fi + +cp ./*.js dist diff --git a/frontend/index.js b/frontend/index.js new file mode 100644 index 0000000..1d5605b --- /dev/null +++ b/frontend/index.js @@ -0,0 +1,22 @@ +import { WASI, OpenFile, File, ConsoleStdout } from "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.3.0/dist/index.js"; +import ghc_wasm_jsffi from "./ghc_wasm_jsffi.js"; + +const args = []; +const env = []; +const fds = [ + new OpenFile(new File([])), // stdin + ConsoleStdout.lineBuffered((msg) => console.log(`[WASI stdout] ${msg}`)), + ConsoleStdout.lineBuffered((msg) => console.warn(`[WASI stderr] ${msg}`)), +]; +const options = { debug: false }; +const wasi = new WASI(args, env, fds, options); + +const instance_exports = {}; +const { instance } = await WebAssembly.instantiateStreaming(fetch("bin.wasm"), { + wasi_snapshot_preview1: wasi.wasiImport, + ghc_wasm_jsffi: ghc_wasm_jsffi(instance_exports), +}); +Object.assign(instance_exports, instance.exports); + +wasi.initialize(instance); +await instance.exports.hs_start(globalThis.example); diff --git a/frontend/reflex-todomvc.html b/frontend/reflex-todomvc.html new file mode 100644 index 0000000..fcfeb2b --- /dev/null +++ b/frontend/reflex-todomvc.html @@ -0,0 +1,12 @@ + + + + + + TodoMVC | Reflex FRP example via GHC WASM + + + + + + diff --git a/ghc-wasm-reflex-examples.cabal b/ghc-wasm-reflex-examples.cabal new file mode 100644 index 0000000..6cae952 --- /dev/null +++ b/ghc-wasm-reflex-examples.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.0 +name: ghc-wasm-reflex-examples +version: 0 + +executable ghc-wasm-reflex-examples + main-is: Main.hs + build-depends: + , base + , ghc-experimental + , jsaddle + , jsaddle-wasm + , reflex-todomvc + hs-source-dirs: app + default-language: GHC2021 + default-extensions: BlockArguments LambdaCase LexicalNegation OverloadedStrings RecordWildCards + ghc-options: -Wall -Wunused-packages -Wno-name-shadowing -Wredundant-constraints + other-modules: + App + ghc-options: -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" diff --git a/reflex-todomvc/reflex-todomvc.cabal b/reflex-todomvc/reflex-todomvc.cabal new file mode 100644 index 0000000..139501f --- /dev/null +++ b/reflex-todomvc/reflex-todomvc.cabal @@ -0,0 +1,25 @@ +Cabal-version: 3.0 +Name: reflex-todomvc +Version: 0.1 +Synopsis: Functional Reactive TodoMVC +Description: An implementation of the TodoMVC specification using the Reflex-DOM functional reactive DOM library +License: BSD-3-Clause +License-file: LICENSE +Author: Ryan Trinkle +Maintainer: ryan.trinkle@gmail.com +Stability: Experimental +Category: FRP + +library + hs-source-dirs: src + build-depends: + base, + reflex, + ghcjs-dom == 0.9.*, + reflex-dom-core, + containers, + text, + mtl + exposed-modules: + Reflex.TodoMVC + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/reflex-todomvc/src/Reflex/TodoMVC.hs b/reflex-todomvc/src/Reflex/TodoMVC.hs new file mode 100644 index 0000000..3556574 --- /dev/null +++ b/reflex-todomvc/src/Reflex/TodoMVC.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Reflex.TodoMVC where + +import Prelude hiding (mapM, mapM_, sequence) + +import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence) +import Control.Monad.Fix +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Foldable +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import GHCJS.DOM.Types (JSM) + +import Reflex +import Reflex.Dom.Core + +-------------------------------------------------------------------------------- +-- Model +-------------------------------------------------------------------------------- + +data Task + = Task { taskDescription :: Text + , taskCompleted :: Bool + } + deriving (Show, Eq) + +-- | Add a new value to a map; automatically choose an unused key +insertNew_ :: (Enum k, Ord k) => v -> Map k v -> Map k v +insertNew_ v m = case Map.maxViewWithKey m of + Nothing -> Map.singleton (toEnum 0) v + Just ((k, _), _) -> Map.insert (succ k) v m + +initialTasks :: Map Int Task +initialTasks = Map.empty + +-------------------------------------------------------------------------------- +-- Filters +-------------------------------------------------------------------------------- + +-- | Subsets of the task list that can be selected by the user +data Filter + = All -- ^ All tasks + | Active -- ^ Uncompleted tasks + | Completed -- ^ Completed tasks + deriving (Show, Eq) + +-- | Determine whether this Task should be shown when this Filter is in effect +satisfiesFilter :: Filter -> Task -> Bool +satisfiesFilter f = case f of + All -> const True + Active -> not . taskCompleted + Completed -> taskCompleted + +-------------------------------------------------------------------------------- +-- View +-------------------------------------------------------------------------------- + +main :: JSM () +main = mainWidgetWithCss styleCss todoMVC + where + -- WASM backend is currently lacking TH + styleCss = T.encodeUtf8 "html,\nbody {\n\tmargin: 0;\n\tpadding: 0;\n}\n\nbutton {\n\tmargin: 0;\n\tpadding: 0;\n\tborder: 0;\n\tbackground: none;\n\tfont-size: 100%;\n\tvertical-align: baseline;\n\tfont-family: inherit;\n\tfont-weight: inherit;\n\tcolor: inherit;\n\t-webkit-appearance: none;\n\tappearance: none;\n\t-webkit-font-smoothing: antialiased;\n\t-moz-osx-font-smoothing: grayscale;\n}\n\nbody {\n\tfont: 14px 'Helvetica Neue', Helvetica, Arial, sans-serif;\n\tline-height: 1.4em;\n\tbackground: #f5f5f5;\n\tcolor: #111111;\n\tmin-width: 230px;\n\tmax-width: 550px;\n\tmargin: 0 auto;\n\t-webkit-font-smoothing: antialiased;\n\t-moz-osx-font-smoothing: grayscale;\n\tfont-weight: 300;\n}\n\n:focus {\n\toutline: 0;\n}\n\n.hidden {\n\tdisplay: none;\n}\n\n.todoapp {\n\tbackground: #fff;\n\tmargin: 130px 0 40px 0;\n\tposition: relative;\n\tbox-shadow: 0 2px 4px 0 rgba(0, 0, 0, 0.2),\n\t 0 25px 50px 0 rgba(0, 0, 0, 0.1);\n}\n\n.todoapp input::-webkit-input-placeholder {\n\tfont-style: italic;\n\tfont-weight: 300;\n\tcolor: rgba(0, 0, 0, 0.4);\n}\n\n.todoapp input::-moz-placeholder {\n\tfont-style: italic;\n\tfont-weight: 300;\n\tcolor: rgba(0, 0, 0, 0.4);\n}\n\n.todoapp input::input-placeholder {\n\tfont-style: italic;\n\tfont-weight: 300;\n\tcolor: rgba(0, 0, 0, 0.4);\n}\n\n.todoapp h1 {\n\tposition: absolute;\n\ttop: -140px;\n\twidth: 100%;\n\tfont-size: 80px;\n\tfont-weight: 200;\n\ttext-align: center;\n\tcolor: #b83f45;\n\t-webkit-text-rendering: optimizeLegibility;\n\t-moz-text-rendering: optimizeLegibility;\n\ttext-rendering: optimizeLegibility;\n}\n\n.new-todo,\n.edit {\n\tposition: relative;\n\tmargin: 0;\n\twidth: 100%;\n\tfont-size: 24px;\n\tfont-family: inherit;\n\tfont-weight: inherit;\n\tline-height: 1.4em;\n\tcolor: inherit;\n\tpadding: 6px;\n\tborder: 1px solid #999;\n\tbox-shadow: inset 0 -1px 5px 0 rgba(0, 0, 0, 0.2);\n\tbox-sizing: border-box;\n\t-webkit-font-smoothing: antialiased;\n\t-moz-osx-font-smoothing: grayscale;\n}\n\n.new-todo {\n\tpadding: 16px 16px 16px 60px;\n\tborder: none;\n\tbackground: rgba(0, 0, 0, 0.003);\n\tbox-shadow: inset 0 -2px 1px rgba(0,0,0,0.03);\n}\n\n.main {\n\tposition: relative;\n\tz-index: 2;\n\tborder-top: 1px solid #e6e6e6;\n}\n\n.toggle-all {\n\twidth: 1px;\n\theight: 1px;\n\tborder: none; /* Mobile Safari */\n\topacity: 0;\n\tposition: absolute;\n\tright: 100%;\n\tbottom: 100%;\n}\n\n.toggle-all + label {\n\twidth: 60px;\n\theight: 34px;\n\tfont-size: 0;\n\tposition: absolute;\n\ttop: -52px;\n\tleft: -13px;\n\t-webkit-transform: rotate(90deg);\n\ttransform: rotate(90deg);\n}\n\n.toggle-all + label:before {\n\tcontent: '\10095';\n\tfont-size: 22px;\n\tcolor: #e6e6e6;\n\tpadding: 10px 27px 10px 27px;\n}\n\n.toggle-all:checked + label:before {\n\tcolor: #737373;\n}\n\n.todo-list {\n\tmargin: 0;\n\tpadding: 0;\n\tlist-style: none;\n}\n\n.todo-list li {\n\tposition: relative;\n\tfont-size: 24px;\n\tborder-bottom: 1px solid #ededed;\n}\n\n.todo-list li:last-child {\n\tborder-bottom: none;\n}\n\n.todo-list li.editing {\n\tborder-bottom: none;\n\tpadding: 0;\n}\n\n.todo-list li.editing .edit {\n\tdisplay: block;\n\twidth: calc(100% - 43px);\n\tpadding: 12px 16px;\n\tmargin: 0 0 0 43px;\n}\n\n.todo-list li.editing .view {\n\tdisplay: none;\n}\n\n.todo-list li .toggle {\n\ttext-align: center;\n\twidth: 40px;\n\t/* auto, since non-WebKit browsers doesn't support input styling */\n\theight: auto;\n\tposition: absolute;\n\ttop: 0;\n\tbottom: 0;\n\tmargin: auto 0;\n\tborder: none; /* Mobile Safari */\n\t-webkit-appearance: none;\n\tappearance: none;\n}\n\n.todo-list li .toggle {\n\topacity: 0;\n}\n\n.todo-list li .toggle + label {\n\t/*\n\t\tFirefox requires `#` to be escaped - https://bugzilla.mozilla.org/show_bug.cgi?id=922433\n\t\tIE and Edge requires *everything* to be escaped to render, so we do that instead of just the `#` - https://developer.microsoft.com/en-us/microsoft-edge/platform/issues/7157459/\n\t*/\n\tbackground-image: url('data:image/svg+xml;utf8,%3Csvg%20xmlns%3D%22http%3A//www.w3.org/2000/svg%22%20width%3D%2240%22%20height%3D%2240%22%20viewBox%3D%22-10%20-18%20100%20135%22%3E%3Ccircle%20cx%3D%2250%22%20cy%3D%2250%22%20r%3D%2250%22%20fill%3D%22none%22%20stroke%3D%22%23ededed%22%20stroke-width%3D%223%22/%3E%3C/svg%3E');\n\tbackground-repeat: no-repeat;\n\tbackground-position: center left;\n}\n\n.todo-list li .toggle:checked + label {\n\tbackground-image: url('data:image/svg+xml;utf8,%3Csvg%20xmlns%3D%22http%3A//www.w3.org/2000/svg%22%20width%3D%2240%22%20height%3D%2240%22%20viewBox%3D%22-10%20-18%20100%20135%22%3E%3Ccircle%20cx%3D%2250%22%20cy%3D%2250%22%20r%3D%2250%22%20fill%3D%22none%22%20stroke%3D%22%23bddad5%22%20stroke-width%3D%223%22/%3E%3Cpath%20fill%3D%22%235dc2af%22%20d%3D%22M72%2025L42%2071%2027%2056l-4%204%2020%2020%2034-52z%22/%3E%3C/svg%3E');\n}\n\n.todo-list li label {\n\tword-break: break-all;\n\tpadding: 15px 15px 15px 60px;\n\tdisplay: block;\n\tline-height: 1.2;\n\ttransition: color 0.4s;\n\tfont-weight: 400;\n\tcolor: #4d4d4d;\n}\n\n.todo-list li.completed label {\n\tcolor: #cdcdcd;\n\ttext-decoration: line-through;\n}\n\n.todo-list li .destroy {\n\tdisplay: none;\n\tposition: absolute;\n\ttop: 0;\n\tright: 10px;\n\tbottom: 0;\n\twidth: 40px;\n\theight: 40px;\n\tmargin: auto 0;\n\tfont-size: 30px;\n\tcolor: #cc9a9a;\n\tmargin-bottom: 11px;\n\ttransition: color 0.2s ease-out;\n}\n\n.todo-list li .destroy:hover {\n\tcolor: #af5b5e;\n}\n\n.todo-list li .destroy:after {\n\tcontent: '\215';\n}\n\n.todo-list li:hover .destroy {\n\tdisplay: block;\n}\n\n.todo-list li .edit {\n\tdisplay: none;\n}\n\n.todo-list li.editing:last-child {\n\tmargin-bottom: -1px;\n}\n\n.footer {\n\tpadding: 10px 15px;\n\theight: 20px;\n\ttext-align: center;\n\tfont-size: 15px;\n\tborder-top: 1px solid #e6e6e6;\n}\n\n.footer:before {\n\tcontent: '';\n\tposition: absolute;\n\tright: 0;\n\tbottom: 0;\n\tleft: 0;\n\theight: 50px;\n\toverflow: hidden;\n\tbox-shadow: 0 1px 1px rgba(0, 0, 0, 0.2),\n\t 0 8px 0 -3px #f6f6f6,\n\t 0 9px 1px -3px rgba(0, 0, 0, 0.2),\n\t 0 16px 0 -6px #f6f6f6,\n\t 0 17px 2px -6px rgba(0, 0, 0, 0.2);\n}\n\n.todo-count {\n\tfloat: left;\n\ttext-align: left;\n}\n\n.todo-count strong {\n\tfont-weight: 300;\n}\n\n.filters {\n\tmargin: 0;\n\tpadding: 0;\n\tlist-style: none;\n\tposition: absolute;\n\tright: 0;\n\tleft: 0;\n}\n\n.filters li {\n\tdisplay: inline;\n}\n\n.filters li a {\n\tcolor: inherit;\n\tmargin: 3px;\n\tpadding: 3px 7px;\n\ttext-decoration: none;\n\tborder: 1px solid transparent;\n\tborder-radius: 3px;\n}\n\n.filters li a:hover {\n\tborder-color: rgba(175, 47, 47, 0.1);\n}\n\n.filters li a.selected {\n\tborder-color: rgba(175, 47, 47, 0.2);\n}\n\n.clear-completed,\nhtml .clear-completed:active {\n\tfloat: right;\n\tposition: relative;\n\tline-height: 20px;\n\ttext-decoration: none;\n\tcursor: pointer;\n}\n\n.clear-completed:hover {\n\ttext-decoration: underline;\n}\n\n.info {\n\tmargin: 65px auto 0;\n\tcolor: #4d4d4d;\n\tfont-size: 11px;\n\ttext-shadow: 0 1px 0 rgba(255, 255, 255, 0.5);\n\ttext-align: center;\n}\n\n.info p {\n\tline-height: 1;\n}\n\n.info a {\n\tcolor: inherit;\n\ttext-decoration: none;\n\tfont-weight: 400;\n}\n\n.info a:hover {\n\ttext-decoration: underline;\n}\n\n/*\n\tHack to remove background from Mobile Safari.\n\tCan't use it globally since it destroys checkboxes in Firefox\n*/\n@media screen and (-webkit-min-device-pixel-ratio:0) {\n\t.toggle-all,\n\t.todo-list li .toggle {\n\t\tbackground: none;\n\t}\n\n\t.todo-list li .toggle {\n\t\theight: 40px;\n\t}\n}\n\n@media (max-width: 430px) {\n\t.footer {\n\t\theight: 50px;\n\t}\n\n\t.filters {\n\t\tbottom: 10px;\n\t}\n}\n" + +todoMVC + :: ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , MonadFix m + , MonadHold t m + , PostBuild t m + ) + => m () +todoMVC = el "div" $ do + elAttr "section" ("class" =: "todoapp") $ do + mainHeader + rec tasks <- foldDyn ($) initialTasks $ mergeWith (.) + [ fmap insertNew_ newTask + , listModifyTasks + , fmap (const $ Map.filter $ not . taskCompleted) clearCompleted -- Call out the type and purpose of these things + ] + newTask <- taskEntry + listModifyTasks <- taskList activeFilter tasks + (activeFilter, clearCompleted) <- controls tasks + return () + infoFooter + +-- | Display the main header +mainHeader :: DomBuilder t m => m () +mainHeader = el "h1" $ text "todos" + +-- | Strip leading and trailing whitespace from the user's entry, and discard it if nothing remains +stripDescription :: Text -> Maybe Text +stripDescription d = + let trimmed = T.strip d + in if T.null trimmed + then Nothing + else Just trimmed + +keyCodeIs :: Key -> KeyCode -> Bool +keyCodeIs k c = keyCodeLookup c == k + +-- | Display an input field; produce new Tasks when the user creates them +taskEntry + :: ( DomBuilder t m + , MonadFix m + , PostBuild t m + , DomBuilderSpace m ~ GhcjsDomSpace + ) + => m (Event t Task) +taskEntry = el "header" $ do + -- Create the textbox; it will be cleared whenever the user presses enter + rec let newValueEntered = keypress Enter descriptionBox + descriptionBox <- inputElement $ def + & inputElementConfig_setValue .~ fmap (const "") newValueEntered + & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ + mconcat [ "class" =: "new-todo" + , "placeholder" =: "What needs to be done?" + , "name" =: "newTodo" + , "type" =: "text" + ] + -- -- Request focus on this element when the widget is done being built + -- schedulePostBuild $ liftIO $ focus $ _textInput_element descriptionBox + let -- | Get the current value of the textbox whenever the user hits enter + newValue = tag (current $ value descriptionBox) newValueEntered + -- -- Set focus when the user enters a new Task + -- performEvent_ $ fmap (const $ liftIO $ focus $ _textInput_element descriptionBox) newValueEntered + return $ fmap (\d -> Task d False) $ fmapMaybe stripDescription newValue + +-- | Display the user's Tasks, subject to a Filter; return requested modifications to the Task list +taskList + :: ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , PostBuild t m + , MonadHold t m + , MonadFix m + , Ord k + ) + => Dynamic t Filter + -> Dynamic t (Map k Task) + -> m (Event t (Map k Task -> Map k Task)) +taskList activeFilter tasks = elAttr "section" ("class" =: "main") $ do + let toggleAllState = all taskCompleted . Map.elems <$> tasks + toggleAllAttrs = ffor tasks $ \t -> "class" =: "toggle-all" <> "name" =: "toggle" <> if Map.null t then "style" =: "visibility:hidden" else mempty + toggleAll <- toggleInput toggleAllAttrs toggleAllState + elAttr "label" ("for" =: "toggle-all") $ text "Mark all as complete" + -- Filter the item list + let visibleTasks = zipDynWith (Map.filter . satisfiesFilter) activeFilter tasks + -- Hide the item list itself if there are no items + let itemListAttrs = ffor visibleTasks $ \t -> mconcat + [ "class" =: "todo-list" + , if Map.null t then "style" =: "visibility:hidden" else mempty + ] + -- Display the items + items <- elDynAttr "ul" itemListAttrs $ list visibleTasks todoItem + -- Aggregate the changes produced by the elements + let combineItemChanges = fmap (foldl' (.) id) . mergeList . map (\(k, v) -> fmap (flip Map.update k) v) . Map.toList + itemChangeEvent = fmap combineItemChanges items + itemChanges = switch $ current itemChangeEvent + return itemChanges + +toggleInput + :: ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , MonadFix m + , MonadHold t m + , PostBuild t m + ) + => Dynamic t (Map AttributeName Text) + -> Dynamic t Bool + -> m (Event t ()) +toggleInput dynAttrs dynChecked = do + let attrs = (<> "class" =: "toggle") . ("type" =: "checkbox" <>) <$> dynAttrs + updatedAttrs = fmap Just <$> updated dynAttrs + updatedChecked = updated dynChecked + initialAttrs <- sample $ current attrs + initialChecked <- sample $ current dynChecked + domEvent Click <$> inputElement (def + & inputElementConfig_initialChecked .~ initialChecked + & inputElementConfig_setChecked .~ updatedChecked + & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ updatedAttrs + & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ initialAttrs) + +buildCompletedCheckbox + :: ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , MonadFix m + , MonadHold t m + , PostBuild t m + ) + => Dynamic t Task + -> Dynamic t Text + -> m (Event t Bool, Event t (), Event t ()) +buildCompletedCheckbox todo description = elAttr "div" ("class" =: "view") $ do + -- Display the todo item's completed status, and allow it to be set + completed <- holdUniqDyn $ fmap taskCompleted todo + checkboxClicked <- toggleInput (constDyn mempty) completed + let setCompleted = fmap not $ tag (current completed) checkboxClicked + -- Display the todo item's name for viewing purposes + (descriptionLabel, _) <- el' "label" $ dynText description + -- Display the button for deleting the todo item + (destroyButton, _) <- elAttr' "button" ("class" =: "destroy") $ return () + return ( setCompleted + , domEvent Click destroyButton + , void $ domEvent Dblclick descriptionLabel + ) + +-- | Display an individual todo item +todoItem + :: ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , MonadFix m + , MonadHold t m + , PostBuild t m + ) + => Dynamic t Task + -> m (Event t (Task -> Maybe Task)) +todoItem todo = do + description <- holdUniqDyn $ fmap taskDescription todo + rec -- Construct the attributes for our element + let attrs = ffor2 todo editing' $ \t e -> Map.singleton "class" $ T.unwords $ concat + [ [ "completed" | taskCompleted t ] + , [ "editing" | e ] + ] + (editing', changeTodo) <- elDynAttr "li" attrs $ do + (setCompleted, destroy, startEditing) <- buildCompletedCheckbox todo description + -- Set the current value of the editBox whenever we start editing (it's not visible in non-editing mode) + let setEditValue = tag (current description) $ ffilter id $ updated editing' + editBox <- inputElement $ def + & inputElementConfig_setValue .~ setEditValue + & inputElementConfig_elementConfig . elementConfig_initialAttributes + .~ ("class" =: "edit" <> "name" =: "title") + let -- Set the todo item's description when the user leaves the textbox or presses enter in it + setDescription = tag (current $ value editBox) $ leftmost + [ keypress Enter editBox + , domEvent Blur editBox + ] + -- Cancel editing (without changing the item's description) when the user presses escape in the textbox + cancelEdit = keypress Escape editBox + -- Put together all the ways the todo item can change itself + changeSelf = mergeWith (>=>) [ fmap (\c t -> Just $ t { taskCompleted = c }) setCompleted + , fmap (const $ const Nothing) destroy + , fmap (\d t -> fmap (\trimmed -> t { taskDescription = trimmed }) $ stripDescription d) setDescription + ] + -- Set focus on the edit box when we enter edit mode +-- postGui <- askPostGui +-- performEvent_ $ fmap (const $ liftIO $ void $ forkIO $ threadDelay 1000 >> postGui (liftIO $ focus $ _textInput_element editBox)) startEditing -- Without the delay, the focus doesn't take effect because the element hasn't become unhidden yet; we need to use postGui to ensure that this is threadsafe when built with GTK + -- Determine the current editing state; initially false, but can be modified by various events + editing <- holdDyn False $ leftmost [ fmap (const True) startEditing + , fmap (const False) setDescription + , fmap (const False) cancelEdit + ] + return (editing, changeSelf) + -- Return an event that fires whenever we change ourselves + return changeTodo + +buildActiveFilter + :: ( DomBuilder t m + , PostBuild t m + , MonadHold t m + , MonadFix m + ) + => m (Dynamic t Filter) +buildActiveFilter = elAttr "ul" ("class" =: "filters") $ do + rec activeFilter <- holdDyn All setFilter + let filterButton f = el "li" $ do + let buttonAttrs = ffor activeFilter $ \af -> "class" =: if f == af then "selected" else "" + (e, _) <- elDynAttr' "a" buttonAttrs $ text $ T.pack $ show f + return $ fmap (const f) (domEvent Click e) + allButton <- filterButton All + text " " + activeButton <- filterButton Active + text " " + completedButton <- filterButton Completed + let setFilter = leftmost [allButton, activeButton, completedButton] + return activeFilter + +-- | Display the control footer; return the user's currently-selected filter and an event that fires when the user chooses to clear all completed events +controls + :: ( DomBuilder t m + , PostBuild t m + , MonadHold t m + , MonadFix m + ) + => Dynamic t (Map k Task) + -> m (Dynamic t Filter, Event t ()) +controls tasks = do + -- Determine the attributes for the footer; it is invisible when there are no todo items + let controlsAttrs = ffor tasks $ \t -> "class" =: "footer" <> if Map.null t then "style" =: "visibility:hidden" else mempty + elDynAttr "footer" controlsAttrs $ do + -- Compute the number of completed and uncompleted tasks + let (tasksCompleted, tasksLeft) = splitDynPure $ ffor tasks $ \m -> + let completed = Map.size $ Map.filter taskCompleted m + in (completed, Map.size m - completed) + elAttr "span" ("class" =: "todo-count") $ do + el "strong" $ dynText $ fmap (T.pack . show) tasksLeft + dynText $ fmap (\n -> (if n == 1 then " item" else " items") <> " left") tasksLeft + activeFilter <- buildActiveFilter + let clearCompletedAttrs = ffor tasksCompleted $ \n -> mconcat + [ "class" =: "clear-completed" + , if n > 0 then mempty else "hidden" =: "" + ] + (clearCompletedAttrsButton, _) <- elDynAttr' "button" clearCompletedAttrs $ dynText $ ffor tasksCompleted $ \n -> "Clear completed (" <> T.pack (show n) <> ")" + return (activeFilter, domEvent Click clearCompletedAttrsButton) + +-- | Display static information about the application +infoFooter :: DomBuilder t m => m () +infoFooter = elAttr "footer" ("class" =: "info") $ do + el "p" $ text "Click to edit a todo" + el "p" $ do + text "Written by " + elAttr "a" ("href" =: "https://github.com/ryantrinkle") $ text "Ryan Trinkle" + el "p" $ do + text "Part of " + elAttr "a" ("href" =: "http://todomvc.com") $ text "TodoMVC"