Feed a Haskell continuation to EventSource.addEventTarget

Field test ElementBuilder



Expose __asterius_instance in global context, for use with chrome devtools

.circleci/config.yml

@@ -24,6 +24,7 @@ jobs:
             docker start -a $(docker create terrorjack/asterius:$ASTERIUS_REV stack --no-terminal test asterius:stableptr --test-arguments="--optimize")
             docker start -a $(docker create terrorjack/asterius:$ASTERIUS_REV stack --no-terminal test asterius:rtsapi --test-arguments="--debug")
             docker start -a $(docker create terrorjack/asterius:$ASTERIUS_REV stack --no-terminal test asterius:rtsapi --test-arguments="--optimize")
+            docker start -a $(docker create terrorjack/asterius:$ASTERIUS_REV stack --no-terminal test asterius:todomvc --test-arguments="--optimize")
 
             docker push terrorjack/asterius:$ASTERIUS_REV
             docker push terrorjack/asterius:$CIRCLE_BRANCH

.gitignore

@@ -9,3 +9,5 @@ site/
 .idea/
 node_modules/
 *.dump-*
+yarn.lock
+package-lock.json

appveyor.yml

@@ -25,5 +25,6 @@ build_script:
   - stack --no-terminal test asterius:stableptr --test-arguments="--optimize"
   - stack --no-terminal test asterius:rtsapi --test-arguments="--debug"
   - stack --no-terminal test asterius:rtsapi --test-arguments="--optimize"
+  - stack --no-terminal test asterius:todomvc --test-arguments="--optimize"
 
 test: off

asterius/app/ahc-link.hs

