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`
+
+[](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"