diff --git a/.circleci/config.yml b/.circleci/config.yml index e6e5d381..a2cffded 100644 --- a/.circleci/config.yml +++ b/.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 diff --git a/.gitignore b/.gitignore index 620e8d2d..14a25e0b 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,5 @@ site/ .idea/ node_modules/ *.dump-* +yarn.lock +package-lock.json diff --git a/appveyor.yml b/appveyor.yml index da288113..07e50de7 100644 --- a/appveyor.yml +++ b/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 diff --git a/asterius/app/ahc-link.hs b/asterius/app/ahc-link.hs index 2af2a140..4091189a 100644 --- a/asterius/app/ahc-link.hs +++ b/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" diff --git a/asterius/package.yaml b/asterius/package.yaml index d3aa7a9d..281503ec 100644 --- a/asterius/package.yaml +++ b/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 diff --git a/asterius/rts/rts.js b/asterius/rts/rts.js index 95f69b3e..0c08d02a 100644 --- a/asterius/rts/rts.js +++ b/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 }; } diff --git a/asterius/src/Asterius/Workarounds.hs b/asterius/src/Asterius/Workarounds.hs index 79f82c41..0bf8122f 100644 --- a/asterius/src/Asterius/Workarounds.hs +++ b/asterius/src/Asterius/Workarounds.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/asterius/test/todomvc.hs b/asterius/test/todomvc.hs new file mode 100644 index 00000000..88cbf66c --- /dev/null +++ b/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 diff --git a/asterius/test/todomvc/AsteriusPrim.hs b/asterius/test/todomvc/AsteriusPrim.hs new file mode 100644 index 00000000..c13184f0 --- /dev/null +++ b/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 () diff --git a/asterius/test/todomvc/ElementBuilder.hs b/asterius/test/todomvc/ElementBuilder.hs new file mode 100644 index 00000000..3fac8468 --- /dev/null +++ b/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 diff --git a/asterius/test/todomvc/TodoView.hs b/asterius/test/todomvc/TodoView.hs new file mode 100644 index 00000000..34ad2d5f --- /dev/null +++ b/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 diff --git a/asterius/test/todomvc/WebAPI.hs b/asterius/test/todomvc/WebAPI.hs new file mode 100644 index 00000000..62093865 --- /dev/null +++ b/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 () diff --git a/asterius/test/todomvc/index.html b/asterius/test/todomvc/index.html new file mode 100644 index 00000000..21367db3 --- /dev/null +++ b/asterius/test/todomvc/index.html @@ -0,0 +1,75 @@ + + + + + + + asterius • TodoMVC + + + + + +
+
+

todos

+ +
+ +
+ + + +
+ + +
+ + + + + + diff --git a/asterius/test/todomvc/package.json b/asterius/test/todomvc/package.json new file mode 100644 index 00000000..e939a50f --- /dev/null +++ b/asterius/test/todomvc/package.json @@ -0,0 +1,7 @@ +{ + "private": true, + "dependencies": { + "todomvc-app-css": "^2.0.0", + "todomvc-common": "^1.0.0" + } +} diff --git a/asterius/test/todomvc/todomvc.hs b/asterius/test/todomvc/todomvc.hs new file mode 100644 index 00000000..61dffff7 --- /dev/null +++ b/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} + ]