WASM hello world

it's generated by hpack

.gitignore

@@ -1,3 +1,4 @@
 dist-newstyle
 .direnv
 *.cabal
+cabal.project.local

Makefile

@@ -0,0 +1,15 @@
+
+all: out/numbersquare.wasm out/ghc_wasm_jsffi.js
+
+numbersquare.cabal: package.yaml
+	hpack
+
+out/numbersquare.wasm: app/*.hs src/*.hs numbersquare.cabal
+	wasm32-wasi-cabal install --installdir=out --overwrite-policy=always
+
+out/ghc_wasm_jsffi.js: out/numbersquare.wasm
+	$(shell wasm32-wasi-ghc --print-libdir)/post-link.mjs -i out/numbersquare.wasm -o out/ghc_wasm_jsffi.js
+
+.PHONY: clean
+clean:
+	rm -rf dist-newstyle out/numbersquare.wasm out/ghc_wasm_jsffi.js

README.org

@@ -0,0 +1,9 @@
+#+TITLE: Number Square
+
+* Number Square
+
+This is supposed to be a clone of [[https://www.gamesaien.com/game/fruit_box_a/][apple game]] (aka Fruit Box), with a
+couple of enhancements:
+
+- multiple game modes
+- multiplayer

app/App.hs

@@ -0,0 +1,19 @@
+module App where
+
+import Reflex
+import Reflex.Dom.Core
+
+import Language.Javascript.JSaddle
+
+testWidget ::
+    ( DomBuilder t m
+    , DomBuilderSpace m ~ GhcjsDomSpace
+    , MonadHold t m
+    , PostBuild t m
+    ) =>
+    m ()
+testWidget = elAttr "div" ("class" =: "content") do
+    text "hello, world!"
+
+start :: JSM ()
+start = mainWidget testWidget

app/Main.hs

@@ -1,4 +1,12 @@
+{-# LANGUAGE CPP #-}
+
 module Main (main) where
 
+import App qualified
+import Language.Javascript.JSaddle
+import Language.Javascript.JSaddle.Wasm qualified as W
+
+foreign export javascript "hs_start" main :: IO ()
+
 main :: IO ()
-main = putStrLn "hi"
+main = W.run $ App.start

cabal.project

@@ -1,2 +1,4 @@
 packages: ./numbersquare.cabal
 tests: True
+
+index-state: 2025-10-11T08:08:38Z

flake.lock

@@ -16,13 +16,68 @@
         "type": "github"
       }
     },
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1731533236,
+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+        "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": 1775305067,
+        "narHash": "sha256-KFWRYVYPgsXu51stX/7/416qc31HFltfQiHPc6nEmH0=",
+        "owner": "haskell-wasm",
+        "repo": "ghc-wasm-meta",
+        "rev": "60098a5076557e327b326a1a3ba3b5fb4fec1e49",
+        "type": "gitlab"
+      },
+      "original": {
+        "host": "gitlab.haskell.org",
+        "owner": "haskell-wasm",
+        "repo": "ghc-wasm-meta",
+        "type": "gitlab"
+      }
+    },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1777268161,
+        "lastModified": 1774399958,
-        "narHash": "sha256-bxrdOn8SCOv8tN4JbTF/TXq7kjo9ag4M+C8yzzIRYbE=",
+        "narHash": "sha256-Q+g1Np4wyNYpylt8RFM8UprAmyRoA3q3EZj7lQV+ZuQ=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "735a15e91bcb1b3e0883a91d3c9dfd4475d1bc54",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-25.11-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs_2": {
+      "locked": {
+        "lastModified": 1777954456,
+        "narHash": "sha256-hGdgeU2Nk87RAuZyYjyDjFL6LK7dAZN5RE9+hrDTkDU=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "1c3fe55ad329cbcb28471bb30f05c9827f724c76",
+        "rev": "549bd84d6279f9852cae6225e372cc67fb91a4c1",
         "type": "github"
       },
       "original": {
@@ -35,7 +90,23 @@
     "root": {
       "inputs": {
         "flake-compat": "flake-compat",
-        "nixpkgs": "nixpkgs"
+        "ghc-wasm-meta": "ghc-wasm-meta",
+        "nixpkgs": "nixpkgs_2"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
       }
     }
   },

flake.nix

@@ -3,6 +3,8 @@
 
   inputs = {
     nixpkgs.url = "github:nixos/nixpkgs?ref=nixos-unstable";
+    ghc-wasm-meta.url = "gitlab:haskell-wasm/ghc-wasm-meta?host=gitlab.haskell.org";
+
     flake-compat = {
       url = "github:NixOS/flake-compat";
       flake = false;
@@ -10,11 +12,19 @@
   };
 
   outputs =
-    { self, nixpkgs, ... }:
+    {
+      self,
+      nixpkgs,
+      ghc-wasm-meta,
+      ...
+    }:
     let
-      pkgs = nixpkgs.legacyPackages.x86_64-linux;
+      pkgs = import nixpkgs { system = "x86_64-linux"; };
     in
     {
-      devShells.x86_64-linux.default = pkgs.callPackage ./shell.nix { };
+      devShells.x86_64-linux.default = pkgs.callPackage ./shell.nix {
+        wasm32-wasi-cabal = ghc-wasm-meta.packages.x86_64-linux.wasm32-wasi-cabal-9_12;
+        wasm32-wasi-ghc = ghc-wasm-meta.packages.x86_64-linux.wasm32-wasi-ghc-9_12;
+      };
     };
 }

numbersquare.cabal

@@ -1,118 +0,0 @@
-cabal-version: 1.12
-
--- This file has been generated from package.yaml by hpack version 0.38.3.
---
--- see: https://github.com/sol/hpack
-
-name:           numbersquare
-version:        0.1.0
-synopsis:       a game where you number square
-description:    a game where you number square
-category:       Games
-author:         skulk
-maintainer:     skulk
-license:        BSD3
-license-file:   LICENSE
-build-type:     Simple
-
-library
-  exposed-modules:
-      Game
-      Types.BoardAction
-      Types.BoardPosition
-      Types.GameBoard
-      Types.GameMode
-      Types.GameState
-      Types.Player
-  other-modules:
-      Paths_numbersquare
-  hs-source-dirs:
-      src
-  default-extensions:
-      ImportQualifiedPost
-      DataKinds
-      FlexibleInstances
-      MultiParamTypeClasses
-      TypeFamilies
-      UndecidableInstances
-      OverloadedLabels
-      NamedFieldPuns
-      TypeOperators
-  ghc-options: -Wall
-  build-depends:
-      array
-    , base ==4.*
-    , binary
-    , containers
-    , display
-    , extra
-    , mtl
-    , optics
-    , random
-    , text
-  default-language: Haskell2010
-
-executable numbersquare
-  main-is: Main.hs
-  other-modules:
-      Paths_numbersquare
-  hs-source-dirs:
-      app
-  default-extensions:
-      ImportQualifiedPost
-      DataKinds
-      FlexibleInstances
-      MultiParamTypeClasses
-      TypeFamilies
-      UndecidableInstances
-      OverloadedLabels
-      NamedFieldPuns
-      TypeOperators
-  ghc-options: -Wall
-  build-depends:
-      array
-    , base ==4.*
-    , binary
-    , containers
-    , display
-    , extra
-    , mtl
-    , optics
-    , random
-    , text
-  default-language: Haskell2010
-
-test-suite numberspec-test
-  type: exitcode-stdio-1.0
-  main-is: Main.hs
-  other-modules:
-      Spec
-      Paths_numbersquare
-  hs-source-dirs:
-      test
-  default-extensions:
-      ImportQualifiedPost
-      DataKinds
-      FlexibleInstances
-      MultiParamTypeClasses
-      TypeFamilies
-      UndecidableInstances
-      OverloadedLabels
-      NamedFieldPuns
-      TypeOperators
-  ghc-options: -Wall -threaded -O0
-  build-depends:
-      QuickCheck
-    , array
-    , base ==4.*
-    , binary
-    , containers
-    , display
-    , extra
-    , hspec >=2.1.8
-    , mtl
-    , numbersquare
-    , optics
-    , random
-    , text
-  default-language: Haskell2010

out/.gitignore

@@ -0,0 +1,2 @@
+*.wasm
+ghc_wasm_jsffi.js

out/index.html

@@ -0,0 +1,12 @@
+<!DOCTYPE HTML>
+<html lang="en">
+    <head>
+        <title>WASM test</title>
+        <meta charset="utf-8">
+        <meta name="viewport" content="width=device-width, initial-scale=1">
+    </head>
+
+    <body>
+        <script src="./index.js" type="module"></script>
+    </body>
+</html>

out/index.js

@@ -0,0 +1,28 @@
+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 = ["GHCRTS=-H64m"];
+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);
+
+let __exports = {};
+
+const { instance } = await WebAssembly.instantiateStreaming(
+    fetch("numbersquare.wasm"),
+    {
+        ghc_wasm_jsffi: ghc_wasm_jsffi(__exports),
+        wasi_snapshot_preview1: wasi.wasiImport,
+    }
+);
+
+Object.assign(__exports, instance.exports);
+
+wasi.initialize(instance);
+console.log(instance)
+await instance.exports.hs_start(globalThis.example);

package.yaml

@@ -6,10 +6,11 @@ description: "a game where you number square"
 license: BSD3
 author: skulk
 
+language: GHC2021
 ghc-options: "-Wall"
 
 dependencies:
-  - "base == 4.*"
+  - base
   - random
   - array
   - text
@@ -30,6 +31,10 @@ default-extensions:
   - OverloadedLabels
   - NamedFieldPuns
   - TypeOperators
+  - BlockArguments
+  - OverloadedStrings
+
+build-type: Simple
 
 library:
   source-dirs:
@@ -39,11 +44,27 @@ executable:
   source-dirs:
     - app
   main: Main.hs
+  dependencies:
+    - base
+    - reflex
+    - reflex-dom-core
+    - "ghcjs-dom == 0.9.*"
+    - jsaddle
+    - jsaddle-wasm
+    - ghc-experimental
+  when:
+    - condition: arch(wasm32)
+      ghc-options:
+        -no-hs-main
+        -optl-mexec-model=reactor
+        "-optl-Wl,--export=hs_start"
+      cpp-options:
+        -DWASM
 
 tests:
   numberspec-test:
     main: "Main.hs"
-    ghc-options: "-threaded -O0"
+    ghc-options: "-O0"
     source-dirs:
       - test
 

shell.nix

@@ -1,20 +1,58 @@
 {
+  callPackage,
   haskellPackages,
   haskell,
   zlib,
   watchexec,
+  wasm32-wasi-cabal,
+  wasm32-wasi-ghc,
+  writeShellApplication,
+  nodejs,
+  pkg-config,
+  python3,
+  fetchFromGitHub,
 }:
-haskellPackages.developPackage {
+let
+  # TODO: this information is duplicated at the bottom. need to fix that.
+  ghc-wasm-compat-rev = "ef21ada9436046c7b118314d0c73752253ec58e1";
+  ghc-wasm-compat-src = fetchFromGitHub {
+    owner = "konn";
+    repo = "ghc-wasm-earthly";
+    rev = ghc-wasm-compat-rev;
+    hash = "sha256-oUf7HFLNxBZ/roFRe5q7Sz0D0ZRygu8prxEYoYuhSU8=";
+  };
+in
+let
+  shell = haskellPackages.developPackage {
     name = "numbersquare";
     root = ./.;
+    overrides = _: _: {
+      ghc-wasm-compat =
+        haskellPackages.callCabal2nix "ghc-wasm-compat" "${ghc-wasm-compat-src}/ghc-wasm-compat"
+          { };
+    };
     modifier =
       let
         addBuildTools =
           drv:
           haskell.lib.addBuildTools drv (
-          [ watchexec ]
+            [
+              watchexec
+              wasm32-wasi-cabal
+              wasm32-wasi-ghc
+              nodejs
+              pkg-config
+              (writeShellApplication {
+                name = "dev-server";
+                text = ''
+                  python -m http.server -d ./out
+                '';
+                runtimeInputs = [ python3 ];
+              })
+            ]
             ++ (with haskellPackages; [
               fourmolu
+              happy
               haskell-language-server
               cabal-install
               hpack
@@ -26,4 +64,16 @@ haskellPackages.developPackage {
         addExtraLibraries = drv: haskell.lib.addExtraLibraries drv [ zlib ];
       in
       drv: addExtraLibraries (addBuildTools drv);
-}
+  };
+in
+shell.overrideAttrs (old: {
+  shellHook = (old.shellHook or "") + ''
+    cat > cabal.project.local <<EOF
+    source-repository-package
+      type: git
+      location: https://github.com/konn/ghc-wasm-earthly
+      tag: ${ghc-wasm-compat-rev}
+      subdir: ghc-wasm-compat
+    EOF
+  '';
+})

src/Game.hs

@@ -1 +1,19 @@
 module Game where
+
+import Optics
+import Types.BoardAction
+import Types.GameBoard
+import Types.GameMode
+import Types.GameState
+
+makeMove :: (GameMode mode) => PlayerIndex -> BoardAction -> GameState mode -> GameState mode
+makeMove (MkPlayerIndex idx) (SelectSquare topLeft bottomRight) state@MkGameState{board} =
+    let tiles = select topLeft bottomRight board
+        gMode = gameMode board
+        transform =
+            case check gMode tiles of
+                Just score ->
+                    over (#players % (ix idx) % #score) (+ score)
+                -- invalid move, do nothing
+                Nothing -> id
+     in transform state

src/Types/GameBoard.hs

@@ -27,7 +27,7 @@ clear topLeft bottomRight gBoard@MkGameBoard{cells} = gBoard{cells = newCells}
   where
     newCells = cells // map (,Nothing) (range (topLeft, bottomRight))
 
-selectCheck :: (GameMode mode) => BoardPosition -> BoardPosition -> GameBoard mode -> Bool
+selectCheck :: (GameMode mode) => BoardPosition -> BoardPosition -> GameBoard mode -> Maybe Int
 selectCheck topLeft bottomRight board@MkGameBoard{gameMode} =
     check gameMode (select topLeft bottomRight board)
 

src/Types/GameMode.hs

@@ -8,7 +8,6 @@ import Data.Bifunctor (Bifunctor (first))
 import Data.Kind (Type)
 import Display
 import System.Random.Stateful (Random (randomR), RandomGen)
-import Types.BoardPosition
 
 {- | The type of game that is being played.
 
@@ -19,7 +18,7 @@ that sums up to 'n'.
 -}
 class (Display (Tile t), Show (Tile t), Eq (Tile t), Eq t, Show t) => GameMode t where
     data Tile t :: Type
-    check :: t -> [Tile t] -> Bool
+    check :: t -> [Tile t] -> Maybe Int
     gen :: (RandomGen g) => t -> g -> (Tile t, g)
 
 data SumTo = MkSumTo Int
@@ -28,8 +27,8 @@ data SumTo = MkSumTo Int
 instance GameMode SumTo where
     data Tile SumTo = IntTile Int deriving (Eq, Show)
 
-    check (MkSumTo n) [] = n == 0
+    check (MkSumTo n) [] = if n == 0 then Just 0 else Nothing
-    check (MkSumTo n) lst = n == sum (map toInt lst)
+    check (MkSumTo n) lst = if n == sum (map toInt lst) then Just (length lst) else Nothing
       where
         toInt (IntTile a) = a
     gen (MkSumTo n) = first IntTile . randomR (1, n)

src/Types/GameState.hs

@@ -26,12 +26,3 @@ newGame gmode playerInfos rng =
     let (initialBoard, nextRng) = newRandomBoard gmode 10 10 rng
         playerStates = S.fromList $ map (\n -> MkPlayerState{name = n, score = 0}) playerInfos
      in (MkGameState initialBoard playerStates, nextRng)
-
-makeMove :: (GameMode mode) => PlayerIndex -> BoardAction -> GameState mode -> GameState mode
-makeMove (MkPlayerIndex idx) (SelectSquare topLeft bottomRight) state@MkGameState{board} =
-    let tiles = select topLeft bottomRight board
-        gMode = gameMode board
-     in if check gMode tiles
-            then
-                over (#players % (ix idx) % #score) (+ 1) state
-            else state

test/Spec.hs

@@ -4,13 +4,20 @@
 module Spec where
 
 import Data.Array (array, elems)
+import Data.Sequence qualified as S
 import Display (displayText)
+import Game
+import Optics
 import Test.Hspec
+import Types.BoardAction
 import Types.GameBoard
 import Types.GameMode (SumTo (MkSumTo), Tile (IntTile))
+import Types.GameState
+import Types.Player
 
 spec :: Spec
-spec = describe "gameboard" do
+spec = do
+    describe "gameboard" do
         let tiles =
                 array
                     ((0, 0), (1, 1))
@@ -25,9 +32,37 @@ spec = describe "gameboard" do
             displayText gameBoard `shouldBe` "1 2 \n3 4 \n"
 
         it "validates a move" do
-        selectCheck (0, 0) (1, 1) gameBoard `shouldBe` True
+            selectCheck (0, 0) (1, 1) gameBoard `shouldBe` Just 4
-        selectCheck (0, 0) (0, 1) gameBoard `shouldBe` False
+            selectCheck (0, 0) (0, 1) gameBoard `shouldBe` Nothing
 
         it "clears properly" do
             let cleared = clear (0, 0) (0, 1) gameBoard
             elems (cells cleared) `shouldBe` [Nothing, Nothing, Just $ IntTile 3, Just $ IntTile 4]
+
+    describe "player moves" do
+        let tiles =
+                array
+                    ((0, 0), (1, 1))
+                    [ ((0, 0), Just $ IntTile 5)
+                    , ((0, 1), Just $ IntTile 5)
+                    , ((1, 0), Just $ IntTile 1)
+                    , ((1, 1), Just $ IntTile 2)
+                    ]
+            gameBoard = MkGameBoard{width = 2, height = 2, gameMode = MkSumTo 10, cells = tiles}
+            initialState = MkGameState{board = gameBoard, players = S.fromList [MkPlayerState (MkPlayerName "P1") 0]}
+
+        it "increases score if sum equals target" do
+            let action = SelectSquare (0, 0) (0, 1)
+                newState = makeMove (MkPlayerIndex 0) action initialState
+
+            preview (#players % ix 0 % #score) newState `shouldBe` Just 2
+
+        it "does not increase score if sum does not equal target" do
+            let invalidAction = SelectSquare (0, 0) (1, 0)
+                newState = makeMove (MkPlayerIndex 0) invalidAction initialState
+            preview (#players % ix 0 % #score) newState `shouldBe` Just 0
+
+        it "does not change anything if invalid player index is provided" do
+            let action = SelectSquare (0, 0) (0, 1)
+                newState = makeMove (MkPlayerIndex 99) action initialState
+            preview (#players % ix 99 % #score) newState `shouldBe` Nothing