@@ -148,6 +148,7 @@ genNode Task {..} LinkReport {..} = do
   pure $
     mconcat $
     [ byteString rts_buf
+    , "let __asterius_instance = null;\n"
     , "async function main() {\n"
     , "const i = await newAsteriusInstance({functionSymbols: "
     , string7 $ show $ map fst $ sortOn snd $ M.toList functionSymbolMap
@@ -155,15 +156,11 @@ genNode Task {..} LinkReport {..} = do
     ] <>
     (case target of
        Node ->
-         [ "require(\"fs\").readFileSync("
+         [ "await require(\"fs\").promises.readFile("
          , string7 $ show $ takeFileName outputWasm
          , ")"
          ]
-       Browser ->
-         [ "await (await fetch("
-         , string7 $ show $ takeFileName outputWasm
-         , ")).arrayBuffer()"
-         ]) <>
+       Browser -> ["fetch(", string7 $ show $ takeFileName outputWasm, ")"]) <>
     [ ", jsffiFactory: "
     , generateFFIImportObjectFactory bundledFFIMarshalState
     , ", staticsSymbolMap: "
@@ -171,6 +168,7 @@ genNode Task {..} LinkReport {..} = do
     , ", functionSymbolMap: "
     , genSymbolDict functionSymbolMap
     , "});\n"
+    , "__asterius_instance = i\n;"
     , "("
     , string7 asteriusInstanceCallback
     , ")(i);\n"

asterius/package.yaml

@@ -17,6 +17,8 @@ extra-source-files:
   - test/rtsapi/**/*.hs
   - test/stableptr/**/*.hs
   - test/th/**/*.hs
+  - test/todomvc/**/*.hs
+  - test/todomvc/**/*.html
 
 data-files:
   - rts/rts.js
@@ -137,3 +139,9 @@ tests:
     main: rtsapi.hs
     dependencies:
       - asterius
+
+  todomvc:
+    source-dirs: test
+    main: todomvc.hs
+    dependencies:
+      - asterius

asterius/rts/rts.js

@@ -20,265 +20,267 @@ async function newAsteriusInstance(req) {
   function __asterius_freeStablePtr(sp) {
     delete __asterius_SPT[sp];
   }
-  const resultObject = await WebAssembly.instantiate(
-    req.bufferSource,
-    Object.assign(
-      req.jsffiFactory({
-        JSRefs: __asterius_jsffi_JSRefs,
-        newJSRef: __asterius_jsffi_newJSRef,
-        makeHaskellCallback: s => () => {
-          const cap = req.staticsSymbolMap.MainCapability,
-            export_funcs = __asterius_wasm_instance.exports;
-          export_funcs.rts_evalIO(cap, __asterius_deRefStablePtr(s), 0);
-        },
-        makeHaskellCallback1: s => ev => {
-          const cap = req.staticsSymbolMap.MainCapability,
-            export_funcs = __asterius_wasm_instance.exports;
-          export_funcs.rts_evalIO(
+  const importObject = Object.assign(
+    req.jsffiFactory({
+      JSRefs: __asterius_jsffi_JSRefs,
+      newJSRef: __asterius_jsffi_newJSRef,
+      makeHaskellCallback: s => () => {
+        const cap = req.staticsSymbolMap.MainCapability,
+          export_funcs = __asterius_wasm_instance.exports;
+        export_funcs.rts_evalIO(cap, __asterius_deRefStablePtr(s), 0);
+      },
+      makeHaskellCallback1: s => ev => {
+        const cap = req.staticsSymbolMap.MainCapability,
+          export_funcs = __asterius_wasm_instance.exports;
+        export_funcs.rts_evalIO(
+          cap,
+          export_funcs.rts_apply(
             cap,
-            export_funcs.rts_apply(
-              cap,
-              __asterius_deRefStablePtr(s),
-              export_funcs.rts_mkInt(cap, __asterius_jsffi_newJSRef(ev))
-            ),
-            0
-          );
-        }
-      }),
-      {
-        Math: Math,
-        rts: {
-          newStablePtr: __asterius_newStablePtr,
-          deRefStablePtr: __asterius_deRefStablePtr,
-          freeStablePtr: __asterius_freeStablePtr,
-          printI64: (lo, hi) => console.log(__asterius_newI64(lo, hi)),
-          print: console.log,
-          panic: e =>
-            console.error(
-              "[ERROR] " +
-                [
-                  "errGCEnter1",
-                  "errGCFun",
-                  "errBarf",
-                  "errStgGC",
-                  "errUnreachableBlock",
-                  "errHeapOverflow",
-                  "errMegaBlockGroup",
-                  "errUnimplemented",
-                  "errAtomics",
-                  "errSetBaseReg",
-                  "errBrokenFunction",
-                  "errAssert",
-                  "errSchedulerReenteredFromHaskell",
-                  "errIllegalSchedState",
-                  "errIllegalPrevWhatNext",
-                  "errIllegalThreadReturnCode"
-                ][e - 1]
-            ),
-          __asterius_current_memory: p => {
-            console.log("[INFO] Current Memory Pages: " + p);
-            return p;
-          },
-          __asterius_grow_memory: (p0, dp) => {
-            console.log(
-              "[INFO] Previous Memory Pages: " +
-                p0 +
-                ", Allocated Memory Pages: " +
-                dp
-            );
-            return p0;
-          },
-          __asterius_memory_trap_trigger: (p_lo, p_hi) =>
-            console.error(
-              "[ERROR] Uninitialized memory trapped at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0")
-            ),
-          __asterius_load_i64: (p_lo, p_hi, v_lo, v_hi) =>
-            console.log(
-              "[INFO] Loading i64 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: 0x" +
-                __asterius_newI64(v_lo, v_hi)
-                  .toString(16)
-                  .padStart(8, "0")
-            ),
-          __asterius_store_i64: (p_lo, p_hi, v_lo, v_hi) =>
-            console.log(
-              "[INFO] Storing i64 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: 0x" +
-                __asterius_newI64(v_lo, v_hi)
-                  .toString(16)
-                  .padStart(8, "0")
-            ),
-          __asterius_load_i8: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Loading i8 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_store_i8: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Storing i8 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_load_i16: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Loading i16 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_store_i16: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Storing i16 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_load_i32: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Loading i32 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_store_i32: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Storing i32 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_load_f32: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Loading f32 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_store_f32: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Storing f32 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_load_f64: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Loading f64 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_store_f64: (p_lo, p_hi, v) =>
-            console.log(
-              "[INFO] Storing f64 at 0x" +
-                __asterius_newI64(p_lo, p_hi)
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", value: " +
-                v
-            ),
-          __asterius_traceCmm: f =>
-            console.log(
-              "[INFO] Entering " +
-                __asterius_func_syms[f - 1] +
-                ", Sp: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_Sp()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", SpLim: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_SpLim()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", Hp: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_Hp()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", HpLim: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_HpLim()
-                  .toString(16)
-                  .padStart(8, "0")
-            ),
-          __asterius_traceCmmBlock: (f, lbl) =>
-            console.log(
-              "[INFO] Branching to " +
-                __asterius_func_syms[f - 1] +
-                " basic block " +
-                lbl +
-                ", Sp: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_Sp()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", SpLim: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_SpLim()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", Hp: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_Hp()
-                  .toString(16)
-                  .padStart(8, "0") +
-                ", HpLim: 0x" +
-                __asterius_wasm_instance.exports
-                  .__asterius_Load_HpLim()
-                  .toString(16)
-                  .padStart(8, "0")
-            ),
-          __asterius_traceCmmSetLocal: (f, i, lo, hi) =>
-            console.log(
-              "[INFO] In " +
-                __asterius_func_syms[f - 1] +
-                ", Setting local register " +
-                i +
-                " to 0x" +
-                __asterius_newI64(lo, hi)
-                  .toString(16)
-                  .padStart(8, "0")
-            )
-        }
+            __asterius_deRefStablePtr(s),
+            export_funcs.rts_mkInt(cap, __asterius_jsffi_newJSRef(ev))
+          ),
+          0
+        );
       }
-    )
+    }),
+    {
+      Math: Math,
+      rts: {
+        newStablePtr: __asterius_newStablePtr,
+        deRefStablePtr: __asterius_deRefStablePtr,
+        freeStablePtr: __asterius_freeStablePtr,
+        printI64: (lo, hi) => console.log(__asterius_newI64(lo, hi)),
+        print: console.log,
+        panic: e =>
+          console.error(
+            "[ERROR] " +
+              [
+                "errGCEnter1",
+                "errGCFun",
+                "errBarf",
+                "errStgGC",
+                "errUnreachableBlock",
+                "errHeapOverflow",
+                "errMegaBlockGroup",
+                "errUnimplemented",
+                "errAtomics",
+                "errSetBaseReg",
+                "errBrokenFunction",
+                "errAssert",
+                "errSchedulerReenteredFromHaskell",
+                "errIllegalSchedState",
+                "errIllegalPrevWhatNext",
+                "errIllegalThreadReturnCode"
+              ][e - 1]
+          ),
+        __asterius_current_memory: p => {
+          console.log("[INFO] Current Memory Pages: " + p);
+          return p;
+        },
+        __asterius_grow_memory: (p0, dp) => {
+          console.log(
+            "[INFO] Previous Memory Pages: " +
+              p0 +
+              ", Allocated Memory Pages: " +
+              dp
+          );
+          return p0;
+        },
+        __asterius_memory_trap_trigger: (p_lo, p_hi) =>
+          console.error(
+            "[ERROR] Uninitialized memory trapped at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0")
+          ),
+        __asterius_load_i64: (p_lo, p_hi, v_lo, v_hi) =>
+          console.log(
+            "[INFO] Loading i64 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: 0x" +
+              __asterius_newI64(v_lo, v_hi)
+                .toString(16)
+                .padStart(8, "0")
+          ),
+        __asterius_store_i64: (p_lo, p_hi, v_lo, v_hi) =>
+          console.log(
+            "[INFO] Storing i64 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: 0x" +
+              __asterius_newI64(v_lo, v_hi)
+                .toString(16)
+                .padStart(8, "0")
+          ),
+        __asterius_load_i8: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Loading i8 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_store_i8: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Storing i8 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_load_i16: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Loading i16 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_store_i16: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Storing i16 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_load_i32: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Loading i32 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_store_i32: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Storing i32 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_load_f32: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Loading f32 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_store_f32: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Storing f32 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_load_f64: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Loading f64 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_store_f64: (p_lo, p_hi, v) =>
+          console.log(
+            "[INFO] Storing f64 at 0x" +
+              __asterius_newI64(p_lo, p_hi)
+                .toString(16)
+                .padStart(8, "0") +
+              ", value: " +
+              v
+          ),
+        __asterius_traceCmm: f =>
+          console.log(
+            "[INFO] Entering " +
+              __asterius_func_syms[f - 1] +
+              ", Sp: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_Sp()
+                .toString(16)
+                .padStart(8, "0") +
+              ", SpLim: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_SpLim()
+                .toString(16)
+                .padStart(8, "0") +
+              ", Hp: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_Hp()
+                .toString(16)
+                .padStart(8, "0") +
+              ", HpLim: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_HpLim()
+                .toString(16)
+                .padStart(8, "0")
+          ),
+        __asterius_traceCmmBlock: (f, lbl) =>
+          console.log(
+            "[INFO] Branching to " +
+              __asterius_func_syms[f - 1] +
+              " basic block " +
+              lbl +
+              ", Sp: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_Sp()
+                .toString(16)
+                .padStart(8, "0") +
+              ", SpLim: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_SpLim()
+                .toString(16)
+                .padStart(8, "0") +
+              ", Hp: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_Hp()
+                .toString(16)
+                .padStart(8, "0") +
+              ", HpLim: 0x" +
+              __asterius_wasm_instance.exports
+                .__asterius_Load_HpLim()
+                .toString(16)
+                .padStart(8, "0")
+          ),
+        __asterius_traceCmmSetLocal: (f, i, lo, hi) =>
+          console.log(
+            "[INFO] In " +
+              __asterius_func_syms[f - 1] +
+              ", Setting local register " +
+              i +
+              " to 0x" +
+              __asterius_newI64(lo, hi)
+                .toString(16)
+                .padStart(8, "0")
+          )
+      }
+    }
   );
+  const resultObject = await (WebAssembly.instantiateStreaming
+    ? WebAssembly.instantiateStreaming(req.bufferSource, importObject)
+    : WebAssembly.instantiate(req.bufferSource, importObject));
   __asterius_wasm_instance = resultObject.instance;
   return {
     wasmModule: resultObject.module,
     wasmInstance: resultObject.instance,
     staticsSymbolMap: req.staticsSymbolMap,
-    functionSymbolMap: req.functionSymbolMap
+    functionSymbolMap: req.functionSymbolMap,
+    __asterius_jsffi_JSRefs: __asterius_jsffi_JSRefs,
+    __asterius_SPT: __asterius_SPT
   };
 }

asterius/src/Asterius/Workarounds.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 

asterius/test/todomvc.hs

@@ -0,0 +1,16 @@
+import System.Directory
+import System.Environment
+import System.Process
+
+main :: IO ()
+main = do
+  args <- getArgs
+  withCurrentDirectory "test/todomvc" $ callCommand "npm install"
+  callProcess "ahc-link" $
+    [ "--browser"
+    , "--input"
+    , "test/todomvc/todomvc.hs"
+    , "--output-link-report"
+    , "test/todomvc/todomvc.link.txt"
+    ] <>
+    args

asterius/test/todomvc/AsteriusPrim.hs

@@ -0,0 +1,173 @@
+{-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+module AsteriusPrim
+  ( JSString
+  , emptyJSString
+  , concatJSString
+  , indexJSString
+  , toJSString
+  , fromJSString
+  , JSArray
+  , emptyJSArray
+  , concatJSArray
+  , indexJSArray
+  , toJSArray
+  , fromJSArray
+  , JSObject
+  , emptyJSObject
+  , indexJSObject
+  , callJSObjectMethod
+  , console
+  , document
+  , json
+  , window
+  , JSFunction
+  , callJSFunction
+  , makeHaskellCallback
+  , makeHaskellCallback1
+  , randomId
+  , trace
+  ) where
+
+import Data.List
+import Foreign.StablePtr
+
+type JSString = JSRef
+
+{-# INLINEABLE emptyJSString #-}
+emptyJSString :: JSString
+emptyJSString = js_string_empty
+
+{-# INLINEABLE concatJSString #-}
+concatJSString :: JSString -> JSString -> JSString
+concatJSString = js_concat
+
+{-# INLINEABLE indexJSString #-}
+indexJSString :: JSString -> Int -> Char
+indexJSString = js_string_tochar
+
+{-# INLINEABLE toJSString #-}
+toJSString :: String -> JSString
+toJSString = foldl' (\s c -> js_concat s (js_string_fromchar c)) js_string_empty
+
+{-# INLINEABLE fromJSString #-}
+fromJSString :: JSString -> String
+fromJSString s = [js_string_tochar s i | i <- [0 .. js_length s - 1]]
+
+type JSArray = JSRef
+
+{-# INLINEABLE emptyJSArray #-}
+emptyJSArray :: JSArray
+emptyJSArray = js_array_empty
+
+{-# INLINEABLE concatJSArray #-}
+concatJSArray :: JSArray -> JSArray -> JSArray
+concatJSArray = js_concat
+
+{-# INLINEABLE indexJSArray #-}
+indexJSArray :: JSArray -> Int -> JSRef
+indexJSArray = js_index_by_int
+
+{-# INLINEABLE toJSArray #-}
+toJSArray :: [JSRef] -> JSArray
+toJSArray = foldl' js_concat js_array_empty
+
+{-# INLINEABLE fromJSArray #-}
+fromJSArray :: JSArray -> [JSRef]
+fromJSArray arr = [js_index_by_int arr i | i <- [0 .. js_length arr - 1]]
+
+type JSObject = JSRef
+
+{-# INLINEABLE emptyJSObject #-}
+emptyJSObject :: JSObject
+emptyJSObject = js_object_empty
+
+{-# INLINEABLE indexJSObject #-}
+indexJSObject :: JSObject -> String -> JSRef
+indexJSObject obj k = js_index_by_jsref obj (toJSString k)
+
+{-# INLINEABLE callJSObjectMethod #-}
+callJSObjectMethod :: JSObject -> String -> [JSRef] -> IO JSRef
+callJSObjectMethod obj f args =
+  js_function_apply (js_index_by_jsref obj (toJSString f)) obj (toJSArray args)
+
+{-# INLINEABLE console #-}
+console :: JSObject
+console = js_console
+
+{-# INLINEABLE document #-}
+document :: JSObject
+document = js_document
+
+{-# INLINEABLE json #-}
+json :: JSObject
+json = js_json
+
+{-# INLINEABLE window #-}
+window :: JSObject
+window = js_window
+
+type JSFunction = JSRef
+
+{-# INLINEABLE callJSFunction #-}
+callJSFunction :: JSFunction -> [JSRef] -> IO JSRef
+callJSFunction f args = js_function_apply f js_object_empty (toJSArray args)
+
+{-# INLINEABLE makeHaskellCallback #-}
+makeHaskellCallback :: IO () -> IO JSRef
+makeHaskellCallback m = do
+  s <- newStablePtr m
+  js_make_hs_callback s
+
+{-# INLINEABLE makeHaskellCallback1 #-}
+makeHaskellCallback1 :: (JSRef -> IO ()) -> IO JSRef
+makeHaskellCallback1 m = do
+  s <- newStablePtr m
+  js_make_hs_callback1 s
+
+{-# INLINEABLE randomId #-}
+randomId :: IO String
+randomId = fromJSString <$> js_random_id
+
+foreign import javascript "\"\"" js_string_empty :: JSRef
+
+foreign import javascript "${1}.concat(${2})" js_concat
+  :: JSRef -> JSRef -> JSRef
+
+foreign import javascript "${1}.length" js_length :: JSRef -> Int
+
+foreign import javascript "String.fromCodePoint(${1})" js_string_fromchar
+  :: Char -> JSRef
+
+foreign import javascript "${1}.codePointAt(${2})" js_string_tochar
+  :: JSRef -> Int -> Char
+
+foreign import javascript "[]" js_array_empty :: JSRef
+
+foreign import javascript "${1}[${2}]" js_index_by_int :: JSRef -> Int -> JSRef
+
+foreign import javascript "{}" js_object_empty :: JSRef
+
+foreign import javascript "${1}[${2}]" js_index_by_jsref
+  :: JSRef -> JSRef -> JSRef
+
+foreign import javascript "console" js_console :: JSRef
+
+foreign import javascript "document" js_document :: JSRef
+
+foreign import javascript "JSON" js_json :: JSRef
+
+foreign import javascript "window" js_window :: JSRef
+
+foreign import javascript "${1}.apply(${2}, ${3})" js_function_apply
+  :: JSRef -> JSRef -> JSRef -> IO JSRef
+
+foreign import javascript "__asterius_jsffi.makeHaskellCallback(${1})" js_make_hs_callback
+  :: StablePtr (IO ()) -> IO JSRef
+
+foreign import javascript "__asterius_jsffi.makeHaskellCallback1(${1})" js_make_hs_callback1
+  :: StablePtr (JSRef -> IO ()) -> IO JSRef
+
+foreign import javascript "Math.random().toString(36).slice(2)" js_random_id :: IO JSRef
+
+foreign import javascript "console.log(\"Veni, vidi, vici\")" trace :: IO ()

asterius/test/todomvc/ElementBuilder.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
+{-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+module ElementBuilder
+  ( Element(..)
+  , emptyElement
+  , buildElement
+  ) where
+
+import Control.Monad
+import Data.Foldable
+import qualified Data.Map.Strict as Map
+import WebAPI
+
+import AsteriusPrim
+
+data Element
+  = Element { className :: String
+            , attributes :: Map.Map String String
+            , children :: [Element]
+            , hidden :: Bool
+            , eventHandlers :: Map.Map String (JSRef -> IO ()) }
+  | TextNode String
+
+emptyElement :: Element
+emptyElement =
+  Element
+    { className = ""
+    , attributes = mempty
+    , children = mempty
+    , hidden = False
+    , eventHandlers = mempty
+    }
+
+{-# INLINEABLE buildElement #-}
+buildElement :: Element -> IO JSRef
+buildElement Element {..} = do
+  e <- createElement className
+  for_ (Map.toList attributes) $ uncurry $ setAttribute e
+  for_ children $ buildElement >=> appendChild e
+  when hidden $ setHidden e True
+  for_ (Map.toList eventHandlers) $ uncurry $ addEventListener e
+  pure e
+buildElement (TextNode s) = createTextNode s

asterius/test/todomvc/TodoView.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+module TodoView where
+
+foreign import javascript "document.querySelector(\".todoapp\")" newTodo
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".main\")" main' :: JSRef
+
+foreign import javascript "document.querySelector(\".toggle-all\")" toggleAll
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".todo-list\")" todoList
+  :: IO JSRef
+
+foreign import javascript "document.querySelector(\".footer\")" footer :: JSRef
+
+foreign import javascript "document.querySelector(\".todo-count\")" todoCount
+  :: IO JSRef
+
+foreign import javascript "document.querySelector(\".filters\")" filters
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".filters > li:nth-child(1) > a\")" allAnchor
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".filters > li:nth-child(2) > a\")" activeAnchor
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".filters > li:nth-child(3) > a\")" completedAnchor
+  :: JSRef
+
+foreign import javascript "document.querySelector(\".clear-completed\")" clearCompleted
+  :: JSRef

asterius/test/todomvc/WebAPI.hs

@@ -0,0 +1,70 @@
+{-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+module WebAPI
+  ( consoleLog
+  , createElement
+  , setAttribute
+  , appendChild
+  , setHidden
+  , addEventListener
+  , createTextNode
+  , replaceWith
+  ) where
+
+import AsteriusPrim
+
+{-# INLINEABLE consoleLog #-}
+consoleLog :: JSRef -> IO ()
+consoleLog = js_console_log
+
+{-# INLINEABLE createElement #-}
+createElement :: String -> IO JSRef
+createElement = js_createElement . toJSString
+
+{-# INLINEABLE setAttribute #-}
+setAttribute :: JSRef -> String -> String -> IO ()
+setAttribute e k v = js_setAttribute e (toJSString k) (toJSString v)
+
+{-# INLINEABLE appendChild #-}
+appendChild :: JSRef -> JSRef -> IO ()
+appendChild = js_appendChild
+
+{-# INLINEABLE setHidden #-}
+setHidden :: JSRef -> Bool -> IO ()
+setHidden = js_element_set_hidden
+
+{-# INLINEABLE addEventListener #-}
+addEventListener :: JSRef -> String -> (JSRef -> IO ()) -> IO ()
+addEventListener target event handler = do
+  callback <- makeHaskellCallback1 handler
+  js_addEventListener target (toJSString event) callback
+
+{-# INLINEABLE createTextNode #-}
+createTextNode :: String -> IO JSRef
+createTextNode = js_createTextNode . toJSString
+
+{-# INLINEABLE replaceWith #-}
+replaceWith :: JSRef -> JSRef -> IO ()
+replaceWith = js_replaceWith
+
+foreign import javascript "console.log(${1})" js_console_log :: JSRef -> IO ()
+
+foreign import javascript "document.createElement(${1})" js_createElement
+  :: JSRef -> IO JSRef
+
+foreign import javascript "${1}.setAttribute(${2},${3})" js_setAttribute
+  :: JSRef -> JSRef -> JSRef -> IO ()
+
+foreign import javascript "${1}.appendChild(${2})" js_appendChild
+  :: JSRef -> JSRef -> IO ()
+
+foreign import javascript "${1}.hidden = ${2}" js_element_set_hidden
+  :: JSRef -> Bool -> IO ()
+
+foreign import javascript "${1}.addEventListener(${2},${3})" js_addEventListener
+  :: JSRef -> JSRef -> JSRef -> IO ()
+
+foreign import javascript "document.createTextNode(${1})" js_createTextNode
+  :: JSRef -> IO JSRef
+
+foreign import javascript "${1}.replaceWith(${2})" js_replaceWith :: JSRef -> JSRef -> IO ()

asterius/test/todomvc/index.html

@@ -0,0 +1,75 @@
+<!doctype html>
+<html lang="en">
+
+<head>
+    <meta charset="utf-8">
+    <meta name="viewport" content="width=device-width, initial-scale=1">
+    <title>asterius • TodoMVC</title>
+    <link rel="stylesheet" href="node_modules/todomvc-common/base.css">
+    <link rel="stylesheet" href="node_modules/todomvc-app-css/index.css">
+</head>
+
+<body>
+    <section class="todoapp">
+        <header class="header">
+            <h1>todos</h1>
+            <input class="new-todo" placeholder="What needs to be done?" autofocus>
+        </header>
+        <!-- This section should be hidden by default and shown when there are todos -->
+        <section class="main">
+            <input id="toggle-all" class="toggle-all" type="checkbox">
+            <label for="toggle-all">Mark all as complete</label>
+            <ul class="todo-list">
+                <!-- These are here just to show the structure of the list items -->
+                <!-- List items should get the class `editing` when editing and `completed` when marked as completed -->
+                <li class="completed">
+                    <div class="view">
+                        <input class="toggle" type="checkbox" checked>
+                        <label>Taste JavaScript</label>
+                        <button class="destroy"></button>
+                    </div>
+                    <input class="edit" value="Create a TodoMVC template">
+                </li>
+                <li>
+                    <div class="view">
+                        <input class="toggle" type="checkbox">
+                        <label>Buy a unicorn</label>
+                        <button class="destroy"></button>
+                    </div>
+                    <input class="edit" value="Rule the web">
+                </li>
+            </ul>
+        </section>
+        <!-- This footer should hidden by default and shown when there are todos -->
+        <footer class="footer">
+            <!-- This should be `0 items left` by default -->
+            <span class="todo-count"><strong>0</strong> item left</span>
+            <!-- Remove this if you don't implement routing -->
+            <ul class="filters">
+                <li>
+                    <a class="selected" href="#/">All</a>
+                </li>
+                <li>
+                    <a href="#/active">Active</a>
+                </li>
+                <li>
+                    <a href="#/completed">Completed</a>
+                </li>
+            </ul>
+            <!-- Hidden if no completed items are left ↓ -->
+            <button class="clear-completed">Clear completed</button>
+        </footer>
+    </section>
+    <footer class="info">
+        <p>Double-click to edit a todo</p>
+        <!-- Remove the below line ↓ -->
+        <p>Template by <a href="http://sindresorhus.com">Sindre Sorhus</a></p>
+        <!-- Change this out with your name and url ↓ -->
+        <p>Created by <a href="http://todomvc.com">you</a></p>
+        <p>Part of <a href="http://todomvc.com">TodoMVC</a></p>
+    </footer>
+    <script src="node_modules/todomvc-common/base.js"></script>
+    <script src="todomvc.js"></script>
+</body>
+
+</html>

asterius/test/todomvc/package.json

@@ -0,0 +1,7 @@
+{
+  "private": true,
+  "dependencies": {
+    "todomvc-app-css": "^2.0.0",
+    "todomvc-common": "^1.0.0"
+  }
+}

asterius/test/todomvc/todomvc.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
+{-# OPTIONS_GHC
+  -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+import AsteriusPrim
+import qualified Data.Map.Strict as Map
+import ElementBuilder
+import TodoView
+import WebAPI
+
+data Todo = Todo
+  { key, text :: String
+  , completed :: Bool
+  }
+
+newtype TodoModel = TodoModel
+  { todos :: [Todo]
+  }
+
+data Route
+  = All
+  | Active
+  | Completed
+
+buildTodoElement :: Route -> Todo -> Element
+buildTodoElement route Todo {..} =
+  emptyElement
+    { className = "li"
+    , attributes =
+        Map.fromList $ [("class", "completed") | completed] <> [("id", key)]
+    , children =
+        [ emptyElement
+            { className = "div"
+            , attributes = Map.fromList [("class", "view")]
+            , children =
+                [ emptyElement
+                    { className = "input"
+                    , attributes =
+                        Map.fromList $
+                        [("checked", "true") | completed] <>
+                        [("class", "toggle"), ("type", "checkbox")]
+                    }
+                , emptyElement {className = "label", children = [TextNode text]}
+                , emptyElement
+                    { className = "button"
+                    , attributes = Map.fromList [("class", "destroy")]
+                    }
+                ]
+            }
+        , emptyElement
+            { className = "input"
+            , attributes = Map.fromList [("class", "edit"), ("value", "")]
+            }
+        ]
+    , hidden =
+        case route of
+          All -> False
+          Active -> completed
+          Completed -> not completed
+    }
+
+buildTodoList :: Route -> TodoModel -> Element
+buildTodoList route TodoModel {..} =
+  emptyElement
+    { className = "ul"
+    , attributes = Map.fromList [("class", "todo-list")]
+    , children = map (buildTodoElement route) todos
+    }
+
+todoApp :: TodoModel -> IO ()
+todoApp model = do
+  new_todo_list <- buildElement $ buildTodoList All model
+  consoleLog new_todo_list
+  old_todo_list <- todoList
+  consoleLog old_todo_list
+  replaceWith old_todo_list new_todo_list
+
+main :: IO ()
+main =
+  todoApp $
+  TodoModel
+    [ Todo {key = "0", text = "0", completed = True}
+    , Todo {key = "1", text = "1", completed = False}
+    ]